ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBBlob.pas
Revision: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 11390 byte(s)
Log Message:
Committing updates for Trunk

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