ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBBlob.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 11542 byte(s)
Log Message:
Fixes Merged

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 - 2018 }
31 {************************************************************************}
32
33 unit IBBlob;
34
35 {$mode Delphi}
36
37 interface
38
39 uses
40 SysUtils, Classes, DB, IB, IBDatabase;
41
42
43 const
44 DefaultBlobSegmentSize = 16 * 1024;
45
46 type
47 TIBBlobStates = (bsUninitialised, bsDataPending, bsData, bsModified);
48
49 { TIBBlobStream }
50 TIBBlobStream = class(TStream)
51 private
52 FBase: TIBBase;
53 FBlob: IBlob;
54 FBlobMaxSegmentSize: Int64;
55 FBlobNumSegments: Int64;
56 FBlobSize: Int64;
57 FBlobType: TBlobType;
58 FBuffer: PChar;
59 FColumnName: string;
60 FMode: TBlobStreamMode;
61 FPosition: Int64;
62 FBlobState: TIBBlobStates;
63 FRelationName: string;
64 function GetBlobID: TISC_QUAD;
65 function GetModified: Boolean;
66 procedure CheckActive;
67 protected
68 procedure CloseBlob;
69 procedure EnsureBlobInitialized;
70 procedure EnsureLoaded;
71 procedure GetBlobInfo;
72 function GetSize: Int64; override;
73 function GetDatabase: TIBDatabase;
74 function GetTransaction: TIBTransaction;
75 procedure OpenBlob;
76 procedure SetBlobID(Value: TISC_QUAD);
77 procedure SetDatabase(Value: TIBDatabase);
78 procedure SetMode(Value: TBlobStreamMode);
79 procedure SetState(aValue: TIBBlobStates);
80 procedure SetTransaction(Value: TIBTransaction);
81 public
82 constructor Create;
83 destructor Destroy; override;
84 procedure CheckReadable;
85 procedure CheckWritable;
86 procedure Finalize;
87 procedure LoadFromFile(Filename: string);
88 procedure LoadFromStream(Stream: TStream);
89 function Read(var Buffer; Count: Longint): Longint; override;
90 procedure SaveToFile(Filename: string);
91 procedure SaveToStream(Stream: TStream);
92 function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
93 procedure SetField(aField: TField);
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 BlobID: TISC_QUAD read GetBlobID write SetBlobID;
99 property Blob: IBlob read FBlob;
100 property BlobMaxSegmentSize: Int64 read FBlobMaxSegmentSize;
101 property BlobNumSegments: Int64 read FBlobNumSegments;
102 property BlobSize: Int64 read GetSize;
103 property BlobType: TBlobType read FBlobType;
104 property Database: TIBDatabase read GetDatabase write SetDatabase;
105 property Mode: TBlobStreamMode read FMode write SetMode;
106 property Modified: Boolean read GetModified;
107 property Transaction: TIBTransaction read GetTransaction write SetTransaction;
108 property RelationName: string read FRelationName;
109 property ColumnName: string read FColumnName;
110 end;
111
112 implementation
113
114 uses FBMessages, IBCustomDataSet;
115
116 { TIBBlobStream }
117 constructor TIBBlobStream.Create;
118 begin
119 inherited Create;
120 FBase := TIBBase.Create(Self);
121 FBuffer := nil;
122 FBlobSize := 0;
123 FBlobState := bsUninitialised;
124 FBlob := nil;
125 end;
126
127 destructor TIBBlobStream.Destroy;
128 begin
129 CloseBlob;
130 FBase.Free;
131 SetSize(0);
132 inherited Destroy;
133 end;
134
135 procedure TIBBlobStream.CheckReadable;
136 begin
137 if FMode = bmWrite then IBError(ibxeBlobCannotBeRead, [nil]);
138 end;
139
140 procedure TIBBlobStream.CheckWritable;
141 begin
142 if FMode = bmRead then IBError(ibxeBlobCannotBeWritten, [nil]);
143 end;
144
145 function TIBBlobStream.GetModified: Boolean;
146 begin
147 Result := FBlobState = bsModified;
148 end;
149
150 procedure TIBBlobStream.CheckActive;
151 begin
152 if Database = nil then
153 IBError(ibxeDatabaseNotAssigned,[nil]);
154
155 if (Database.Attachment = nil) or
156 not Database.Attachment.IsConnected then
157 IBError(ibxeDatabaseClosed,[nil]);
158
159 if Transaction = nil then
160 IBError(ibxeTransactionNotAssigned,[nil]);
161
162 if (Transaction.TransactionIntf = nil) or
163 not Transaction.TransactionIntf.InTransaction then
164 IBError(ibxeNotInTransaction,[nil]);
165 end;
166
167 function TIBBlobStream.GetBlobID: TISC_QUAD;
168 begin
169 if (FBlob = nil) or (FBlobSize = 0) then
170 begin
171 Result.gds_quad_high := 0;
172 Result.gds_quad_low := 0;
173 end
174 else
175 Result := FBlob.GetBlobID;
176 end;
177
178 procedure TIBBlobStream.CloseBlob;
179 begin
180 Finalize;
181 FBlob := nil;
182 SetState(bsUninitialised);
183 end;
184
185 procedure TIBBlobStream.EnsureBlobInitialized;
186 begin
187 if FBlobState <> bsUninitialised then Exit;
188
189 if FMode = bmWrite then
190 SetState(bsData)
191 else
192 begin
193 CheckReadable;
194 if FBlob = nil then Exit;
195 try
196 GetBlobInfo;
197 {Defer reading in blob until read method called}
198 except
199 FBlob := nil;
200 raise;
201 end;
202 SetState(bsDataPending);
203 end;
204 end;
205
206 procedure TIBBlobStream.EnsureLoaded;
207 begin
208 EnsureBlobInitialized;
209 if (FBlobState = bsDataPending) and (FBlob <> nil) then
210 begin
211 SetSize(FBlobSize);
212 FBlob.Read(FBuffer^, FBlobSize);
213 SetState(bsData);
214 end;
215 end;
216
217 procedure TIBBlobStream.Finalize;
218 begin
219 if FBlobState <> bsModified then
220 exit;
221 CheckWritable;
222 if FBlobSize > 0 then
223 begin
224 { need to start writing to a blob, create one }
225 FBlob := Database.Attachment.CreateBlob(Transaction.TransactionIntf,RelationName,ColumnName);
226 FBlob.Write(FBuffer^, FBlobSize);
227 FBlob.Close;
228 end;
229 SetState(bsData);
230 end;
231
232 procedure TIBBlobStream.GetBlobInfo;
233 var
234 iBlobSize: Int64;
235 begin
236 if FBlob = nil then Exit;
237
238 FBlob.GetInfo(FBlobNumSegments, FBlobMaxSegmentSize, iBlobSize, FBlobType);
239 SetSize(iBlobSize);
240 end;
241
242 function TIBBlobStream.GetSize: Int64;
243 begin
244 EnsureBlobInitialized;
245 Result := FBlobSize;
246 end;
247
248 function TIBBlobStream.GetDatabase: TIBDatabase;
249 begin
250 result := FBase.Database;
251 end;
252
253 function TIBBlobStream.GetTransaction: TIBTransaction;
254 begin
255 result := FBase.Transaction;
256 end;
257
258 procedure TIBBlobStream.LoadFromFile(Filename: string);
259 var
260 Stream: TStream;
261 begin
262 Stream := TFileStream.Create(FileName, fmOpenRead);
263 try
264 LoadFromStream(Stream);
265 finally
266 Stream.Free;
267 end;
268 end;
269
270 procedure TIBBlobStream.LoadFromStream(Stream: TStream);
271 begin
272 CheckWritable;
273 EnsureBlobInitialized;
274 Stream.Position := 0;
275 SetSize(Stream.Size);
276 if FBlobSize <> 0 then
277 Stream.ReadBuffer(FBuffer^, FBlobSize);
278 SetState(bsModified);
279 end;
280
281 procedure TIBBlobStream.OpenBlob;
282 begin
283 CheckReadable;
284 try
285 GetBlobInfo;
286 {Defer reading in blob until read method called}
287 except
288 FBlob.Close;
289 raise;
290 end;
291 SetState(bsDataPending);
292 end;
293
294 function TIBBlobStream.Read(var Buffer; Count: Longint): Longint;
295 begin
296 CheckReadable;
297 EnsureLoaded;
298 if Count <= 0 then
299 begin
300 result := 0;
301 exit;
302 end;
303 if (FPosition + Count > FBlobSize) then
304 result := FBlobSize - FPosition
305 else
306 result := Count;
307 Move(FBuffer[FPosition], Buffer, result);
308 Inc(FPosition, Result);
309 end;
310
311 procedure TIBBlobStream.SaveToFile(Filename: string);
312 var
313 Stream: TStream;
314 begin
315 Stream := TFileStream.Create(FileName, fmCreate);
316 try
317 SaveToStream(Stream);
318 finally
319 Stream.Free;
320 end;
321 end;
322
323 procedure TIBBlobStream.SaveToStream(Stream: TStream);
324 begin
325 CheckReadable;
326 EnsureLoaded;
327 if FBlobSize <> 0 then
328 begin
329 Seek(0, soFromBeginning);
330 Stream.WriteBuffer(FBuffer^, FBlobSize);
331 end;
332 end;
333
334 function TIBBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
335 begin
336 EnsureBlobInitialized;
337 case Origin of
338 soBeginning : FPosition := Offset;
339 soCurrent : Inc(FPosition, Offset);
340 soEnd : FPosition := FBlobSize + Offset;
341 end;
342 result := FPosition;
343 end;
344
345 procedure TIBBlobStream.SetField(aField: TField);
346 begin
347 FRelationName := '';
348 if aField.FieldDef <> nil then
349 FRelationName := (aField.FieldDef as TIBFieldDef).RelationName;
350 FColumnName := aField.FieldName;;
351 end;
352
353 procedure TIBBlobStream.SetBlobID(Value: TISC_QUAD);
354 begin
355 CheckActive;
356 FBlob := nil;
357 if (Value.gds_quad_high = 0) and (Value.gds_quad_low = 0) then
358 Exit;
359 FBlob := Database.Attachment.OpenBlob(Transaction.TransactionIntf,RelationName,ColumnName,Value);
360 if FBlobState <> bsData then
361 SetState(bsUninitialised);
362 end;
363
364 procedure TIBBlobStream.SetDatabase(Value: TIBDatabase);
365 begin
366 FBase.Database := Value;
367 SetState(bsUninitialised);
368 end;
369
370 procedure TIBBlobStream.SetMode(Value: TBlobStreamMode);
371 begin
372 FMode := Value;
373 SetState(bsUninitialised);
374 end;
375
376 procedure TIBBlobStream.SetState(aValue: TIBBlobStates);
377 begin
378 if FBlobState = aValue then Exit;
379
380 if (FBlobState = bsDataPending) and (FBlob <> nil) then
381 FBlob.Close;
382
383 FBlobState := aValue;
384 end;
385
386 procedure TIBBlobStream.SetSize(const NewSize: Int64);
387 begin
388 if (NewSize <> FBlobSize) then
389 begin
390 ReallocMem(FBuffer, NewSize);
391 FBlobSize := NewSize;
392 if NewSize = 0 then
393 FBuffer := nil;
394 end;
395 end;
396
397 procedure TIBBlobStream.SetSize(NewSize: Longint);
398 begin
399 SetSize(Int64(NewSize));
400 end;
401
402 procedure TIBBlobStream.SetTransaction(Value: TIBTransaction);
403 begin
404 FBase.Transaction := Value;
405 SetState(bsUninitialised);
406 end;
407
408 procedure TIBBlobStream.Truncate;
409 begin
410 SetSize(0);
411 SetState(bsModified);
412 end;
413
414 function TIBBlobStream.Write(const Buffer; Count: Longint): Longint;
415 begin
416 CheckWritable;
417 EnsureLoaded; {Could be an untruncated bmReadWrite Blob}
418 result := Count;
419 if Count <= 0 then
420 exit;
421 if (FPosition + Count > FBlobSize) then
422 SetSize(FPosition + Count);
423 Move(Buffer, FBuffer[FPosition], Count);
424 Inc(FPosition, Count);
425 SetState(bsModified);
426 end;
427
428 end.