ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBTransaction.pas
Revision: 345
Committed: Mon Aug 23 14:22:29 2021 UTC (3 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBTransaction.pas
File size: 11374 byte(s)
Log Message:
Merged into public release

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     {************************************************************************}
31     { }
32     { Borland Delphi Visual Component Library }
33     { InterBase Express core components }
34     { }
35     { Copyright (c) 1998-2000 Inprise Corporation }
36     { }
37     { InterBase Express is based in part on the product }
38     { Free IB Components, written by Gregory H. Deatz for }
39     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40     { Free IB Components is used under license. }
41     { }
42     { The contents of this file are subject to the InterBase }
43     { Public License Version 1.0 (the "License"); you may not }
44     { use this file except in compliance with the License. You }
45     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46     { Software distributed under the License is distributed on }
47     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48     { express or implied. See the License for the specific language }
49     { governing rights and limitations under the License. }
50     { The Original Code was created by InterBase Software Corporation }
51     { and its successors. }
52     { Portions created by Inprise Corporation are Copyright (C) Inprise }
53     { Corporation. All Rights Reserved. }
54     { Contributor(s): Jeff Overcash }
55     { }
56     { IBX For Lazarus (Firebird Express) }
57     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58     { Portions created by MWA Software are copyright McCallum Whyman }
59     { Associates Ltd 2011 - 2015 }
60     { }
61     {************************************************************************}
62     unit FBTransaction;
63 tony 56 {$IFDEF MSWINDOWS}
64     {$DEFINE WINDOWS}
65     {$ENDIF}
66 tony 45
67     {$IFDEF FPC}
68 tony 56 {$mode delphi}
69 tony 45 {$interfaces COM}
70     {$ENDIF}
71    
72     interface
73    
74     uses
75 tony 263 Classes, SysUtils, IB, FBParamBlock, FBActivityMonitor, FBClientAPI;
76 tony 45
77     type
78     { TFBTransaction }
79    
80     TFBTransaction = class(TActivityReporter, IActivityMonitor,ITransaction)
81     private
82 tony 263 FFirebirdAPI: TFBClientAPI;
83 tony 45 function GenerateTPB(sl: array of byte): ITPB;
84     protected
85     FTPB: ITPB;
86     FSeqNo: integer;
87     FDefaultCompletion: TTransactionAction;
88     FAttachments: array of IAttachment; {Keep reference to attachment - ensures
89     attachment cannot be freed before transaction}
90     function GetActivityIntf(att: IAttachment): IActivityMonitor; virtual; abstract;
91 tony 263 procedure SetInterface(api: TFBClientAPI); virtual;
92 tony 45 public
93 tony 263 constructor Create(api: TFBClientAPI; Attachments: array of IAttachment; Params: array of byte; DefaultCompletion: TTransactionAction); overload;
94     constructor Create(api: TFBClientAPI; Attachments: array of IAttachment; TPB: ITPB; DefaultCompletion: TTransactionAction); overload;
95     constructor Create(api: TFBClientAPI; Attachment: IAttachment; Params: array of byte; DefaultCompletion: TTransactionAction); overload;
96     constructor Create(api: TFBClientAPI; Attachment: IAttachment; TPB: ITPB; DefaultCompletion: TTransactionAction); overload;
97 tony 45 destructor Destroy; override;
98     procedure DoDefaultTransactionEnd(Force: boolean);
99 tony 263 property FirebirdAPI: TFBClientAPI read FFirebirdAPI;
100 tony 45
101     public
102     {ITransaction}
103     function getTPB: ITPB;
104     procedure PrepareForCommit;virtual; abstract;
105     procedure Commit(Force: boolean=false); virtual; abstract;
106     procedure CommitRetaining; virtual; abstract;
107     function GetInTransaction: boolean; virtual; abstract;
108     function GetAttachmentCount: integer;
109     function GetAttachment(index: integer): IAttachment;
110     procedure Rollback(Force: boolean=false); virtual; abstract;
111     procedure RollbackRetaining; virtual; abstract;
112     procedure Start(DefaultCompletion: TTransactionCompletion=taCommit); overload; virtual; abstract;
113     procedure Start(TPB: ITPB; DefaultCompletion: TTransactionCompletion=taCommit); overload;
114    
115     property InTransaction: boolean read GetInTransaction;
116     property TransactionSeqNo: integer read FSeqNo;
117     end;
118    
119 tony 315 {The transaction user interface is used to force an action on the end of the
120     transaction.}
121    
122     ITransactionUser = interface
123     ['{156fcdc9-a326-44b3-a82d-f23c6fb9f97c}']
124     procedure TransactionEnding(aTransaction: ITransaction; Force: boolean);
125     end;
126    
127     { TTPBItem }
128    
129     TTPBItem = class(TParamBlockItem,ITPBItem)
130     public
131     function getParamTypeName: AnsiString; override;
132     end;
133    
134     { TTPB }
135    
136     TTPB = class (TCustomParamBlock<TTPBItem,ITPBItem>, ITPB)
137     protected
138     function LookupItemType(ParamTypeName: AnsiString): byte; override;
139     public
140     constructor Create(api: TFBClientAPI);
141 tony 345 function GetParamTypeName(ParamType: byte): Ansistring;
142     {$IFDEF FPC}
143     function ITPB.GetDPBParamTypeName = GetParamTypeName;
144     {$ELSE}
145 tony 315 function GetDPBParamTypeName(ParamType: byte): Ansistring;
146 tony 345 {$ENDIF}
147     end;
148 tony 315
149 tony 45 implementation
150    
151 tony 315 uses FBMessages;
152 tony 45
153 tony 315 const
154     isc_tpb_last_tpb_constant = isc_tpb_at_snapshot_number;
155    
156     TPBConstantNames: array[1..isc_tpb_last_tpb_constant] of string = (
157     'consistency',
158     'concurrency',
159     'shared',
160     'protected',
161     'exclusive',
162     'wait',
163     'nowait',
164     'read',
165     'write',
166     'lock_read',
167     'lock_write',
168     'verb_time',
169     'commit_time',
170     'ignore_limbo',
171     'read_committed',
172     'autocommit',
173     'rec_version',
174     'no_rec_version',
175     'restart_requests',
176     'no_auto_undo',
177     'lock_timeout',
178     'read_consistency',
179     'at_snapshot_number'
180     );
181    
182 tony 45 { TFBTransaction }
183    
184     function TFBTransaction.GenerateTPB(sl: array of byte): ITPB;
185     var
186     i: Integer;
187     begin
188 tony 263 Result := TTPB.Create(FFirebirdAPI);
189 tony 45 for i := 0 to Length(sl) - 1 do
190     Result.Add(sl[i]);
191     end;
192    
193 tony 263 procedure TFBTransaction.SetInterface(api: TFBClientAPI);
194     begin
195     FFirebirdAPI := api;
196     end;
197    
198     constructor TFBTransaction.Create(api: TFBClientAPI; Attachments: array of IAttachment;
199 tony 45 Params: array of byte; DefaultCompletion: TTransactionAction);
200     begin
201 tony 263 Create(api, Attachments,GenerateTPB(Params), DefaultCompletion);
202 tony 45 end;
203    
204 tony 263 constructor TFBTransaction.Create(api: TFBClientAPI; Attachments: array of IAttachment; TPB: ITPB;
205 tony 45 DefaultCompletion: TTransactionAction);
206     var
207     i: Integer;
208     begin
209     inherited Create(nil);
210 tony 263 SetInterface(api);
211 tony 45 if Length(Attachments) = 0 then
212     IBError(ibxeEmptyAttachmentsList,[nil]);
213    
214 tony 263 {make sure all attachments use same Firebird API}
215     for i := 0 to Length(Attachments) - 1 do
216     if Attachments[i].getFirebirdAPI.GetFBLibrary.GetHandle <> FFirebirdAPI.GetFBLibrary.GetHandle then
217     IBError(ibxeDifferentAPIs,[nil]);
218    
219 tony 45 SetLength(FAttachments,Length(Attachments));
220     for i := 0 to Length(Attachments) - 1 do
221     begin
222     AddMonitor(GetActivityIntf(Attachments[i]));
223     FAttachments[i] := Attachments[i];
224     end;
225     FTPB := TPB;
226     Start(DefaultCompletion);
227     end;
228    
229 tony 263 constructor TFBTransaction.Create(api: TFBClientAPI; Attachment: IAttachment;
230 tony 45 Params: array of byte; DefaultCompletion: TTransactionAction);
231     begin
232 tony 263 Create(api,Attachment,GenerateTPB(Params),DefaultCompletion);
233 tony 45 end;
234    
235 tony 263 constructor TFBTransaction.Create(api: TFBClientAPI; Attachment: IAttachment; TPB: ITPB;
236 tony 45 DefaultCompletion: TTransactionAction);
237     begin
238     inherited Create(nil);
239 tony 263 SetInterface(api);
240 tony 45 AddMonitor(GetActivityIntf(Attachment));
241     SetLength(FAttachments,1);
242     FAttachments[0] := Attachment;
243     FTPB := TPB;
244     Start(DefaultCompletion);
245     end;
246    
247     destructor TFBTransaction.Destroy;
248     begin
249     DoDefaultTransactionEnd(false);
250     inherited Destroy;
251     end;
252    
253     procedure TFBTransaction.DoDefaultTransactionEnd(Force: boolean);
254     var i: integer;
255 tony 315 intf: IUnknown;
256     user: ITransactionUser;
257 tony 45 begin
258     if InTransaction then
259     begin
260     for i := 0 to InterfaceCount - 1 do
261     begin
262     intf := GetInterface(i);
263 tony 315 if (intf <> nil) and (intf.QueryInterface(ITransactionUser,user) = S_OK) then
264     user.TransactionEnding(self,Force);
265 tony 45 end;
266     case FDefaultCompletion of
267     taRollback:
268     Rollback(Force);
269     taCommit:
270     Commit(Force);
271     end;
272     end;
273     end;
274    
275     function TFBTransaction.getTPB: ITPB;
276     begin
277     Result := FTPB;
278     end;
279    
280     function TFBTransaction.GetAttachmentCount: integer;
281     begin
282     Result := Length(FAttachments);
283     end;
284    
285     function TFBTransaction.GetAttachment(index: integer): IAttachment;
286     begin
287     if (index >= 0) and (index < Length(FAttachments)) then
288     Result := FAttachments[index]
289     else
290     IBError(ibxeAttachmentListIndexError,[index]);
291     end;
292    
293     procedure TFBTransaction.Start(TPB: ITPB; DefaultCompletion: TTransactionCompletion
294     );
295     begin
296     FTPB := TPB;
297     Start(DefaultCompletion);
298     end;
299    
300 tony 315 { TTPBItem }
301    
302     function TTPBItem.getParamTypeName: AnsiString;
303     begin
304     Result := TPBPrefix + TPBConstantNames[getParamType];
305     end;
306    
307    
308     {TTPB}
309    
310     constructor TTPB.Create(api: TFBClientAPI);
311     begin
312     inherited Create(api);
313     FDataLength := 1;
314     FBuffer^ := isc_tpb_version3;
315     end;
316    
317 tony 345 function TTPB.GetParamTypeName(ParamType: byte): Ansistring;
318 tony 315 begin
319     if ParamType <= isc_tpb_last_tpb_constant then
320     Result := TPBConstantNames[ParamType]
321     else
322     Result := '';
323     end;
324    
325 tony 345 {$IFNDEF FPC}
326     function TTPB.GetDPBParamTypeName(ParamType: byte): Ansistring;
327     begin
328     Result := GetParamTypeName(ParamType);
329     end;
330     {$ENDIF}
331    
332    
333 tony 315 function TTPB.LookupItemType(ParamTypeName: AnsiString): byte;
334     var i: byte;
335     begin
336     Result := 0;
337     ParamTypeName := LowerCase(ParamTypeName);
338     if (Pos(TPBPrefix, ParamTypeName) = 1) then
339     Delete(ParamTypeName, 1, Length(TPBPrefix));
340    
341     for i := 1 to isc_tpb_last_tpb_constant do
342     if (ParamTypeName = TPBConstantNames[i]) then
343     begin
344     Result := i;
345     break;
346     end;
347     end;
348    
349 tony 45 end.
350