ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBBlob.pas
Revision: 60
Committed: Mon Mar 27 15:21:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 11440 byte(s)
Log Message:

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 procedure NeedFullMetadata; virtual; abstract;
62 procedure NeedSubType;
63 public
64 constructor Create(Transaction: TFBTransaction; RelationName, ColumnName: AnsiString
65 );
66 procedure SetCharSetID(aValue: integer);
67
68 public
69 {IBlobMetaData}
70 function GetSubType: integer;
71 function GetCharSetID: cardinal;
72 function GetCodePage: TSystemCodePage;
73 function GetSegmentSize: cardinal;
74 function GetRelationName: AnsiString;
75 function GetColumnName: AnsiString;
76 function GetUnconfirmedCharacterSet: boolean;
77 end;
78
79 TFBBlob = class(TActivityReporter)
80 private
81 FMetaData: IBlobMetaData;
82 FAttachment: IAttachment;
83 FTransaction: ITransaction;
84 FBPB: IBPB;
85 FStringData: rawbytestring;
86 FStringCached: boolean;
87 protected
88 FCreating: boolean;
89 FBlobID: TISC_QUAD;
90 procedure CheckReadable; virtual; abstract;
91 procedure CheckWritable; virtual; abstract;
92 procedure ClearStringCache;
93 function GetIntf: IBlob; virtual; abstract;
94 procedure GetInfo(Request: array of byte; Response: IBlobInfo); overload; virtual; abstract;
95 procedure InternalClose(Force: boolean); virtual; abstract;
96 procedure InternalCancel(Force: boolean); virtual; abstract;
97 public
98 constructor Create(Attachment: IAttachment; Transaction: TFBTransaction;
99 MetaData: IBlobMetaData; BPB: IBPB); overload;
100 constructor Create(Attachment: IAttachment; Transaction: TFBTransaction;
101 MetaData: IBlobMetaData; BlobID: TISC_QUAD; BPB: IBPB); overload;
102 destructor Destroy; override;
103 procedure TransactionEnding(aTransaction: TFBTransaction; Force: boolean);
104
105 public
106 {IBlobMetaData}
107 function GetSubType: integer;
108 function GetCharSetID: cardinal;
109 function GetCodePage: TSystemCodePage;
110 function GetSegmentSize: cardinal;
111 function GetRelationName: AnsiString;
112 function GetColumnName: AnsiString;
113 function GetUnconfirmedCharacterSet: boolean;
114
115 {IBlob}
116 function GetBPB: IBPB;
117 procedure Cancel;
118 procedure Close;
119 function GetBlobSize: Int64;
120 procedure GetInfo(var NumSegments: Int64; var MaxSegmentSize, TotalSize: Int64;
121 var BlobType: TBlobType); overload;
122 function GetBlobID: TISC_QUAD;
123 function GetBlobMode: TFBBlobMode;
124 function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
125 function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
126 function LoadFromFile(Filename: AnsiString): IBlob;
127 function LoadFromStream(S: TStream) : IBlob;
128 function SaveToFile(Filename: AnsiString): IBlob;
129 function SaveToStream(S: TStream): IBlob;
130 function GetAttachment: IAttachment;
131 function GetTransaction: ITransaction;
132 function GetAsString: rawbytestring;
133 procedure SetAsString(aValue: rawbytestring);
134 function SetString(aValue: rawbytestring): IBlob;
135 end;
136
137
138
139 implementation
140
141 uses FBMessages;
142
143 { TFBBlob }
144
145 procedure TFBBlob.ClearStringCache;
146 begin
147 FStringData := '';
148 FStringCached := false;
149 end;
150
151 constructor TFBBlob.Create(Attachment: IAttachment;
152 Transaction: TFBTransaction; MetaData: IBlobMetaData; BPB: IBPB);
153 begin
154 inherited Create(Transaction);
155 FAttachment := Attachment;
156 FTransaction := Transaction;
157 FMetaData := MetaData;
158 FBPB := BPB;
159 FCreating := true;
160 end;
161
162 constructor TFBBlob.Create(Attachment: IAttachment;
163 Transaction: TFBTransaction; MetaData: IBlobMetaData; BlobID: TISC_QUAD; BPB: IBPB);
164 begin
165 Create(Attachment,Transaction,MetaData,BPB);
166 FBlobID := BlobID;
167 FCreating := false;
168 end;
169
170 destructor TFBBlob.Destroy;
171 begin
172 if FCreating then
173 Cancel
174 else
175 Close;
176 inherited Destroy;
177 end;
178
179 procedure TFBBlob.TransactionEnding(aTransaction: TFBTransaction;
180 Force: boolean);
181 begin
182 if aTransaction <> (FTransaction as TFBTransaction) then
183 Exit;
184 if FCreating then
185 InternalCancel(Force)
186 else
187 InternalClose(Force);
188 end;
189
190 function TFBBlob.GetSubType: integer;
191 begin
192 Result := FMetaData.GetSubType;
193 end;
194
195 function TFBBlob.GetCharSetID: cardinal;
196 begin
197 Result := FMetaData.GetCharSetID;
198 end;
199
200 function TFBBlob.GetCodePage: TSystemCodePage;
201 begin
202 Result := FMetaData.GetCodePage;
203 end;
204
205 function TFBBlob.GetSegmentSize: cardinal;
206 begin
207 Result := FMetaData.GetSegmentSize;
208 end;
209
210 function TFBBlob.GetRelationName: AnsiString;
211 begin
212 Result := FMetaData.GetRelationName;
213 end;
214
215 function TFBBlob.GetColumnName: AnsiString;
216 begin
217 Result := FMetaData.GetColumnName;
218 end;
219
220 function TFBBlob.GetUnconfirmedCharacterSet: boolean;
221 begin
222 Result := (FMetadata as TFBBlobMetadata).GetUnconfirmedCharacterSet;
223 end;
224
225 function TFBBlob.GetBPB: IBPB;
226 begin
227 Result := FBPB;
228 end;
229
230 procedure TFBBlob.Cancel;
231 begin
232 InternalCancel(false);
233 end;
234
235 procedure TFBBlob.Close;
236 begin
237 InternalClose(false);
238 end;
239
240 function TFBBlob.GetBlobSize: Int64;
241 var NumSegments: Int64;
242 MaxSegmentSize: Int64;
243 BlobType: TBlobType;
244 begin
245 GetInfo(NumSegments,MaxSegmentSize,Result,BlobType);
246 end;
247
248 procedure TFBBlob.GetInfo(var NumSegments: Int64; var MaxSegmentSize,
249 TotalSize: Int64; var BlobType: TBlobType);
250 var BlobInfo: IBlobInfo;
251 i: integer;
252 begin
253 NumSegments := 0;
254 MaxSegmentSize := 0;
255 TotalSize := 0;
256 BlobType := btSegmented;
257
258 BlobInfo := TBlobInfo.Create;
259 GetInfo([isc_info_blob_num_segments,
260 isc_info_blob_max_segment,
261 isc_info_blob_total_length,
262 isc_info_blob_type],BlobInfo);
263
264 for i := 0 to BlobInfo.Count - 1 do
265 with BlobInfo[i] do
266 case getItemType of
267 isc_info_blob_num_segments:
268 NumSegments := GetAsInteger;
269 isc_info_blob_max_segment:
270 MaxSegmentSize := GetAsInteger;
271 isc_info_blob_total_length:
272 TotalSize := GetAsInteger;
273 isc_info_blob_type:
274 if GetAsInteger = 0 then
275 BlobType := btSegmented
276 else
277 BlobType := btStream;
278 end;
279 end;
280
281 function TFBBlob.GetBlobID: TISC_QUAD;
282 begin
283 Result := FBlobID;
284 end;
285
286 function TFBBlob.GetBlobMode: TFBBlobMode;
287 begin
288 if FCreating then
289 Result := fbmWrite
290 else
291 Result := fbmRead;
292 end;
293
294 function TFBBlob.LoadFromFile(Filename: AnsiString): IBlob;
295 var
296 Stream: TStream;
297 begin
298 Stream := TFileStream.Create(FileName, fmOpenRead);
299 try
300 Result := LoadFromStream(Stream);
301 finally
302 Stream.Free;
303 end;
304 end;
305
306 const BufSize = 8 * 1024;
307
308 function TFBBlob.LoadFromStream(S: TStream): IBlob;
309 var Buffer: array [0..BufSize-1] of char;
310 BytesRead: integer;
311 begin
312 CheckWritable;
313 S.Position := 0;
314 repeat
315 BytesRead := S.Read(Buffer,BufSize);
316 Write(Buffer,BytesRead);
317 until BytesRead = 0;
318 Close;
319 Result := GetIntf;
320 end;
321
322 function TFBBlob.SaveToFile(Filename: AnsiString): IBlob;
323 var
324 Stream: TStream;
325 begin
326 Stream := TFileStream.Create(FileName, fmCreate);
327 try
328 Result := SaveToStream(Stream);
329 finally
330 Stream.Free;
331 end;
332 end;
333
334 function TFBBlob.SaveToStream(S: TStream): IBlob;
335 var Buffer: array [0..BufSize-1] of char;
336 BytesRead: integer;
337 begin
338 CheckReadable;
339 repeat
340 BytesRead := Read(Buffer,BufSize);
341 S.Write(Buffer,BytesRead);
342 until BytesRead = 0;
343 Close;
344 Result := GetIntf;
345 end;
346
347 function TFBBlob.GetAttachment: IAttachment;
348 begin
349 Result := FAttachment;
350 end;
351
352 function TFBBlob.GetTransaction: ITransaction;
353 begin
354 Result := FTransaction;
355 end;
356
357 function TFBBlob.GetAsString: rawbytestring;
358 var ss: TStringStream;
359 begin
360 if FStringCached then
361 begin
362 Result := FStringData;
363 Exit;
364 end;
365
366 ss := TStringStream.Create('');
367 try
368 SaveToStream(ss);
369 Result := ss.DataString;
370 if (GetSubType = 1) and (FBPB = nil) then
371 SetCodePage(Result,GetCodePage,false);
372 finally
373 ss.Free;
374 end;
375 FStringData := Result;
376 FStringCached := true;
377 end;
378
379 procedure TFBBlob.SetAsString(aValue: rawbytestring);
380 var
381 ss: TStringStream;
382 begin
383 {if GetUnconfirmedCharacterSet then
384 IBError(ibxeNoDefaultCharacterSet,[nil]);}
385
386 if (GetSubType = 1) and (StringCodePage(aValue) <> GetCodePage) and
387 (GetCodePage <> CP_NONE) and (FBPB = nil) then
388 SetCodePage(aValue,GetCodePage,true);
389 ss := TStringStream.Create(aValue);
390 try
391 LoadFromStream(ss);
392 finally
393 ss.Free;
394 end;
395 FStringData := aValue;
396 FStringCached := true;
397 end;
398
399 function TFBBlob.SetString(aValue: rawbytestring): IBlob;
400 begin
401 SetAsString(aValue);
402 Result := GetIntf;
403 end;
404
405 {TFBBlobMetaData}
406
407 procedure TFBBlobMetaData.NeedSubType;
408 begin
409 if not FHasSubType then
410 begin
411 NeedFullMetadata;
412 FHasSubType := true;
413 end;
414 end;
415
416 constructor TFBBlobMetaData.Create(Transaction: TFBTransaction; RelationName,
417 ColumnName: AnsiString);
418 begin
419 inherited Create(Transaction);
420 // if (RelationName = '') or (ColumnName = '') then
421 // IBError(ibxeMissingColumnName,[]);
422 FRelationName := RelationName;
423 FColumnName := ColumnName;
424 FSegmentSize := 80;
425 FUnconfirmedCharacterSet := true;
426 FCharSetID := 0;
427 end;
428
429 procedure TFBBlobMetaData.SetCharSetID(aValue: integer);
430 begin
431 FCharSetID := aValue;
432 FUnconfirmedCharacterSet := false;
433 end;
434
435 function TFBBlobMetaData.GetSubType: integer;
436 begin
437 NeedSubType;
438 Result := FSubType;
439 end;
440
441 function TFBBlobMetaData.GetCharSetID: cardinal;
442 begin
443 NeedFullMetadata;
444 Result := FCharSetID;
445 end;
446
447 function TFBBlobMetaData.GetCodePage: TSystemCodePage;
448 begin
449 Attachment.CharSetID2CodePage(GetCharSetID,Result);
450 end;
451
452 function TFBBlobMetaData.GetSegmentSize: cardinal;
453 begin
454 NeedFullMetadata;
455 Result := FSegmentSize;
456 end;
457
458 function TFBBlobMetaData.GetRelationName: AnsiString;
459 begin
460 Result := FRelationName;
461 end;
462
463 function TFBBlobMetaData.GetColumnName: AnsiString;
464 begin
465 Result := FColumnName;
466 end;
467
468 function TFBBlobMetaData.GetUnconfirmedCharacterSet: boolean;
469 begin
470 NeedFullMetadata;
471 Result := FUnconfirmedCharacterSet;
472 end;
473
474
475 end.
476