ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBBlob.pas
(Generate patch)

Comparing ibx/trunk/runtime/IBBlob.pas (file contents):
Revision 32 by tony, Sat Dec 28 19:22:24 2013 UTC vs.
Revision 33 by tony, Sat Jul 18 12:30:52 2015 UTC

# Line 1 | Line 1
1 < {************************************************************************}
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 < {$Mode Delphi}
36 <
37 < interface
38 <
39 < uses
40 <  SysUtils, Classes, IBHeader, IBErrorCodes, IBExternals, DB, IB, IBDatabase;
41 <
42 <
43 < const
44 <  DefaultBlobSegmentSize = 16 * 1024;
45 <
46 < type
47 <  { TIBBlobStream }
48 <  TIBBlobStream = class(TStream)
49 <  private
50 <    FBase: TIBBase;
51 <    FBlobID: TISC_QUAD;
52 <    FBlobMaxSegmentSize: Int64;
53 <    FBlobNumSegments: Int64;
54 <    FBlobSize: Int64;
55 <    FBlobType: Short;  { 0 = segmented, 1 = streamed }
56 <    FBuffer: PChar;
57 <    FBlobInitialized: Boolean;
58 <    FHandle: TISC_BLOB_HANDLE;
59 <    FMode: TBlobStreamMode;
60 <    FModified: Boolean;
61 <    FPosition: Int64;
62 <  protected
63 <    procedure CloseBlob;
64 <    procedure CreateBlob;
65 <    procedure EnsureBlobInitialized;
66 <    procedure GetBlobInfo;
67 <    function GetDatabase: TIBDatabase;
68 <    function GetDBHandle: PISC_DB_HANDLE;
69 <    function GetTransaction: TIBTransaction;
70 <    function GetTRHandle: PISC_TR_HANDLE;
71 <    procedure OpenBlob;
72 <    procedure SetBlobID(Value: TISC_QUAD);
73 <    procedure SetDatabase(Value: TIBDatabase);
74 <    procedure SetMode(Value: TBlobStreamMode);
75 <    procedure SetTransaction(Value: TIBTransaction);
76 <  public
77 <    constructor Create;
78 <    destructor Destroy; override;
79 <    function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
80 <    procedure CheckReadable;
81 <    procedure CheckWritable;
82 <    procedure Finalize;
83 <    procedure LoadFromFile(Filename: string);
84 <    procedure LoadFromStream(Stream: TStream);
85 <    function Read(var Buffer; Count: Longint): Longint; override;
86 <    procedure SaveToFile(Filename: string);
87 <    procedure SaveToStream(Stream: TStream);
88 <    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
89 <    procedure SetSize(const NewSize: Int64); override;
90 <    procedure SetSize(NewSize: Longint); override;
91 <    procedure Truncate;
92 <    function Write(const Buffer; Count: Longint): Longint; override;
93 <    property Handle: TISC_BLOB_HANDLE read FHandle;
94 <    property BlobID: TISC_QUAD read FBlobID write SetBlobID;
95 <    property BlobMaxSegmentSize: Int64 read FBlobMaxSegmentSize;
96 <    property BlobNumSegments: Int64 read FBlobNumSegments;
97 <    property BlobSize: Int64 read FBlobSize;
98 <    property BlobType: Short read FBlobType;
99 <    property Database: TIBDatabase read GetDatabase write SetDatabase;
100 <    property DBHandle: PISC_DB_HANDLE read GetDBHandle;
101 <    property Mode: TBlobStreamMode read FMode write SetMode;
102 <    property Modified: Boolean read FModified;
103 <    property Transaction: TIBTransaction read GetTransaction write SetTransaction;
104 <    property TRHandle: PISC_TR_HANDLE read GetTRHandle;
105 <  end;
106 <
107 <  procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
108 <                      TotalSize: Int64; var BlobType: Short);
109 <  procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
110 <  procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
111 <
112 < implementation
113 <
114 < uses IBIntf;
115 <
116 < procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
117 <                      TotalSize: Int64; var BlobType: Short);
118 < var
119 <  items: array[0..3] of Char;
120 <  results: array[0..99] of Char;
121 <  i, item_length: Integer;
122 <  item: Integer;
123 < begin
124 <  items[0] := Char(isc_info_blob_num_segments);
125 <  items[1] := Char(isc_info_blob_max_segment);
126 <  items[2] := Char(isc_info_blob_total_length);
127 <  items[3] := Char(isc_info_blob_type);
128 <
129 <  if isc_blob_info(StatusVector, hBlobHandle, 4, @items[0], SizeOf(results),
130 <                    @results[0]) > 0 then
131 <    IBDatabaseError;
132 <
133 <  i := 0;
134 <  while (i < SizeOf(results)) and (results[i] <> Char(isc_info_end)) do
135 <  begin
136 <    item := Integer(results[i]); Inc(i);
137 <    item_length := isc_vax_integer(@results[i], 2); Inc(i, 2);
138 <    case item of
139 <      isc_info_blob_num_segments:
140 <        NumSegments := isc_portable_integer(@results[i], item_length);
141 <      isc_info_blob_max_segment:
142 <        MaxSegmentSize := isc_portable_integer(@results[i], item_length);
143 <      isc_info_blob_total_length:
144 <        TotalSize := isc_portable_integer(@results[i], item_length);
145 <      isc_info_blob_type:
146 <        BlobType := isc_portable_integer(@results[i], item_length);
147 <    end;
148 <    Inc(i, item_length);
149 <  end;
150 < end;
151 <
152 < procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
153 < var
154 <  CurPos: Int64;
155 <  BytesRead, SegLen: UShort;
156 <  LocalBuffer: PChar;
157 < begin
158 <  CurPos := 0;
159 <  LocalBuffer := Buffer;
160 <  SegLen := UShort(DefaultBlobSegmentSize);
161 <  while (CurPos < BlobSize) do
162 <  begin
163 <    if (CurPos + SegLen > BlobSize) then
164 <      SegLen := BlobSize - CurPos;
165 <    if not ((isc_get_segment(StatusVector, hBlobHandle, @BytesRead, SegLen,
166 <                             LocalBuffer) = 0) or
167 <            (StatusVectorArray[1] = isc_segment)) then
168 <      IBDatabaseError;
169 <    Inc(LocalBuffer, BytesRead);
170 <    Inc(CurPos, BytesRead);
171 <    BytesRead := 0;
172 <  end;
173 < end;
174 <
175 < procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar;
176 <  BlobSize: Int64);
177 < var
178 <  CurPos: Int64;
179 <  SegLen: Long;
180 < begin
181 <  CurPos := 0;
182 <  SegLen := DefaultBlobSegmentSize;
183 <  while (CurPos < BlobSize) do
184 <  begin
185 <    if (CurPos + SegLen > BlobSize) then
186 <      SegLen := BlobSize - CurPos;
187 <    if isc_put_segment(StatusVector, hBlobHandle, SegLen,
188 <         PChar(@Buffer[CurPos])) > 0 then
189 <      IBDatabaseError;
190 <    Inc(CurPos, SegLen);
191 <  end;
192 < end;
193 <
194 <
195 < { TIBBlobStream }
196 < constructor TIBBlobStream.Create;
197 < begin
198 <  inherited Create;
199 <  FBase := TIBBase.Create(Self);
200 <  FBuffer := nil;
201 <  FBlobSize := 0;
202 < end;
203 <
204 < destructor TIBBlobStream.Destroy;
205 < begin
206 <  if (FHandle <> nil) and
207 <     (Call(isc_close_blob(StatusVector, @FHandle), False) > 0) then
208 <    IBDataBaseError;
209 <  FBase.Free;
210 <  SetSize(0);
211 <  inherited Destroy;
212 < end;
213 <
214 < function TIBBlobStream.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
215 < begin
216 <  result := 0;
217 <  if Transaction <> nil then
218 <    result := Transaction.Call(ErrCode, RaiseError)
219 <  else if RaiseError and (ErrCode > 0) then
220 <    IBDataBaseError;
221 < end;
222 <
223 < procedure TIBBlobStream.CheckReadable;
224 < begin
225 <  if FMode = bmWrite then IBError(ibxeBlobCannotBeRead, [nil]);
226 < end;
227 <
228 < procedure TIBBlobStream.CheckWritable;
229 < begin
230 <  if FMode = bmRead then IBError(ibxeBlobCannotBeWritten, [nil]);
231 < end;
232 <
233 < procedure TIBBlobStream.CloseBlob;
234 < begin
235 <  Finalize;
236 <  if (FHandle <> nil) and
237 <     (Call(isc_close_blob(StatusVector, @FHandle), False) > 0) then
238 <    IBDataBaseError;
239 < end;
240 <
241 < procedure TIBBlobStream.CreateBlob;
242 < begin
243 <  CheckWritable;
244 <  FBlobID.gds_quad_high := 0;
245 <  FBlobID.gds_quad_low := 0;
246 <  Truncate;
247 < end;
248 <
249 < procedure TIBBlobStream.EnsureBlobInitialized;
250 < begin
251 <  if not FBlobInitialized then
252 <    case FMode of
253 <      bmWrite:
254 <        CreateBlob;
255 <      bmReadWrite: begin
256 <        if (FBlobID.gds_quad_high = 0) and
257 <           (FBlobID.gds_quad_low = 0) then
258 <          CreateBlob
259 <        else
260 <          OpenBlob;
261 <      end;
262 <      else
263 <        OpenBlob;
264 <    end;
265 <  FBlobInitialized := True;
266 < end;
267 <
268 < procedure TIBBlobStream.Finalize;
269 < begin
270 <  if (not FBlobInitialized) or (FMode = bmRead) or (not FModified) then
271 <    exit;
272 <  { need to start writing to a blob, create one }
273 <  Call(isc_create_blob2(StatusVector, DBHandle, TRHandle, @FHandle, @FBlobID,
274 <                       0, nil), True);
275 <  IBBlob.WriteBlob(@FHandle, FBuffer, FBlobSize);
276 <  Call(isc_close_blob(StatusVector, @FHandle), True);
277 <  FModified := False;
278 < end;
279 <
280 < procedure TIBBlobStream.GetBlobInfo;
281 < var
282 <  iBlobSize: Int64;
283 < begin
284 <  IBBlob.GetBlobInfo(@FHandle, FBlobNumSegments, FBlobMaxSegmentSize,
285 <    iBlobSize, FBlobType);
286 <  SetSize(iBlobSize);
287 < end;
288 <
289 < function TIBBlobStream.GetDatabase: TIBDatabase;
290 < begin
291 <  result := FBase.Database;
292 < end;
293 <
294 < function TIBBlobStream.GetDBHandle: PISC_DB_HANDLE;
295 < begin
296 <  result := FBase.DBHandle;
297 < end;
298 <
299 < function TIBBlobStream.GetTransaction: TIBTransaction;
300 < begin
301 <  result := FBase.Transaction;
302 < end;
303 <
304 < function TIBBlobStream.GetTRHandle: PISC_TR_HANDLE;
305 < begin
306 <  result := FBase.TRHandle;
307 < end;
308 <
309 < procedure TIBBlobStream.LoadFromFile(Filename: string);
310 < var
311 <  Stream: TStream;
312 < begin
313 <  Stream := TFileStream.Create(FileName, fmOpenRead);
314 <  try
315 <    LoadFromStream(Stream);
316 <  finally
317 <    Stream.Free;
318 <  end;
319 < end;
320 <
321 < procedure TIBBlobStream.LoadFromStream(Stream: TStream);
322 < begin
323 <  CheckWritable;
324 <  EnsureBlobInitialized;
325 <  Stream.Position := 0;
326 <  SetSize(Stream.Size);
327 <  if FBlobSize <> 0 then
328 <    Stream.ReadBuffer(FBuffer^, FBlobSize);
329 <  FModified := True;
330 < end;
331 <
332 < procedure TIBBlobStream.OpenBlob;
333 < begin
334 <  CheckReadable;
335 <  Call(isc_open_blob2(StatusVector, DBHandle, TRHandle, @FHandle,
336 <                     @FBlobID, 0, nil), True);
337 <  try
338 <    GetBlobInfo;
339 <    SetSize(FBlobSize);
340 <    IBBlob.ReadBlob(@FHandle, FBuffer, FBlobSize);
341 <  except
342 <    Call(isc_close_blob(StatusVector, @FHandle), False);
343 <    raise;
344 <  end;
345 <  Call(isc_close_blob(StatusVector, @FHandle), True);
346 < end;
347 <
348 < function TIBBlobStream.Read(var Buffer; Count: Longint): Longint;
349 < begin
350 <  CheckReadable;
351 <  EnsureBlobInitialized;
352 <  if (Count <= 0) then
353 <  begin
354 <    result := 0;
355 <    exit;
356 <  end;
357 <  if (FPosition + Count > FBlobSize) then
358 <    result := FBlobSize - FPosition
359 <  else
360 <    result := Count;
361 <  Move(FBuffer[FPosition], Buffer, result);
362 <  Inc(FPosition, Result);
363 < end;
364 <
365 < procedure TIBBlobStream.SaveToFile(Filename: string);
366 < var
367 <  Stream: TStream;
368 < begin
369 <  Stream := TFileStream.Create(FileName, fmCreate);
370 <  try
371 <    SaveToStream(Stream);
372 <  finally
373 <    Stream.Free;
374 <  end;
375 < end;
376 <
377 < procedure TIBBlobStream.SaveToStream(Stream: TStream);
378 < begin
379 <  CheckReadable;
380 <  EnsureBlobInitialized;
381 <  if FBlobSize <> 0 then
382 <  begin
383 <    Seek(0, soFromBeginning);
384 <    Stream.WriteBuffer(FBuffer^, FBlobSize);
385 <  end;
386 < end;
387 <
388 < function TIBBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
389 < begin
390 <  EnsureBlobInitialized;
391 <  case Origin of
392 <    soBeginning     : FPosition := Offset;
393 <    soCurrent       : Inc(FPosition, Offset);
394 <    soEnd           : FPosition := FBlobSize + Offset;
395 <  end;
396 <  result := FPosition;
397 < end;
398 <
399 < procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
400 < begin
401 <  System.Move(Value, FBlobID, SizeOf(TISC_QUAD));
402 <  FBlobInitialized := False;
403 < end;
404 <
405 < procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
406 < begin
407 <  FBase.Database := Value;
408 <  FBlobInitialized := False;
409 < end;
410 <
411 < procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
412 < begin
413 <  FMode := Value;
414 <  FBlobInitialized := False;
415 < end;
416 <
417 < procedure TIBBlobStream.SetSize(const NewSize: Int64);
418 < begin
419 <  if (NewSize <> FBlobSize) then
420 <  begin
421 <    ReallocMem(FBuffer, NewSize);
422 <    FBlobSize := NewSize;
423 <    if NewSize = 0 then
424 <      FBuffer := nil;
425 <  end;
426 < end;
427 <
428 < procedure TIBBlobStream.SetSize(NewSize: Longint);
429 < begin
430 <  SetSize(Int64(NewSize));
431 < end;
432 <
433 < procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
434 < begin
435 <  FBase.Transaction := Value;
436 <  FBlobInitialized := False;
437 < end;
438 <
439 < procedure TIBBlobStream.Truncate;
440 < begin
441 <  SetSize(0);
442 < end;
443 <
444 < function TIBBlobStream.Write(const Buffer; Count: Longint): Longint;
445 < begin
446 <  CheckWritable;
447 <  EnsureBlobInitialized;
448 <  result := Count;
449 <  if Count <= 0 then
450 <    exit;
451 <  if (FPosition + Count > FBlobSize) then
452 <    SetSize(FPosition + Count);
453 <  Move(Buffer, FBuffer[FPosition], Count);
454 <  Inc(FPosition, Count);
455 <  FModified := True;
456 < end;
457 <
458 < end.
1 > {************************************************************************}
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 > {$Mode Delphi}
36 >
37 > interface
38 >
39 > uses
40 >  SysUtils, Classes, IBHeader, IBErrorCodes, IBExternals, DB, IB, IBDatabase;
41 >
42 >
43 > const
44 >  DefaultBlobSegmentSize = 16 * 1024;
45 >
46 > type
47 >  { TIBBlobStream }
48 >  TIBBlobStream = class(TStream)
49 >  private
50 >    FBase: TIBBase;
51 >    FBlobID: TISC_QUAD;
52 >    FBlobMaxSegmentSize: Int64;
53 >    FBlobNumSegments: Int64;
54 >    FBlobSize: Int64;
55 >    FBlobType: Short;  { 0 = segmented, 1 = streamed }
56 >    FBuffer: PChar;
57 >    FBlobInitialized: Boolean;
58 >    FHandle: TISC_BLOB_HANDLE;
59 >    FMode: TBlobStreamMode;
60 >    FModified: Boolean;
61 >    FPosition: Int64;
62 >  protected
63 >    procedure CloseBlob;
64 >    procedure CreateBlob;
65 >    procedure EnsureBlobInitialized;
66 >    procedure GetBlobInfo;
67 >    function GetDatabase: TIBDatabase;
68 >    function GetDBHandle: PISC_DB_HANDLE;
69 >    function GetTransaction: TIBTransaction;
70 >    function GetTRHandle: PISC_TR_HANDLE;
71 >    procedure OpenBlob;
72 >    procedure SetBlobID(Value: TISC_QUAD);
73 >    procedure SetDatabase(Value: TIBDatabase);
74 >    procedure SetMode(Value: TBlobStreamMode);
75 >    procedure SetTransaction(Value: TIBTransaction);
76 >  public
77 >    constructor Create;
78 >    destructor Destroy; override;
79 >    function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
80 >    procedure CheckReadable;
81 >    procedure CheckWritable;
82 >    procedure Finalize;
83 >    procedure LoadFromFile(Filename: string);
84 >    procedure LoadFromStream(Stream: TStream);
85 >    function Read(var Buffer; Count: Longint): Longint; override;
86 >    procedure SaveToFile(Filename: string);
87 >    procedure SaveToStream(Stream: TStream);
88 >    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
89 >    procedure SetSize(const NewSize: Int64); override;
90 >    procedure SetSize(NewSize: Longint); override;
91 >    procedure Truncate;
92 >    function Write(const Buffer; Count: Longint): Longint; override;
93 >    property Handle: TISC_BLOB_HANDLE read FHandle;
94 >    property BlobID: TISC_QUAD read FBlobID write SetBlobID;
95 >    property BlobMaxSegmentSize: Int64 read FBlobMaxSegmentSize;
96 >    property BlobNumSegments: Int64 read FBlobNumSegments;
97 >    property BlobSize: Int64 read FBlobSize;
98 >    property BlobType: Short read FBlobType;
99 >    property Database: TIBDatabase read GetDatabase write SetDatabase;
100 >    property DBHandle: PISC_DB_HANDLE read GetDBHandle;
101 >    property Mode: TBlobStreamMode read FMode write SetMode;
102 >    property Modified: Boolean read FModified;
103 >    property Transaction: TIBTransaction read GetTransaction write SetTransaction;
104 >    property TRHandle: PISC_TR_HANDLE read GetTRHandle;
105 >  end;
106 >
107 >  procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
108 >                      TotalSize: Int64; var BlobType: Short);
109 >  procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
110 >  procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
111 >
112 > implementation
113 >
114 > uses IBIntf;
115 >
116 > procedure GetBlobInfo(hBlobHandle: PISC_BLOB_HANDLE; var NumSegments: Int64; var MaxSegmentSize,
117 >                      TotalSize: Int64; var BlobType: Short);
118 > var
119 >  items: array[0..3] of Char;
120 >  results: array[0..99] of Char;
121 >  i, item_length: Integer;
122 >  item: Integer;
123 > begin
124 >  items[0] := Char(isc_info_blob_num_segments);
125 >  items[1] := Char(isc_info_blob_max_segment);
126 >  items[2] := Char(isc_info_blob_total_length);
127 >  items[3] := Char(isc_info_blob_type);
128 >
129 >  if isc_blob_info(StatusVector, hBlobHandle, 4, @items[0], SizeOf(results),
130 >                    @results[0]) > 0 then
131 >    IBDatabaseError;
132 >
133 >  i := 0;
134 >  while (i < SizeOf(results)) and (results[i] <> Char(isc_info_end)) do
135 >  begin
136 >    item := Integer(results[i]); Inc(i);
137 >    item_length := isc_vax_integer(@results[i], 2); Inc(i, 2);
138 >    case item of
139 >      isc_info_blob_num_segments:
140 >        NumSegments := isc_portable_integer(@results[i], item_length);
141 >      isc_info_blob_max_segment:
142 >        MaxSegmentSize := isc_portable_integer(@results[i], item_length);
143 >      isc_info_blob_total_length:
144 >        TotalSize := isc_portable_integer(@results[i], item_length);
145 >      isc_info_blob_type:
146 >        BlobType := isc_portable_integer(@results[i], item_length);
147 >    end;
148 >    Inc(i, item_length);
149 >  end;
150 > end;
151 >
152 > procedure ReadBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar; BlobSize: Int64);
153 > var
154 >  CurPos: Int64;
155 >  BytesRead, SegLen: UShort;
156 >  LocalBuffer: PChar;
157 > begin
158 >  CurPos := 0;
159 >  LocalBuffer := Buffer;
160 >  SegLen := UShort(DefaultBlobSegmentSize);
161 >  while (CurPos < BlobSize) do
162 >  begin
163 >    if (CurPos + SegLen > BlobSize) then
164 >      SegLen := BlobSize - CurPos;
165 >    if not ((isc_get_segment(StatusVector, hBlobHandle, @BytesRead, SegLen,
166 >                             LocalBuffer) = 0) or
167 >            (StatusVectorArray[1] = isc_segment)) then
168 >      IBDatabaseError;
169 >    Inc(LocalBuffer, BytesRead);
170 >    Inc(CurPos, BytesRead);
171 >    BytesRead := 0;
172 >  end;
173 > end;
174 >
175 > procedure WriteBlob(hBlobHandle: PISC_BLOB_HANDLE; Buffer: PChar;
176 >  BlobSize: Int64);
177 > var
178 >  CurPos: Int64;
179 >  SegLen: Long;
180 > begin
181 >  CurPos := 0;
182 >  SegLen := DefaultBlobSegmentSize;
183 >  while (CurPos < BlobSize) do
184 >  begin
185 >    if (CurPos + SegLen > BlobSize) then
186 >      SegLen := BlobSize - CurPos;
187 >    if isc_put_segment(StatusVector, hBlobHandle, SegLen,
188 >         PChar(@Buffer[CurPos])) > 0 then
189 >      IBDatabaseError;
190 >    Inc(CurPos, SegLen);
191 >  end;
192 > end;
193 >
194 >
195 > { TIBBlobStream }
196 > constructor TIBBlobStream.Create;
197 > begin
198 >  inherited Create;
199 >  FBase := TIBBase.Create(Self);
200 >  FBuffer := nil;
201 >  FBlobSize := 0;
202 > end;
203 >
204 > destructor TIBBlobStream.Destroy;
205 > begin
206 >  if (FHandle <> nil) and
207 >     (Call(isc_close_blob(StatusVector, @FHandle), False) > 0) then
208 >    IBDataBaseError;
209 >  FBase.Free;
210 >  SetSize(0);
211 >  inherited Destroy;
212 > end;
213 >
214 > function TIBBlobStream.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
215 > begin
216 >  result := 0;
217 >  if Transaction <> nil then
218 >    result := Transaction.Call(ErrCode, RaiseError)
219 >  else if RaiseError and (ErrCode > 0) then
220 >    IBDataBaseError;
221 > end;
222 >
223 > procedure TIBBlobStream.CheckReadable;
224 > begin
225 >  if FMode = bmWrite then IBError(ibxeBlobCannotBeRead, [nil]);
226 > end;
227 >
228 > procedure TIBBlobStream.CheckWritable;
229 > begin
230 >  if FMode = bmRead then IBError(ibxeBlobCannotBeWritten, [nil]);
231 > end;
232 >
233 > procedure TIBBlobStream.CloseBlob;
234 > begin
235 >  Finalize;
236 >  if (FHandle <> nil) and
237 >     (Call(isc_close_blob(StatusVector, @FHandle), False) > 0) then
238 >    IBDataBaseError;
239 > end;
240 >
241 > procedure TIBBlobStream.CreateBlob;
242 > begin
243 >  CheckWritable;
244 >  FBlobID.gds_quad_high := 0;
245 >  FBlobID.gds_quad_low := 0;
246 >  Truncate;
247 > end;
248 >
249 > procedure TIBBlobStream.EnsureBlobInitialized;
250 > begin
251 >  if not FBlobInitialized then
252 >    case FMode of
253 >      bmWrite:
254 >        CreateBlob;
255 >      bmReadWrite: begin
256 >        if (FBlobID.gds_quad_high = 0) and
257 >           (FBlobID.gds_quad_low = 0) then
258 >          CreateBlob
259 >        else
260 >          OpenBlob;
261 >      end;
262 >      else
263 >        OpenBlob;
264 >    end;
265 >  FBlobInitialized := True;
266 > end;
267 >
268 > procedure TIBBlobStream.Finalize;
269 > begin
270 >  if (not FBlobInitialized) or (FMode = bmRead) or (not FModified) then
271 >    exit;
272 >  { need to start writing to a blob, create one }
273 >  Call(isc_create_blob2(StatusVector, DBHandle, TRHandle, @FHandle, @FBlobID,
274 >                       0, nil), True);
275 >  IBBlob.WriteBlob(@FHandle, FBuffer, FBlobSize);
276 >  Call(isc_close_blob(StatusVector, @FHandle), True);
277 >  FModified := False;
278 > end;
279 >
280 > procedure TIBBlobStream.GetBlobInfo;
281 > var
282 >  iBlobSize: Int64;
283 > begin
284 >  IBBlob.GetBlobInfo(@FHandle, FBlobNumSegments, FBlobMaxSegmentSize,
285 >    iBlobSize, FBlobType);
286 >  SetSize(iBlobSize);
287 > end;
288 >
289 > function TIBBlobStream.GetDatabase: TIBDatabase;
290 > begin
291 >  result := FBase.Database;
292 > end;
293 >
294 > function TIBBlobStream.GetDBHandle: PISC_DB_HANDLE;
295 > begin
296 >  result := FBase.DBHandle;
297 > end;
298 >
299 > function TIBBlobStream.GetTransaction: TIBTransaction;
300 > begin
301 >  result := FBase.Transaction;
302 > end;
303 >
304 > function TIBBlobStream.GetTRHandle: PISC_TR_HANDLE;
305 > begin
306 >  result := FBase.TRHandle;
307 > end;
308 >
309 > procedure TIBBlobStream.LoadFromFile(Filename: string);
310 > var
311 >  Stream: TStream;
312 > begin
313 >  Stream := TFileStream.Create(FileName, fmOpenRead);
314 >  try
315 >    LoadFromStream(Stream);
316 >  finally
317 >    Stream.Free;
318 >  end;
319 > end;
320 >
321 > procedure TIBBlobStream.LoadFromStream(Stream: TStream);
322 > begin
323 >  CheckWritable;
324 >  EnsureBlobInitialized;
325 >  Stream.Position := 0;
326 >  SetSize(Stream.Size);
327 >  if FBlobSize <> 0 then
328 >    Stream.ReadBuffer(FBuffer^, FBlobSize);
329 >  FModified := True;
330 > end;
331 >
332 > procedure TIBBlobStream.OpenBlob;
333 > begin
334 >  CheckReadable;
335 >  Call(isc_open_blob2(StatusVector, DBHandle, TRHandle, @FHandle,
336 >                     @FBlobID, 0, nil), True);
337 >  try
338 >    GetBlobInfo;
339 >    SetSize(FBlobSize);
340 >    IBBlob.ReadBlob(@FHandle, FBuffer, FBlobSize);
341 >  except
342 >    Call(isc_close_blob(StatusVector, @FHandle), False);
343 >    raise;
344 >  end;
345 >  Call(isc_close_blob(StatusVector, @FHandle), True);
346 > end;
347 >
348 > function TIBBlobStream.Read(var Buffer; Count: Longint): Longint;
349 > begin
350 >  CheckReadable;
351 >  EnsureBlobInitialized;
352 >  if (Count <= 0) then
353 >  begin
354 >    result := 0;
355 >    exit;
356 >  end;
357 >  if (FPosition + Count > FBlobSize) then
358 >    result := FBlobSize - FPosition
359 >  else
360 >    result := Count;
361 >  Move(FBuffer[FPosition], Buffer, result);
362 >  Inc(FPosition, Result);
363 > end;
364 >
365 > procedure TIBBlobStream.SaveToFile(Filename: string);
366 > var
367 >  Stream: TStream;
368 > begin
369 >  Stream := TFileStream.Create(FileName, fmCreate);
370 >  try
371 >    SaveToStream(Stream);
372 >  finally
373 >    Stream.Free;
374 >  end;
375 > end;
376 >
377 > procedure TIBBlobStream.SaveToStream(Stream: TStream);
378 > begin
379 >  CheckReadable;
380 >  EnsureBlobInitialized;
381 >  if FBlobSize <> 0 then
382 >  begin
383 >    Seek(0, soFromBeginning);
384 >    Stream.WriteBuffer(FBuffer^, FBlobSize);
385 >  end;
386 > end;
387 >
388 > function TIBBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
389 > begin
390 >  EnsureBlobInitialized;
391 >  case Origin of
392 >    soBeginning     : FPosition := Offset;
393 >    soCurrent       : Inc(FPosition, Offset);
394 >    soEnd           : FPosition := FBlobSize + Offset;
395 >  end;
396 >  result := FPosition;
397 > end;
398 >
399 > procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
400 > begin
401 >  System.Move(Value, FBlobID, SizeOf(TISC_QUAD));
402 >  FBlobInitialized := False;
403 > end;
404 >
405 > procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
406 > begin
407 >  FBase.Database := Value;
408 >  FBlobInitialized := False;
409 > end;
410 >
411 > procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
412 > begin
413 >  FMode := Value;
414 >  FBlobInitialized := False;
415 > end;
416 >
417 > procedure TIBBlobStream.SetSize(const NewSize: Int64);
418 > begin
419 >  if (NewSize <> FBlobSize) then
420 >  begin
421 >    ReallocMem(FBuffer, NewSize);
422 >    FBlobSize := NewSize;
423 >    if NewSize = 0 then
424 >      FBuffer := nil;
425 >  end;
426 > end;
427 >
428 > procedure TIBBlobStream.SetSize(NewSize: Longint);
429 > begin
430 >  SetSize(Int64(NewSize));
431 > end;
432 >
433 > procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
434 > begin
435 >  FBase.Transaction := Value;
436 >  FBlobInitialized := False;
437 > end;
438 >
439 > procedure TIBBlobStream.Truncate;
440 > begin
441 >  SetSize(0);
442 > end;
443 >
444 > function TIBBlobStream.Write(const Buffer; Count: Longint): Longint;
445 > begin
446 >  CheckWritable;
447 >  EnsureBlobInitialized;
448 >  result := Count;
449 >  if Count <= 0 then
450 >    exit;
451 >  if (FPosition + Count > FBlobSize) then
452 >    SetSize(FPosition + Count);
453 >  Move(Buffer, FBuffer[FPosition], Count);
454 >  Inc(FPosition, Count);
455 >  FModified := True;
456 > end;
457 >
458 > end.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines