ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBBlob.pas
Revision: 110
Committed: Thu Jan 18 14:37:51 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 11661 byte(s)
Log Message:
Fixes Merged

File Contents

# Content
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2016 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 unit FBBlob;
31 {$IFDEF MSWINDOWS}
32 {$DEFINE WINDOWS}
33 {$ENDIF}
34
35 {$IFDEF FPC}
36 {$mode delphi}
37 {$interfaces COM}
38 {$ENDIF}
39
40 interface
41
42 uses
43 Classes, SysUtils, IB, FBActivityMonitor, FBTransaction, FBClientAPI,
44 FBOutputBlock;
45
46 type
47
48 { TFBBlobMetaData }
49
50 TFBBlobMetaData = class(TActivityReporter)
51 private
52 FRelationName: AnsiString;
53 FColumnName: AnsiString;
54 protected
55 FUnconfirmedCharacterSet: boolean;
56 FHasSubType: boolean;
57 FSubType: integer;
58 FCharSetID: cardinal;
59 FSegmentSize: cardinal;
60 function Attachment: IAttachment; virtual; abstract;
61 function CanFetchMetaData: boolean;
62 procedure NeedFullMetadata; virtual; abstract;
63 procedure NeedSubType;
64 public
65 constructor Create(Transaction: TFBTransaction; RelationName, ColumnName: AnsiString
66 );
67 procedure SetCharSetID(aValue: integer);
68
69 public
70 {IBlobMetaData}
71 function GetSubType: integer;
72 function GetCharSetID: cardinal;
73 function GetCodePage: TSystemCodePage;
74 function GetSegmentSize: cardinal;
75 function GetRelationName: AnsiString;
76 function GetColumnName: AnsiString;
77 function GetUnconfirmedCharacterSet: boolean;
78 end;
79
80 TFBBlob = class(TActivityReporter)
81 private
82 FMetaData: IBlobMetaData;
83 FAttachment: IAttachment;
84 FTransaction: ITransaction;
85 FBPB: IBPB;
86 FStringData: rawbytestring;
87 FStringCached: boolean;
88 protected
89 FCreating: boolean;
90 FBlobID: TISC_QUAD;
91 procedure CheckReadable; virtual; abstract;
92 procedure CheckWritable; virtual; abstract;
93 procedure ClearStringCache;
94 function GetIntf: IBlob; virtual; abstract;
95 procedure GetInfo(Request: array of byte; Response: IBlobInfo); overload; virtual; abstract;
96 procedure InternalClose(Force: boolean); virtual; abstract;
97 procedure InternalCancel(Force: boolean); virtual; abstract;
98 public
99 constructor Create(Attachment: IAttachment; Transaction: TFBTransaction;
100 MetaData: IBlobMetaData; BPB: IBPB); overload;
101 constructor Create(Attachment: IAttachment; Transaction: TFBTransaction;
102 MetaData: IBlobMetaData; BlobID: TISC_QUAD; BPB: IBPB); overload;
103 destructor Destroy; override;
104 procedure TransactionEnding(aTransaction: TFBTransaction; Force: boolean);
105
106 public
107 {IBlobMetaData}
108 function GetSubType: integer;
109 function GetCharSetID: cardinal;
110 function GetCodePage: TSystemCodePage;
111 function GetSegmentSize: cardinal;
112 function GetRelationName: AnsiString;
113 function GetColumnName: AnsiString;
114 function GetUnconfirmedCharacterSet: boolean;
115
116 {IBlob}
117 function GetBPB: IBPB;
118 procedure Cancel;
119 procedure Close;
120 function GetBlobSize: Int64;
121 procedure GetInfo(var NumSegments: Int64; var MaxSegmentSize, TotalSize: Int64;
122 var BlobType: TBlobType); overload;
123 function GetBlobID: TISC_QUAD;
124 function GetBlobMode: TFBBlobMode;
125 function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
126 function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
127 function LoadFromFile(Filename: AnsiString): IBlob;
128 function LoadFromStream(S: TStream) : IBlob;
129 function SaveToFile(Filename: AnsiString): IBlob;
130 function SaveToStream(S: TStream): IBlob;
131 function GetAttachment: IAttachment;
132 function GetTransaction: ITransaction;
133 function GetAsString: rawbytestring;
134 procedure SetAsString(aValue: rawbytestring);
135 function SetString(aValue: rawbytestring): IBlob;
136 end;
137
138
139
140 implementation
141
142 uses FBMessages;
143
144 { TFBBlob }
145
146 procedure TFBBlob.ClearStringCache;
147 begin
148 FStringData := '';
149 FStringCached := false;
150 end;
151
152 constructor TFBBlob.Create(Attachment: IAttachment;
153 Transaction: TFBTransaction; MetaData: IBlobMetaData; BPB: IBPB);
154 begin
155 inherited Create(Transaction);
156 FAttachment := Attachment;
157 FTransaction := Transaction;
158 FMetaData := MetaData;
159 FBPB := BPB;
160 FCreating := true;
161 end;
162
163 constructor TFBBlob.Create(Attachment: IAttachment;
164 Transaction: TFBTransaction; MetaData: IBlobMetaData; BlobID: TISC_QUAD; BPB: IBPB);
165 begin
166 Create(Attachment,Transaction,MetaData,BPB);
167 FBlobID := BlobID;
168 FCreating := false;
169 end;
170
171 destructor TFBBlob.Destroy;
172 begin
173 if FCreating then
174 Cancel
175 else
176 Close;
177 inherited Destroy;
178 end;
179
180 procedure TFBBlob.TransactionEnding(aTransaction: TFBTransaction;
181 Force: boolean);
182 begin
183 if aTransaction <> (FTransaction as TFBTransaction) then
184 Exit;
185 if FCreating then
186 InternalCancel(Force)
187 else
188 InternalClose(Force);
189 end;
190
191 function TFBBlob.GetSubType: integer;
192 begin
193 Result := FMetaData.GetSubType;
194 end;
195
196 function TFBBlob.GetCharSetID: cardinal;
197 begin
198 Result := FMetaData.GetCharSetID;
199 end;
200
201 function TFBBlob.GetCodePage: TSystemCodePage;
202 begin
203 Result := FMetaData.GetCodePage;
204 end;
205
206 function TFBBlob.GetSegmentSize: cardinal;
207 begin
208 Result := FMetaData.GetSegmentSize;
209 end;
210
211 function TFBBlob.GetRelationName: AnsiString;
212 begin
213 Result := FMetaData.GetRelationName;
214 end;
215
216 function TFBBlob.GetColumnName: AnsiString;
217 begin
218 Result := FMetaData.GetColumnName;
219 end;
220
221 function TFBBlob.GetUnconfirmedCharacterSet: boolean;
222 begin
223 Result := (FMetadata as TFBBlobMetadata).GetUnconfirmedCharacterSet;
224 end;
225
226 function TFBBlob.GetBPB: IBPB;
227 begin
228 Result := FBPB;
229 end;
230
231 procedure TFBBlob.Cancel;
232 begin
233 InternalCancel(false);
234 end;
235
236 procedure TFBBlob.Close;
237 begin
238 InternalClose(false);
239 end;
240
241 function TFBBlob.GetBlobSize: Int64;
242 var NumSegments: Int64;
243 MaxSegmentSize: Int64;
244 BlobType: TBlobType;
245 begin
246 GetInfo(NumSegments,MaxSegmentSize,Result,BlobType);
247 end;
248
249 procedure TFBBlob.GetInfo(var NumSegments: Int64; var MaxSegmentSize,
250 TotalSize: Int64; var BlobType: TBlobType);
251 var BlobInfo: IBlobInfo;
252 i: integer;
253 begin
254 NumSegments := 0;
255 MaxSegmentSize := 0;
256 TotalSize := 0;
257 BlobType := btSegmented;
258
259 BlobInfo := TBlobInfo.Create;
260 GetInfo([isc_info_blob_num_segments,
261 isc_info_blob_max_segment,
262 isc_info_blob_total_length,
263 isc_info_blob_type],BlobInfo);
264
265 for i := 0 to BlobInfo.Count - 1 do
266 with BlobInfo[i] do
267 case getItemType of
268 isc_info_blob_num_segments:
269 NumSegments := GetAsInteger;
270 isc_info_blob_max_segment:
271 MaxSegmentSize := GetAsInteger;
272 isc_info_blob_total_length:
273 TotalSize := GetAsInteger;
274 isc_info_blob_type:
275 if GetAsInteger = 0 then
276 BlobType := btSegmented
277 else
278 BlobType := btStream;
279 end;
280 end;
281
282 function TFBBlob.GetBlobID: TISC_QUAD;
283 begin
284 Result := FBlobID;
285 end;
286
287 function TFBBlob.GetBlobMode: TFBBlobMode;
288 begin
289 if FCreating then
290 Result := fbmWrite
291 else
292 Result := fbmRead;
293 end;
294
295 function TFBBlob.LoadFromFile(Filename: AnsiString): IBlob;
296 var
297 Stream: TStream;
298 begin
299 Stream := TFileStream.Create(FileName, fmOpenRead);
300 try
301 Result := LoadFromStream(Stream);
302 finally
303 Stream.Free;
304 end;
305 end;
306
307 const BufSize = 8 * 1024;
308
309 function TFBBlob.LoadFromStream(S: TStream): IBlob;
310 var Buffer: array [0..BufSize-1] of char;
311 BytesRead: integer;
312 begin
313 CheckWritable;
314 S.Position := 0;
315 repeat
316 BytesRead := S.Read(Buffer,BufSize);
317 Write(Buffer,BytesRead);
318 until BytesRead = 0;
319 Close;
320 Result := GetIntf;
321 end;
322
323 function TFBBlob.SaveToFile(Filename: AnsiString): IBlob;
324 var
325 Stream: TStream;
326 begin
327 Stream := TFileStream.Create(FileName, fmCreate);
328 try
329 Result := SaveToStream(Stream);
330 finally
331 Stream.Free;
332 end;
333 end;
334
335 function TFBBlob.SaveToStream(S: TStream): IBlob;
336 var Buffer: array [0..BufSize-1] of char;
337 BytesRead: integer;
338 begin
339 CheckReadable;
340 repeat
341 BytesRead := Read(Buffer,BufSize);
342 S.Write(Buffer,BytesRead);
343 until BytesRead = 0;
344 Close;
345 Result := GetIntf;
346 end;
347
348 function TFBBlob.GetAttachment: IAttachment;
349 begin
350 Result := FAttachment;
351 end;
352
353 function TFBBlob.GetTransaction: ITransaction;
354 begin
355 Result := FTransaction;
356 end;
357
358 function TFBBlob.GetAsString: rawbytestring;
359 var ss: TStringStream;
360 begin
361 if FStringCached then
362 begin
363 Result := FStringData;
364 Exit;
365 end;
366
367 ss := TStringStream.Create('');
368 try
369 SaveToStream(ss);
370 Result := ss.DataString;
371 if (GetSubType = 1) and (FBPB = nil) then
372 SetCodePage(Result,GetCodePage,false);
373 finally
374 ss.Free;
375 end;
376 FStringData := Result;
377 FStringCached := true;
378 end;
379
380 procedure TFBBlob.SetAsString(aValue: rawbytestring);
381 var
382 ss: TStringStream;
383 begin
384 {if GetUnconfirmedCharacterSet then
385 IBError(ibxeNoDefaultCharacterSet,[nil]);}
386
387 if (GetSubType = 1) and (StringCodePage(aValue) <> GetCodePage) and
388 (GetCodePage <> CP_NONE) and (FBPB = nil) then
389 SetCodePage(aValue,GetCodePage,true);
390 ss := TStringStream.Create(aValue);
391 try
392 LoadFromStream(ss);
393 finally
394 ss.Free;
395 end;
396 FStringData := aValue;
397 FStringCached := true;
398 end;
399
400 function TFBBlob.SetString(aValue: rawbytestring): IBlob;
401 begin
402 SetAsString(aValue);
403 Result := GetIntf;
404 end;
405
406 {TFBBlobMetaData}
407
408 function TFBBlobMetaData.CanFetchMetaData: boolean;
409 begin
410 Result := (FRelationName <> '') and (FColumnName <> '');
411 end;
412
413 procedure TFBBlobMetaData.NeedSubType;
414 begin
415 if not FHasSubType then
416 begin
417 NeedFullMetadata;
418 FHasSubType := true;
419 end;
420 end;
421
422 constructor TFBBlobMetaData.Create(Transaction: TFBTransaction; RelationName,
423 ColumnName: AnsiString);
424 begin
425 inherited Create(Transaction);
426 // if (RelationName = '') or (ColumnName = '') then
427 // IBError(ibxeMissingColumnName,[]);
428 FRelationName := RelationName;
429 FColumnName := ColumnName;
430 FSegmentSize := 80;
431 FUnconfirmedCharacterSet := true;
432 FCharSetID := 0;
433 end;
434
435 procedure TFBBlobMetaData.SetCharSetID(aValue: integer);
436 begin
437 FCharSetID := aValue;
438 FUnconfirmedCharacterSet := false;
439 end;
440
441 function TFBBlobMetaData.GetSubType: integer;
442 begin
443 NeedSubType;
444 Result := FSubType;
445 end;
446
447 function TFBBlobMetaData.GetCharSetID: cardinal;
448 begin
449 if FUnconfirmedCharacterSet and CanFetchMetaData then
450 NeedFullMetadata;
451 Result := FCharSetID;
452 end;
453
454 function TFBBlobMetaData.GetCodePage: TSystemCodePage;
455 begin
456 Attachment.CharSetID2CodePage(GetCharSetID,Result);
457 end;
458
459 function TFBBlobMetaData.GetSegmentSize: cardinal;
460 begin
461 NeedFullMetadata;
462 Result := FSegmentSize;
463 end;
464
465 function TFBBlobMetaData.GetRelationName: AnsiString;
466 begin
467 Result := FRelationName;
468 end;
469
470 function TFBBlobMetaData.GetColumnName: AnsiString;
471 begin
472 Result := FColumnName;
473 end;
474
475 function TFBBlobMetaData.GetUnconfirmedCharacterSet: boolean;
476 begin
477 NeedFullMetadata;
478 Result := FUnconfirmedCharacterSet;
479 end;
480
481
482 end.
483