ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBBlob.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 4 months ago) by tony
Content type: text/x-pascal
File size: 10081 byte(s)
Log Message:
Committing updates for Release R2-0-0

File Contents

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