ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBBlob.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (10 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 13804 byte(s)
Log Message:
Committing updates for Release R1-0-5

File Contents

# Content
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.