ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBTransaction.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (17 months, 2 weeks ago) by tony
File size: 11078 byte(s)
Log Message:
Updated for IBX 4 release
Line File contents
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 {************************************************************************}
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 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$interfaces COM}
70 {$ENDIF}
71
72 interface
73
74 uses
75 Classes, SysUtils, IB, FBParamBlock, FBActivityMonitor, FBClientAPI;
76
77 type
78 { TFBTransaction }
79
80 TFBTransaction = class(TActivityReporter, IActivityMonitor,ITransaction)
81 private
82 FFirebirdAPI: TFBClientAPI;
83 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 procedure SetInterface(api: TFBClientAPI); virtual;
92 public
93 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 destructor Destroy; override;
98 procedure DoDefaultTransactionEnd(Force: boolean);
99 property FirebirdAPI: TFBClientAPI read FFirebirdAPI;
100
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 {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 function GetDPBParamTypeName(ParamType: byte): Ansistring;
142 end;
143
144 implementation
145
146 uses FBMessages;
147
148 const
149 isc_tpb_last_tpb_constant = isc_tpb_at_snapshot_number;
150
151 TPBConstantNames: array[1..isc_tpb_last_tpb_constant] of string = (
152 'consistency',
153 'concurrency',
154 'shared',
155 'protected',
156 'exclusive',
157 'wait',
158 'nowait',
159 'read',
160 'write',
161 'lock_read',
162 'lock_write',
163 'verb_time',
164 'commit_time',
165 'ignore_limbo',
166 'read_committed',
167 'autocommit',
168 'rec_version',
169 'no_rec_version',
170 'restart_requests',
171 'no_auto_undo',
172 'lock_timeout',
173 'read_consistency',
174 'at_snapshot_number'
175 );
176
177 { TFBTransaction }
178
179 function TFBTransaction.GenerateTPB(sl: array of byte): ITPB;
180 var
181 i: Integer;
182 begin
183 Result := TTPB.Create(FFirebirdAPI);
184 for i := 0 to Length(sl) - 1 do
185 Result.Add(sl[i]);
186 end;
187
188 procedure TFBTransaction.SetInterface(api: TFBClientAPI);
189 begin
190 FFirebirdAPI := api;
191 end;
192
193 constructor TFBTransaction.Create(api: TFBClientAPI; Attachments: array of IAttachment;
194 Params: array of byte; DefaultCompletion: TTransactionAction);
195 begin
196 Create(api, Attachments,GenerateTPB(Params), DefaultCompletion);
197 end;
198
199 constructor TFBTransaction.Create(api: TFBClientAPI; Attachments: array of IAttachment; TPB: ITPB;
200 DefaultCompletion: TTransactionAction);
201 var
202 i: Integer;
203 begin
204 inherited Create(nil);
205 SetInterface(api);
206 if Length(Attachments) = 0 then
207 IBError(ibxeEmptyAttachmentsList,[nil]);
208
209 {make sure all attachments use same Firebird API}
210 for i := 0 to Length(Attachments) - 1 do
211 if Attachments[i].getFirebirdAPI.GetFBLibrary.GetHandle <> FFirebirdAPI.GetFBLibrary.GetHandle then
212 IBError(ibxeDifferentAPIs,[nil]);
213
214 SetLength(FAttachments,Length(Attachments));
215 for i := 0 to Length(Attachments) - 1 do
216 begin
217 AddMonitor(GetActivityIntf(Attachments[i]));
218 FAttachments[i] := Attachments[i];
219 end;
220 FTPB := TPB;
221 Start(DefaultCompletion);
222 end;
223
224 constructor TFBTransaction.Create(api: TFBClientAPI; Attachment: IAttachment;
225 Params: array of byte; DefaultCompletion: TTransactionAction);
226 begin
227 Create(api,Attachment,GenerateTPB(Params),DefaultCompletion);
228 end;
229
230 constructor TFBTransaction.Create(api: TFBClientAPI; Attachment: IAttachment; TPB: ITPB;
231 DefaultCompletion: TTransactionAction);
232 begin
233 inherited Create(nil);
234 SetInterface(api);
235 AddMonitor(GetActivityIntf(Attachment));
236 SetLength(FAttachments,1);
237 FAttachments[0] := Attachment;
238 FTPB := TPB;
239 Start(DefaultCompletion);
240 end;
241
242 destructor TFBTransaction.Destroy;
243 begin
244 DoDefaultTransactionEnd(false);
245 inherited Destroy;
246 end;
247
248 procedure TFBTransaction.DoDefaultTransactionEnd(Force: boolean);
249 var i: integer;
250 intf: IUnknown;
251 user: ITransactionUser;
252 begin
253 if InTransaction then
254 begin
255 for i := 0 to InterfaceCount - 1 do
256 begin
257 intf := GetInterface(i);
258 if (intf <> nil) and (intf.QueryInterface(ITransactionUser,user) = S_OK) then
259 user.TransactionEnding(self,Force);
260 end;
261 case FDefaultCompletion of
262 taRollback:
263 Rollback(Force);
264 taCommit:
265 Commit(Force);
266 end;
267 end;
268 end;
269
270 function TFBTransaction.getTPB: ITPB;
271 begin
272 Result := FTPB;
273 end;
274
275 function TFBTransaction.GetAttachmentCount: integer;
276 begin
277 Result := Length(FAttachments);
278 end;
279
280 function TFBTransaction.GetAttachment(index: integer): IAttachment;
281 begin
282 if (index >= 0) and (index < Length(FAttachments)) then
283 Result := FAttachments[index]
284 else
285 IBError(ibxeAttachmentListIndexError,[index]);
286 end;
287
288 procedure TFBTransaction.Start(TPB: ITPB; DefaultCompletion: TTransactionCompletion
289 );
290 begin
291 FTPB := TPB;
292 Start(DefaultCompletion);
293 end;
294
295 { TTPBItem }
296
297 function TTPBItem.getParamTypeName: AnsiString;
298 begin
299 Result := TPBPrefix + TPBConstantNames[getParamType];
300 end;
301
302
303 {TTPB}
304
305 constructor TTPB.Create(api: TFBClientAPI);
306 begin
307 inherited Create(api);
308 FDataLength := 1;
309 FBuffer^ := isc_tpb_version3;
310 end;
311
312 function TTPB.GetDPBParamTypeName(ParamType: byte): Ansistring;
313 begin
314 if ParamType <= isc_tpb_last_tpb_constant then
315 Result := TPBConstantNames[ParamType]
316 else
317 Result := '';
318 end;
319
320 function TTPB.LookupItemType(ParamTypeName: AnsiString): byte;
321 var i: byte;
322 begin
323 Result := 0;
324 ParamTypeName := LowerCase(ParamTypeName);
325 if (Pos(TPBPrefix, ParamTypeName) = 1) then
326 Delete(ParamTypeName, 1, Length(TPBPrefix));
327
328 for i := 1 to isc_tpb_last_tpb_constant do
329 if (ParamTypeName = TPBConstantNames[i]) then
330 begin
331 Result := i;
332 break;
333 end;
334 end;
335
336 end.
337