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, 11 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

# 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
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