trunk/runtime/IBBlob.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011                                                 }
{************************************************************************}

unit IBBlob;

{$mode Delphi}

interface

uses
  SysUtils, Classes, IBHeader, IBErrorCodes, IBExternals, DB, IB, IBDatabase;


const
  DefaultBlobSegmentSize = 16 * 1024;

type
  TIBBlobStates = (bsUninitialised, bsDataPending, bsData, bsModified);

  { TIBBlobStream }
  TIBBlobStream = class(TStream)
  private
    FBase: TIBBase;
    FBlobID: TISC_QUAD;
    FBlobMaxSegmentSize: Int64;
    FBlobNumSegments: Int64;
    FBlobSize: Int64;
    FBlobType: Short;  { 0 = segmented, 1 = streamed }
    FBuffer: PChar;
    FHandle: TISC_BLOB_HANDLE;
    FMode: TBlobStreamMode;
    FPosition: Int64;
    FBlobState: TIBBlobStates;
    function GetModified: Boolean;
  protected
    procedure CloseBlob;
    procedure CreateBlob;
    procedure EnsureBlobInitialized;
    procedure EnsureLoaded;
    procedure GetBlobInfo;
    function  GetSize: Int64; override;
    function GetDatabase: TIBDatabase;
    function GetDBHandle: PISC_DB_HANDLE;
    function GetTransaction: TIBTransaction;
    function GetTRHandle: PISC_TR_HANDLE;
    procedure OpenBlob;
    procedure SetBlobID(Value: TISC_QUAD);
    procedure SetDatabase(Value: TIBDatabase);
    procedure SetMode(Value: TBlobStreamMode);
    procedure SetState(aValue: TIBBlobStates);
    procedure SetTransaction(Value: TIBTransaction);
  public
    constructor Create;
    destructor Destroy; override;
    function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
    procedure CheckReadable;
    procedure CheckWritable;
    procedure Finalize;
    procedure LoadFromFile(Filename: string);
    procedure LoadFromStream(Stream: TStream);
    function Read(var Buffer; Count: Longint): Longint; override;
    procedure SaveToFile(Filename: string);
    procedure SaveToStream(Stream: TStream);
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    procedure SetSize(const NewSize: Int64); override;
    procedure SetSize(NewSize: Longint); override;
    procedure Truncate;
    function Write(const Buffer; Count: Longint): Longint; override;
    property Handle: TISC_BLOB_HANDLE read FHandle;
    property BlobID: TISC_QUAD read FBlobID write SetBlobID;
    property BlobMaxSegmentSize: Int64 read FBlobMaxSegmentSize;
    property BlobNumSegments: Int64 read FBlobNumSegments;
    property BlobSize: Int64 read GetSize;
    property BlobType: Short read FBlobType;
    property Database: TIBDatabase read GetDatabase write SetDatabase;
    property DBHandle: PISC_DB_HANDLE read GetDBHandle;
    property Mode: TBlobStreamMode read FMode write SetMode;
    property Modified: Boolean read GetModified;
    property Transaction: TIBTransaction read GetTransaction write SetTransaction;
    property TRHandle: PISC_TR_HANDLE read GetTRHandle;
  end;

  procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
                      TotalSize: Int64; var BlobType: Short);
  function GetBlobCharSetID(hDB_Handle: TISC_DB_HANDLE; hTR_Handle: TISC_TR_HANDLE;
                      tableName, columnName: PChar): short;
  procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
  procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);

implementation

uses IBIntf;

procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
                      TotalSize: Int64; var BlobType: Short);
var
  items: array[0..3] of Char;
  results: array[0..99] of Char;
  i, item_length: Integer;
  item: Integer;
begin
  items[0] := Char(isc_info_blob_num_segments);
  items[1] := Char(isc_info_blob_max_segment);
  items[2] := Char(isc_info_blob_total_length);
  items[3] := Char(isc_info_blob_type);

  if isc_blob_info(StatusVector, hBlobHandle, 4, @items[0], SizeOf(results),
                    @results[0]) > 0 then
    IBDatabaseError;

  i := 0;
  while (i < SizeOf(results)) and (results[i] <> Char(isc_info_end)) do
  begin
    item := Integer(results[i]); Inc(i);
    item_length := isc_vax_integer(@results[i], 2); Inc(i, 2);
    case item of
      isc_info_blob_num_segments:
        NumSegments := isc_portable_integer(@results[i], item_length);
      isc_info_blob_max_segment:
        MaxSegmentSize := isc_portable_integer(@results[i], item_length);
      isc_info_blob_total_length:
        TotalSize := isc_portable_integer(@results[i], item_length);
      isc_info_blob_type:
        BlobType := isc_portable_integer(@results[i], item_length);
    end;
    Inc(i, item_length);
  end;
end;

function GetBlobCharSetID(hDB_Handle: TISC_DB_HANDLE;
  hTR_Handle: TISC_TR_HANDLE; tableName, columnName: PChar): short;
var desc: TISC_BLOB_DESC;
    uGlobal: array [0..31] of char;
begin
  if isc_blob_lookup_desc(StatusVector,@hDB_Handle,@hTR_Handle,
                tableName,columnName,@desc,@uGlobal) > 0 then
    IBDatabaseError;

  Result := desc.blob_desc_charset;
end;

procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
var
  CurPos: Int64;
  BytesRead, SegLen: UShort;
  LocalBuffer: PChar;
begin
  CurPos := 0;
  LocalBuffer := Buffer;
  SegLen := UShort(DefaultBlobSegmentSize);
  while (CurPos < BlobSize) do
  begin
    if (CurPos + SegLen > BlobSize) then
      SegLen := BlobSize - CurPos;
    if not ((isc_get_segment(StatusVector, hBlobHandle, @BytesRead, SegLen,
                             LocalBuffer) = 0) or
            (StatusVectorArray[1] = isc_segment)) then
      IBDatabaseError;
    Inc(LocalBuffer, BytesRead);
    Inc(CurPos, BytesRead);
    BytesRead := 0;
  end;
end;

procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar;
  BlobSize: Int64);
var
  CurPos: Int64;
  SegLen: Long;
begin
  CurPos := 0;
  SegLen := DefaultBlobSegmentSize;
  while (CurPos < BlobSize) do
  begin
    if (CurPos + SegLen > BlobSize) then
      SegLen := BlobSize - CurPos;
    if isc_put_segment(StatusVector, hBlobHandle, SegLen,
         PChar(@Buffer[CurPos])) > 0 then
      IBDatabaseError;
    Inc(CurPos, SegLen);
  end;
end;


{ TIBBlobStream }
constructor TIBBlobStream.Create;
begin
  inherited Create;
  FBase := TIBBase.Create(Self);
  FBuffer := nil;
  FBlobSize := 0;
  FBlobState := bsUninitialised;
end;

destructor TIBBlobStream.Destroy;
begin
  SetState(bsUninitialised);
  FBase.Free;
  SetSize(0);
  inherited Destroy;
end;

function TIBBlobStream.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
begin
  result := 0;
  if Transaction <> nil then
    result := Transaction.Call(ErrCode, RaiseError)
  else if RaiseError and (ErrCode > 0) then
    IBDataBaseError;
end;

procedure TIBBlobStream.CheckReadable;
begin
  if FMode = bmWrite then IBError(ibxeBlobCannotBeRead, [nil]);
end;

procedure TIBBlobStream.CheckWritable;
begin
  if FMode = bmRead then IBError(ibxeBlobCannotBeWritten, [nil]);
end;

function TIBBlobStream.GetModified: Boolean;
begin
  Result := FBlobState = bsModified;
end;

procedure TIBBlobStream.CloseBlob;
begin
  Finalize;
  SetState(bsUninitialised);
end;

procedure TIBBlobStream.CreateBlob;
begin
  CheckWritable;
  FBlobID.gds_quad_high := 0;
  FBlobID.gds_quad_low := 0;
  SetState(bsData);
  SetSize(0);
end;

procedure TIBBlobStream.EnsureBlobInitialized;
begin
  if FBlobState = bsUninitialised then
    case FMode of
      bmWrite:
        CreateBlob;
      bmReadWrite: begin
        if (FBlobID.gds_quad_high = 0) and
           (FBlobID.gds_quad_low = 0) then
          CreateBlob
        else
          OpenBlob;
      end;
      else
        OpenBlob;
    end;
end;

procedure TIBBlobStream.EnsureLoaded;
begin
  EnsureBlobInitialized;
  if FBlobState = bsDataPending then
  begin
    SetSize(FBlobSize);
    try
      IBBlob.ReadBlob(@FHandle, FBuffer, FBlobSize);
    except
      Call(isc_close_blob(StatusVector, @FHandle), False);
      raise;
    end;
    SetState(bsData);
  end;
end;

procedure TIBBlobStream.Finalize;
begin
  if FBlobState <> bsModified then
    exit;
  if FBlobSize > 0 then
  begin
    { need to start writing to a blob, create one }
    Call(isc_create_blob2(StatusVector, DBHandle, TRHandle, @FHandle, @FBlobID,
                         0, nil), True);
    IBBlob.WriteBlob(@FHandle, FBuffer, FBlobSize);
    Call(isc_close_blob(StatusVector, @FHandle), True);
  end
  else
  begin
    FBlobID.gds_quad_high := 0;
    FBlobID.gds_quad_low := 0;
  end;
  SetState(bsData);
end;

procedure TIBBlobStream.GetBlobInfo;
var
  iBlobSize: Int64;
begin
  IBBlob.GetBlobInfo(@FHandle, FBlobNumSegments, FBlobMaxSegmentSize,
    iBlobSize, FBlobType);
  SetSize(iBlobSize);
end;

function TIBBlobStream.GetSize: Int64;
begin
  EnsureBlobInitialized;
  Result := FBlobSize;
end;

function TIBBlobStream.GetDatabase: TIBDatabase;
begin
  result := FBase.Database;
end;

function TIBBlobStream.GetDBHandle: PISC_DB_HANDLE;
begin
  result := FBase.DBHandle;
end;

function TIBBlobStream.GetTransaction: TIBTransaction;
begin
  result := FBase.Transaction;
end;

function TIBBlobStream.GetTRHandle: PISC_TR_HANDLE;
begin
  result := FBase.TRHandle;
end;

procedure TIBBlobStream.LoadFromFile(Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TIBBlobStream.LoadFromStream(Stream: TStream);
begin
  CheckWritable;
  EnsureBlobInitialized;
  Stream.Position := 0;
  SetSize(Stream.Size);
  if FBlobSize <> 0 then
    Stream.ReadBuffer(FBuffer^, FBlobSize);
  SetState(bsModified);
end;

procedure TIBBlobStream.OpenBlob;
begin
  CheckReadable;
  Call(isc_open_blob2(StatusVector, DBHandle, TRHandle, @FHandle,
                     @FBlobID, 0, nil), True);
  try
    GetBlobInfo;
    {Defer reading in blob until read method called}
  except
    Call(isc_close_blob(StatusVector, @FHandle), False);
    raise;
  end;
  SetState(bsDataPending);
end;

function TIBBlobStream.Read(var Buffer; Count: Longint): Longint;
begin
  CheckReadable;
  EnsureLoaded;
  if (Count <= 0) then
  begin
    result := 0;
    exit;
  end;
  if (FPosition + Count > FBlobSize) then
    result := FBlobSize - FPosition
  else
    result := Count;
  Move(FBuffer[FPosition], Buffer, result);
  Inc(FPosition, Result);
end;

procedure TIBBlobStream.SaveToFile(Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TIBBlobStream.SaveToStream(Stream: TStream);
begin
  CheckReadable;
  EnsureLoaded;
  if FBlobSize <> 0 then
  begin
    Seek(0, soFromBeginning);
    Stream.WriteBuffer(FBuffer^, FBlobSize);
  end;
end;

function TIBBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  EnsureBlobInitialized;
  case Origin of
    soBeginning     : FPosition := Offset;
    soCurrent       : Inc(FPosition, Offset);
    soEnd           : FPosition := FBlobSize + Offset;
  end;
  result := FPosition;
end;

procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
begin
  System.Move(Value, FBlobID, SizeOf(TISC_QUAD));
  SetState(bsUninitialised);
end;

procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
begin
  FBase.Database := Value;
  SetState(bsUninitialised);
end;

procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
begin
  FMode := Value;
  SetState(bsUninitialised);
end;

procedure TIBBlobStream.SetState(aValue: TIBBlobStates);
begin
  if FBlobState = aValue then Exit;

  if FBlobState = bsDataPending then
    Call(isc_close_blob(StatusVector, @FHandle), True);

  FBlobState := aValue;
end;

procedure TIBBlobStream.SetSize(const NewSize: Int64);
begin
  if (NewSize <> FBlobSize) then
  begin
    ReallocMem(FBuffer, NewSize);
    FBlobSize := NewSize;
    if NewSize = 0 then
      FBuffer := nil;
  end;
end;

procedure TIBBlobStream.SetSize(NewSize: Longint);
begin
  SetSize(Int64(NewSize));
end;

procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
begin
  FBase.Transaction := Value;
  SetState(bsUninitialised);
end;

procedure TIBBlobStream.Truncate;
begin
  SetSize(0);
  SetState(bsModified);
end;

function TIBBlobStream.Write(const Buffer; Count: Longint): Longint;
begin
  CheckWritable;
  EnsureLoaded;  {Could be an untruncated bmReadWrite Blob}
  result := Count;
  if Count <= 0 then
    exit;
  if (FPosition + Count > FBlobSize) then
    SetSize(FPosition + Count);
  Move(Buffer, FBuffer[FPosition], Count);
  Inc(FPosition, Count);
  SetState(bsModified);
end;

end.
Revision:	41
Committed:	Sat Jul 16 12:25:48 2016 UTC (8 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	14766 byte(s)
Log Message:	Committing updates for Release R1-4-2
#	User	Rev	Content
1	tony	33	{************************************************************************}
2			{ }
3			{ Borland Delphi Visual Component Library }
4			{ InterBase Express core components }
5			{ }
6			{ Copyright (c) 1998-2000 Inprise Corporation }
7			{ }
8			{ InterBase Express is based in part on the product }
9			{ Free IB Components, written by Gregory H. Deatz for }
10			{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11			{ Free IB Components is used under license. }
12			{ }
13			{ The contents of this file are subject to the InterBase }
14			{ Public License Version 1.0 (the "License"); you may not }
15			{ use this file except in compliance with the License. You }
16			{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17			{ Software distributed under the License is distributed on }
18			{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19			{ express or implied. See the License for the specific language }
20			{ governing rights and limitations under the License. }
21			{ The Original Code was created by InterBase Software Corporation }
22			{ and its successors. }
23			{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24			{ Corporation. All Rights Reserved. }
25			{ Contributor(s): Jeff Overcash }
26			{ }
27			{ IBX For Lazarus (Firebird Express) }
28			{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29			{ Portions created by MWA Software are copyright McCallum Whyman }
30			{ Associates Ltd 2011 }
31			{************************************************************************}
32
33			unit IBBlob;
34
35	tony	41	{$mode Delphi}
36	tony	33
37			interface
38
39			uses
40			SysUtils, Classes, IBHeader, IBErrorCodes, IBExternals, DB, IB, IBDatabase;
41
42
43			const
44	tony	41	DefaultBlobSegmentSize = 16 * 1024;
45	tony	33
46			type
47	tony	41	TIBBlobStates = (bsUninitialised, bsDataPending, bsData, bsModified);
48
49	tony	33	{ TIBBlobStream }
50			TIBBlobStream = class(TStream)
51			private
52			FBase: TIBBase;
53			FBlobID: TISC_QUAD;
54			FBlobMaxSegmentSize: Int64;
55			FBlobNumSegments: Int64;
56			FBlobSize: Int64;
57			FBlobType: Short; { 0 = segmented, 1 = streamed }
58			FBuffer: PChar;
59			FHandle: TISC_BLOB_HANDLE;
60			FMode: TBlobStreamMode;
61			FPosition: Int64;
62	tony	41	FBlobState: TIBBlobStates;
63			function GetModified: Boolean;
64	tony	33	protected
65			procedure CloseBlob;
66			procedure CreateBlob;
67			procedure EnsureBlobInitialized;
68	tony	41	procedure EnsureLoaded;
69	tony	33	procedure GetBlobInfo;
70	tony	41	function GetSize: Int64; override;
71	tony	33	function GetDatabase: TIBDatabase;
72			function GetDBHandle: PISC_DB_HANDLE;
73			function GetTransaction: TIBTransaction;
74			function GetTRHandle: PISC_TR_HANDLE;
75			procedure OpenBlob;
76			procedure SetBlobID(Value: TISC_QUAD);
77			procedure SetDatabase(Value: TIBDatabase);
78			procedure SetMode(Value: TBlobStreamMode);
79	tony	41	procedure SetState(aValue: TIBBlobStates);
80	tony	33	procedure SetTransaction(Value: TIBTransaction);
81			public
82			constructor Create;
83			destructor Destroy; override;
84			function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
85			procedure CheckReadable;
86			procedure CheckWritable;
87			procedure Finalize;
88			procedure LoadFromFile(Filename: string);
89			procedure LoadFromStream(Stream: TStream);
90			function Read(var Buffer; Count: Longint): Longint; override;
91			procedure SaveToFile(Filename: string);
92			procedure SaveToStream(Stream: TStream);
93			function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
94			procedure SetSize(const NewSize: Int64); override;
95			procedure SetSize(NewSize: Longint); override;
96			procedure Truncate;
97			function Write(const Buffer; Count: Longint): Longint; override;
98			property Handle: TISC_BLOB_HANDLE read FHandle;
99			property BlobID: TISC_QUAD read FBlobID write SetBlobID;
100			property BlobMaxSegmentSize: Int64 read FBlobMaxSegmentSize;
101			property BlobNumSegments: Int64 read FBlobNumSegments;
102	tony	41	property BlobSize: Int64 read GetSize;
103	tony	33	property BlobType: Short read FBlobType;
104			property Database: TIBDatabase read GetDatabase write SetDatabase;
105			property DBHandle: PISC_DB_HANDLE read GetDBHandle;
106			property Mode: TBlobStreamMode read FMode write SetMode;
107	tony	41	property Modified: Boolean read GetModified;
108	tony	33	property Transaction: TIBTransaction read GetTransaction write SetTransaction;
109			property TRHandle: PISC_TR_HANDLE read GetTRHandle;
110			end;
111
112			procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
113			TotalSize: Int64; var BlobType: Short);
114	tony	35	function GetBlobCharSetID(hDB_Handle: TISC_DB_HANDLE; hTR_Handle: TISC_TR_HANDLE;
115			tableName, columnName: PChar): short;
116	tony	33	procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
117			procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
118
119			implementation
120
121			uses IBIntf;
122
123			procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
124			TotalSize: Int64; var BlobType: Short);
125			var
126			items: array[0..3] of Char;
127			results: array[0..99] of Char;
128			i, item_length: Integer;
129			item: Integer;
130			begin
131			items[0] := Char(isc_info_blob_num_segments);
132			items[1] := Char(isc_info_blob_max_segment);
133			items[2] := Char(isc_info_blob_total_length);
134			items[3] := Char(isc_info_blob_type);
135
136			if isc_blob_info(StatusVector, hBlobHandle, 4, @items[0], SizeOf(results),
137			@results[0]) > 0 then
138			IBDatabaseError;
139
140			i := 0;
141			while (i < SizeOf(results)) and (results[i] <> Char(isc_info_end)) do
142			begin
143			item := Integer(results[i]); Inc(i);
144			item_length := isc_vax_integer(@results[i], 2); Inc(i, 2);
145			case item of
146			isc_info_blob_num_segments:
147			NumSegments := isc_portable_integer(@results[i], item_length);
148			isc_info_blob_max_segment:
149			MaxSegmentSize := isc_portable_integer(@results[i], item_length);
150			isc_info_blob_total_length:
151			TotalSize := isc_portable_integer(@results[i], item_length);
152			isc_info_blob_type:
153			BlobType := isc_portable_integer(@results[i], item_length);
154			end;
155			Inc(i, item_length);
156			end;
157			end;
158
159	tony	35	function GetBlobCharSetID(hDB_Handle: TISC_DB_HANDLE;
160			hTR_Handle: TISC_TR_HANDLE; tableName, columnName: PChar): short;
161			var desc: TISC_BLOB_DESC;
162			uGlobal: array [0..31] of char;
163			begin
164			if isc_blob_lookup_desc(StatusVector,@hDB_Handle,@hTR_Handle,
165			tableName,columnName,@desc,@uGlobal) > 0 then
166			IBDatabaseError;
167
168			Result := desc.blob_desc_charset;
169			end;
170
171	tony	33	procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
172			var
173			CurPos: Int64;
174			BytesRead, SegLen: UShort;
175			LocalBuffer: PChar;
176			begin
177			CurPos := 0;
178			LocalBuffer := Buffer;
179			SegLen := UShort(DefaultBlobSegmentSize);
180			while (CurPos < BlobSize) do
181			begin
182			if (CurPos + SegLen > BlobSize) then
183			SegLen := BlobSize - CurPos;
184			if not ((isc_get_segment(StatusVector, hBlobHandle, @BytesRead, SegLen,
185			LocalBuffer) = 0) or
186			(StatusVectorArray[1] = isc_segment)) then
187			IBDatabaseError;
188			Inc(LocalBuffer, BytesRead);
189			Inc(CurPos, BytesRead);
190			BytesRead := 0;
191			end;
192			end;
193
194			procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar;
195			BlobSize: Int64);
196			var
197			CurPos: Int64;
198			SegLen: Long;
199			begin
200			CurPos := 0;
201			SegLen := DefaultBlobSegmentSize;
202			while (CurPos < BlobSize) do
203			begin
204			if (CurPos + SegLen > BlobSize) then
205			SegLen := BlobSize - CurPos;
206			if isc_put_segment(StatusVector, hBlobHandle, SegLen,
207			PChar(@Buffer[CurPos])) > 0 then
208			IBDatabaseError;
209			Inc(CurPos, SegLen);
210			end;
211			end;
212
213
214			{ TIBBlobStream }
215			constructor TIBBlobStream.Create;
216			begin
217			inherited Create;
218			FBase := TIBBase.Create(Self);
219			FBuffer := nil;
220			FBlobSize := 0;
221	tony	41	FBlobState := bsUninitialised;
222	tony	33	end;
223
224			destructor TIBBlobStream.Destroy;
225			begin
226	tony	41	SetState(bsUninitialised);
227	tony	33	FBase.Free;
228			SetSize(0);
229			inherited Destroy;
230			end;
231
232			function TIBBlobStream.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
233			begin
234			result := 0;
235			if Transaction <> nil then
236			result := Transaction.Call(ErrCode, RaiseError)
237			else if RaiseError and (ErrCode > 0) then
238			IBDataBaseError;
239			end;
240
241			procedure TIBBlobStream.CheckReadable;
242			begin
243			if FMode = bmWrite then IBError(ibxeBlobCannotBeRead, [nil]);
244			end;
245
246			procedure TIBBlobStream.CheckWritable;
247			begin
248			if FMode = bmRead then IBError(ibxeBlobCannotBeWritten, [nil]);
249			end;
250
251	tony	41	function TIBBlobStream.GetModified: Boolean;
252			begin
253			Result := FBlobState = bsModified;
254			end;
255
256	tony	33	procedure TIBBlobStream.CloseBlob;
257			begin
258			Finalize;
259	tony	41	SetState(bsUninitialised);
260	tony	33	end;
261
262			procedure TIBBlobStream.CreateBlob;
263			begin
264			CheckWritable;
265			FBlobID.gds_quad_high := 0;
266			FBlobID.gds_quad_low := 0;
267	tony	41	SetState(bsData);
268			SetSize(0);
269	tony	33	end;
270
271			procedure TIBBlobStream.EnsureBlobInitialized;
272			begin
273	tony	41	if FBlobState = bsUninitialised then
274	tony	33	case FMode of
275			bmWrite:
276			CreateBlob;
277			bmReadWrite: begin
278			if (FBlobID.gds_quad_high = 0) and
279			(FBlobID.gds_quad_low = 0) then
280			CreateBlob
281			else
282			OpenBlob;
283			end;
284			else
285			OpenBlob;
286			end;
287			end;
288
289	tony	41	procedure TIBBlobStream.EnsureLoaded;
290			begin
291			EnsureBlobInitialized;
292			if FBlobState = bsDataPending then
293			begin
294			SetSize(FBlobSize);
295			try
296			IBBlob.ReadBlob(@FHandle, FBuffer, FBlobSize);
297			except
298			Call(isc_close_blob(StatusVector, @FHandle), False);
299			raise;
300			end;
301			SetState(bsData);
302			end;
303			end;
304
305	tony	33	procedure TIBBlobStream.Finalize;
306			begin
307	tony	41	if FBlobState <> bsModified then
308	tony	33	exit;
309	tony	41	if FBlobSize > 0 then
310			begin
311			{ need to start writing to a blob, create one }
312			Call(isc_create_blob2(StatusVector, DBHandle, TRHandle, @FHandle, @FBlobID,
313			0, nil), True);
314			IBBlob.WriteBlob(@FHandle, FBuffer, FBlobSize);
315			Call(isc_close_blob(StatusVector, @FHandle), True);
316			end
317			else
318			begin
319			FBlobID.gds_quad_high := 0;
320			FBlobID.gds_quad_low := 0;
321			end;
322			SetState(bsData);
323	tony	33	end;
324
325			procedure TIBBlobStream.GetBlobInfo;
326			var
327			iBlobSize: Int64;
328			begin
329			IBBlob.GetBlobInfo(@FHandle, FBlobNumSegments, FBlobMaxSegmentSize,
330			iBlobSize, FBlobType);
331			SetSize(iBlobSize);
332			end;
333
334	tony	41	function TIBBlobStream.GetSize: Int64;
335			begin
336			EnsureBlobInitialized;
337			Result := FBlobSize;
338			end;
339
340	tony	33	function TIBBlobStream.GetDatabase: TIBDatabase;
341			begin
342			result := FBase.Database;
343			end;
344
345			function TIBBlobStream.GetDBHandle: PISC_DB_HANDLE;
346			begin
347			result := FBase.DBHandle;
348			end;
349
350			function TIBBlobStream.GetTransaction: TIBTransaction;
351			begin
352			result := FBase.Transaction;
353			end;
354
355			function TIBBlobStream.GetTRHandle: PISC_TR_HANDLE;
356			begin
357			result := FBase.TRHandle;
358			end;
359
360			procedure TIBBlobStream.LoadFromFile(Filename: string);
361			var
362			Stream: TStream;
363			begin
364			Stream := TFileStream.Create(FileName, fmOpenRead);
365			try
366			LoadFromStream(Stream);
367			finally
368			Stream.Free;
369			end;
370			end;
371
372			procedure TIBBlobStream.LoadFromStream(Stream: TStream);
373			begin
374			CheckWritable;
375			EnsureBlobInitialized;
376			Stream.Position := 0;
377			SetSize(Stream.Size);
378			if FBlobSize <> 0 then
379			Stream.ReadBuffer(FBuffer^, FBlobSize);
380	tony	41	SetState(bsModified);
381	tony	33	end;
382
383			procedure TIBBlobStream.OpenBlob;
384			begin
385			CheckReadable;
386			Call(isc_open_blob2(StatusVector, DBHandle, TRHandle, @FHandle,
387			@FBlobID, 0, nil), True);
388			try
389			GetBlobInfo;
390	tony	41	{Defer reading in blob until read method called}
391	tony	33	except
392			Call(isc_close_blob(StatusVector, @FHandle), False);
393			raise;
394			end;
395	tony	41	SetState(bsDataPending);
396	tony	33	end;
397
398			function TIBBlobStream.Read(var Buffer; Count: Longint): Longint;
399			begin
400			CheckReadable;
401	tony	41	EnsureLoaded;
402	tony	33	if (Count <= 0) then
403			begin
404			result := 0;
405			exit;
406			end;
407			if (FPosition + Count > FBlobSize) then
408			result := FBlobSize - FPosition
409			else
410			result := Count;
411			Move(FBuffer[FPosition], Buffer, result);
412			Inc(FPosition, Result);
413			end;
414
415			procedure TIBBlobStream.SaveToFile(Filename: string);
416			var
417			Stream: TStream;
418			begin
419			Stream := TFileStream.Create(FileName, fmCreate);
420			try
421			SaveToStream(Stream);
422			finally
423			Stream.Free;
424			end;
425			end;
426
427			procedure TIBBlobStream.SaveToStream(Stream: TStream);
428			begin
429			CheckReadable;
430	tony	41	EnsureLoaded;
431	tony	33	if FBlobSize <> 0 then
432			begin
433			Seek(0, soFromBeginning);
434			Stream.WriteBuffer(FBuffer^, FBlobSize);
435			end;
436			end;
437
438			function TIBBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
439			begin
440			EnsureBlobInitialized;
441			case Origin of
442			soBeginning : FPosition := Offset;
443			soCurrent : Inc(FPosition, Offset);
444			soEnd : FPosition := FBlobSize + Offset;
445			end;
446			result := FPosition;
447			end;
448
449			procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
450			begin
451			System.Move(Value, FBlobID, SizeOf(TISC_QUAD));
452	tony	41	SetState(bsUninitialised);
453	tony	33	end;
454
455			procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
456			begin
457			FBase.Database := Value;
458	tony	41	SetState(bsUninitialised);
459	tony	33	end;
460
461			procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
462			begin
463			FMode := Value;
464	tony	41	SetState(bsUninitialised);
465	tony	33	end;
466
467	tony	41	procedure TIBBlobStream.SetState(aValue: TIBBlobStates);
468			begin
469			if FBlobState = aValue then Exit;
470
471			if FBlobState = bsDataPending then
472			Call(isc_close_blob(StatusVector, @FHandle), True);
473
474			FBlobState := aValue;
475			end;
476
477	tony	33	procedure TIBBlobStream.SetSize(const NewSize: Int64);
478			begin
479			if (NewSize <> FBlobSize) then
480			begin
481			ReallocMem(FBuffer, NewSize);
482			FBlobSize := NewSize;
483			if NewSize = 0 then
484			FBuffer := nil;
485			end;
486			end;
487
488			procedure TIBBlobStream.SetSize(NewSize: Longint);
489			begin
490			SetSize(Int64(NewSize));
491			end;
492
493			procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
494			begin
495			FBase.Transaction := Value;
496	tony	41	SetState(bsUninitialised);
497	tony	33	end;
498
499			procedure TIBBlobStream.Truncate;
500			begin
501			SetSize(0);
502	tony	41	SetState(bsModified);
503	tony	33	end;
504
505			function TIBBlobStream.Write(const Buffer; Count: Longint): Longint;
506			begin
507			CheckWritable;
508	tony	41	EnsureLoaded; {Could be an untruncated bmReadWrite Blob}
509	tony	33	result := Count;
510			if Count <= 0 then
511			exit;
512			if (FPosition + Count > FBlobSize) then
513			SetSize(FPosition + Count);
514			Move(Buffer, FBuffer[FPosition], Count);
515			Inc(FPosition, Count);
516	tony	41	SetState(bsModified);
517	tony	33	end;
518
519			end.