ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBBlob.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 10311 byte(s)
Log Message:
Committing updates for Release R2-0-1

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