ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBTransaction.pas
Revision: 363
Committed: Tue Dec 7 13:30:05 2021 UTC (8 months ago) by tony
File size: 20484 byte(s)
Log Message:
add fbintf
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, FBOutputBlock;
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: TTransactionCompletion;
88 FAttachments: array of IAttachment; {Keep reference to attachment - ensures
89 attachment cannot be freed before transaction}
90 FTransactionName: AnsiString;
91 procedure CheckHandle;
92 function GetActivityIntf(att: IAttachment): IActivityMonitor; virtual; abstract;
93 function GetJournalIntf(Attachment: IAttachment): IJournallingHook;
94 procedure SetInterface(api: TFBClientAPI); virtual;
95 function GetTrInfo(ReqBuffer: PByte; ReqBufLen: integer): ITrInformation; virtual; abstract;
96 procedure InternalStartSingle(attachment: IAttachment); virtual; abstract;
97 procedure InternalStartMultiple; virtual; abstract;
98 procedure InternalCommit(Force: boolean); virtual; abstract;
99 procedure InternalCommitRetaining; virtual; abstract;
100 procedure InternalRollback(Force: boolean); virtual; abstract;
101 procedure InternalRollbackRetaining; virtual; abstract;
102 public
103 constructor Create(api: TFBClientAPI; Attachments: array of IAttachment; Params: array of byte; DefaultCompletion: TTransactionAction; aName: AnsiString); overload;
104 constructor Create(api: TFBClientAPI; Attachments: array of IAttachment; TPB: ITPB; DefaultCompletion: TTransactionAction; aName: AnsiString); overload;
105 constructor Create(api: TFBClientAPI; Attachment: IAttachment; Params: array of byte; DefaultCompletion: TTransactionAction; aName: AnsiString); overload;
106 constructor Create(api: TFBClientAPI; Attachment: IAttachment; TPB: ITPB; DefaultCompletion: TTransactionAction; aName: AnsiString); overload;
107 destructor Destroy; override;
108 procedure DoDefaultTransactionEnd(Force: boolean);
109 property FirebirdAPI: TFBClientAPI read FFirebirdAPI;
110
111 public
112 {ITransaction}
113 function getTPB: ITPB;
114 procedure PrepareForCommit;virtual; abstract;
115 procedure Commit(Force: boolean=false);
116 procedure CommitRetaining;
117 function GetInTransaction: boolean; virtual; abstract;
118 function GetIsReadOnly: boolean;
119 function GetTransactionID: integer;
120 function GetAttachmentCount: integer;
121 function GetAttachment(index: integer): IAttachment;
122 function GetJournalingActive(attachment: IAttachment): boolean;
123 function GetDefaultCompletion: TTransactionCompletion;
124 procedure Rollback(Force: boolean=false);
125 procedure RollbackRetaining;
126 procedure Start(DefaultCompletion: TTransactionCompletion=taCommit); overload;
127 procedure Start(TPB: ITPB; DefaultCompletion: TTransactionCompletion=taCommit); overload;
128 function GetTrInformation(Requests: array of byte): ITrInformation; overload;
129 function GetTrInformation(Request: byte): ITrInformation; overload;
130 function GetTransactionName: AnsiString;
131 procedure SetTransactionName(aValue: AnsiString);
132
133 property InTransaction: boolean read GetInTransaction;
134 property TransactionSeqNo: integer read FSeqNo;
135 end;
136
137 {The transaction user interface is used to force an action on the end of the
138 transaction.}
139
140 ITransactionUser = interface
141 ['{156fcdc9-a326-44b3-a82d-f23c6fb9f97c}']
142 procedure TransactionEnding(aTransaction: ITransaction; Force: boolean);
143 end;
144
145 { TTPBItem }
146
147 TTPBItem = class(TParamBlockItem,ITPBItem)
148 public
149 function getParamTypeName: AnsiString; override;
150 end;
151
152 { TTPB }
153
154 TTPB = class (TCustomParamBlock<TTPBItem,ITPBItem>, ITPB)
155 protected
156 function LookupItemType(ParamTypeName: AnsiString): byte; override;
157 public
158 constructor Create(api: TFBClientAPI);
159 function GetParamTypeName(ParamType: byte): Ansistring;
160 {$IFDEF FPC}
161 function ITPB.GetDPBParamTypeName = GetParamTypeName;
162 {$ELSE}
163 function GetDPBParamTypeName(ParamType: byte): Ansistring;
164 {$ENDIF}
165 function AsText: AnsiString;
166 end;
167
168 {$IFDEF FPC}
169 TTrInfoItem = class;
170
171 { TTrInfoItem }
172
173 TTrInfoItem = class(TOutputBlockItemGroup<TTrInfoItem,ITrInfoItem>,ITrInfoItem)
174 {$ELSE}
175 TTrInfoItem = class(TOutputBlockItemGroup<TOutputBlockItem,ITrInfoItem>,ITrInfoItem)
176 {$ENDIF}
177 public
178 procedure DecodeTraIsolation(var IsolationType, RecVersion: byte);
179 end;
180
181 { TTrInformation }
182
183 TTrInformation = class(TCustomOutputBlock<TTrInfoItem,ITrInfoItem>, ITrInformation)
184 protected
185 procedure DoParseBuffer; override;
186 public
187 constructor Create(api: TFBClientAPI; aSize: integer = DefaultBufferSize);
188 {$IFNDEF FPC}
189 function Find(ItemType: byte): ITrInfoItem;
190 {$ENDIF}
191 end;
192
193
194 implementation
195
196 uses FBMessages;
197
198 const
199 isc_tpb_last_tpb_constant = isc_tpb_at_snapshot_number;
200
201 TPBConstantNames: array[1..isc_tpb_last_tpb_constant] of string = (
202 'consistency',
203 'concurrency',
204 'shared',
205 'protected',
206 'exclusive',
207 'wait',
208 'nowait',
209 'read',
210 'write',
211 'lock_read',
212 'lock_write',
213 'verb_time',
214 'commit_time',
215 'ignore_limbo',
216 'read_committed',
217 'autocommit',
218 'rec_version',
219 'no_rec_version',
220 'restart_requests',
221 'no_auto_undo',
222 'lock_timeout',
223 'read_consistency',
224 'at_snapshot_number'
225 );
226
227 { TFBTransaction }
228
229 function TFBTransaction.GenerateTPB(sl: array of byte): ITPB;
230 var
231 i: Integer;
232 begin
233 Result := TTPB.Create(FFirebirdAPI);
234 for i := 0 to Length(sl) - 1 do
235 Result.Add(sl[i]);
236 end;
237
238 procedure TFBTransaction.CheckHandle;
239 begin
240 if not InTransaction then
241 IBError(ibxeNotInTransaction,[]);
242 end;
243
244 function TFBTransaction.GetJournalIntf(Attachment: IAttachment): IJournallingHook;
245 begin
246 Attachment.QueryInterface(IJournallingHook,Result)
247 end;
248
249 procedure TFBTransaction.SetInterface(api: TFBClientAPI);
250 begin
251 FFirebirdAPI := api;
252 end;
253
254 constructor TFBTransaction.Create(api: TFBClientAPI; Attachments: array of IAttachment;
255 Params: array of byte; DefaultCompletion: TTransactionAction; aName: AnsiString);
256 begin
257 Create(api, Attachments,GenerateTPB(Params), DefaultCompletion, aName);
258 end;
259
260 constructor TFBTransaction.Create(api: TFBClientAPI; Attachments: array of IAttachment; TPB: ITPB;
261 DefaultCompletion: TTransactionAction; aName: AnsiString);
262 var
263 i: Integer;
264 begin
265 inherited Create(nil);
266 FTransactionName := aName;
267 SetInterface(api);
268 if Length(Attachments) = 0 then
269 IBError(ibxeEmptyAttachmentsList,[nil]);
270
271 {make sure all attachments use same Firebird API}
272 for i := 0 to Length(Attachments) - 1 do
273 if Attachments[i].getFirebirdAPI.GetFBLibrary.GetHandle <> FFirebirdAPI.GetFBLibrary.GetHandle then
274 IBError(ibxeDifferentAPIs,[nil]);
275
276 SetLength(FAttachments,Length(Attachments));
277 for i := 0 to Length(Attachments) - 1 do
278 begin
279 AddMonitor(GetActivityIntf(Attachments[i]));
280 FAttachments[i] := Attachments[i];
281 end;
282 FTPB := TPB;
283 Start(DefaultCompletion);
284 end;
285
286 constructor TFBTransaction.Create(api: TFBClientAPI; Attachment: IAttachment;
287 Params: array of byte; DefaultCompletion: TTransactionAction; aName: AnsiString);
288 begin
289 Create(api,Attachment,GenerateTPB(Params),DefaultCompletion,aName);
290 end;
291
292 constructor TFBTransaction.Create(api: TFBClientAPI; Attachment: IAttachment; TPB: ITPB;
293 DefaultCompletion: TTransactionAction; aName: AnsiString);
294 begin
295 inherited Create(nil);
296 SetInterface(api);
297 AddMonitor(GetActivityIntf(Attachment));
298 SetLength(FAttachments,1);
299 FAttachments[0] := Attachment;
300 FTPB := TPB;
301 FTransactionName := aName;
302 Start(DefaultCompletion);
303 end;
304
305 destructor TFBTransaction.Destroy;
306 begin
307 DoDefaultTransactionEnd(false);
308 inherited Destroy;
309 end;
310
311 procedure TFBTransaction.DoDefaultTransactionEnd(Force: boolean);
312 var i: integer;
313 intf: IUnknown;
314 user: ITransactionUser;
315 begin
316 if InTransaction then
317 begin
318 for i := 0 to InterfaceCount - 1 do
319 begin
320 intf := GetInterface(i);
321 if (intf <> nil) and (intf.QueryInterface(ITransactionUser,user) = S_OK) then
322 user.TransactionEnding(self,Force);
323 end;
324 case FDefaultCompletion of
325 taRollback:
326 Rollback(Force);
327 taCommit:
328 Commit(Force);
329 end;
330 end;
331 end;
332
333 function TFBTransaction.getTPB: ITPB;
334 begin
335 Result := FTPB;
336 end;
337
338 procedure TFBTransaction.Commit(Force: boolean);
339 var i: integer;
340 TransactionID: integer;
341 TransactionEndNeeded: array of boolean;
342 begin
343 if not GetInTransaction then Exit;
344
345 SetLength(TransactionEndNeeded,Length(FAttachments));
346 TransactionID := GetTransactionID;
347 for i := 0 to Length(FAttachments) - 1 do
348 if (FAttachments[i] <> nil) then
349 TransactionEndNeeded[i] := GetJournalingActive(FAttachments[i])
350 else
351 TransactionEndNeeded[i] := false;
352 InternalCommit(Force);
353 for i := 0 to Length(FAttachments) - 1 do
354 if TransactionEndNeeded[i] then
355 GetJournalIntf(FAttachments[i]).TransactionEnd(TransactionID, TACommit);
356 end;
357
358 procedure TFBTransaction.CommitRetaining;
359 var i: integer;
360 TransactionID: integer;
361 begin
362 if not GetInTransaction then Exit;
363
364 TransactionID := GetTransactionID;
365 InternalCommitRetaining;
366 for i := 0 to Length(FAttachments) - 1 do
367 if (FAttachments[i] <> nil) and GetJournalingActive(FAttachments[i]) then
368 GetJournalIntf(FAttachments[i]).TransactionRetained(self,TransactionID, TACommitRetaining);
369 end;
370
371 function TFBTransaction.GetIsReadOnly: boolean;
372 var Info: ITrInformation;
373 begin
374 Info := GetTrInformation(isc_info_tra_access);
375 if (Info.Count > 0) and (Info[0].getItemType = isc_info_tra_access) then
376 Result := Info[0].getAsInteger = isc_info_tra_readonly
377 else
378 Result := false;
379 end;
380
381 function TFBTransaction.GetTransactionID: integer;
382 var Info: ITrInformation;
383 begin
384 Result := -1;
385 Info := GetTrInformation(isc_info_tra_id);
386 if (Info.Count > 0) and (Info[0].getItemType = isc_info_tra_id) then
387 Result := Info[0].getAsInteger;
388 end;
389
390 function TFBTransaction.GetAttachmentCount: integer;
391 begin
392 Result := Length(FAttachments);
393 end;
394
395 function TFBTransaction.GetAttachment(index: integer): IAttachment;
396 begin
397 if (index >= 0) and (index < Length(FAttachments)) then
398 Result := FAttachments[index]
399 else
400 IBError(ibxeAttachmentListIndexError,[index]);
401 end;
402
403 function TFBTransaction.GetJournalingActive(attachment: IAttachment): boolean;
404 begin
405 Result := false;
406 if (attachment = nil) and (length(FAttachments) > 0) then
407 attachment := FAttachments[0];
408 if attachment <> nil then
409 with attachment do
410 Result := self.GetInTransaction and JournalingActive and
411 ((((joReadOnlyTransactions in GetJournalOptions) and self.GetIsReadOnly)) or
412 ((joReadWriteTransactions in GetJournalOptions) and not self.GetIsReadOnly));
413 end;
414
415 function TFBTransaction.GetDefaultCompletion: TTransactionCompletion;
416 begin
417 Result := FDefaultCompletion;
418 end;
419
420 procedure TFBTransaction.Rollback(Force: boolean);
421 var i: integer;
422 TransactionID: integer;
423 TransactionEndNeeded: array of boolean;
424 begin
425 if not GetInTransaction then Exit;
426
427 SetLength(TransactionEndNeeded,Length(FAttachments));
428 TransactionID := GetTransactionID;
429 for i := 0 to Length(FAttachments) - 1 do
430 if (FAttachments[i] <> nil) then
431 TransactionEndNeeded[i] := GetJournalingActive(FAttachments[i])
432 else
433 TransactionEndNeeded[i] := false;
434 InternalRollback(Force);
435 for i := 0 to Length(FAttachments) - 1 do
436 if TransactionEndNeeded[i] then
437 GetJournalIntf(FAttachments[i]).TransactionEnd(TransactionID, TARollback);
438 end;
439
440 procedure TFBTransaction.RollbackRetaining;
441 var i: integer;
442 TransactionID: integer;
443 begin
444 if not GetInTransaction then Exit;
445
446 TransactionID := GetTransactionID;
447 InternalRollbackRetaining;
448 for i := 0 to Length(FAttachments) - 1 do
449 if (FAttachments[i] <> nil) and GetJournalingActive(FAttachments[i]) then
450 GetJournalIntf(FAttachments[i]).TransactionRetained(self,TransactionID,TARollbackRetaining);
451 end;
452
453 procedure TFBTransaction.Start(DefaultCompletion: TTransactionCompletion);
454 var i: integer;
455 begin
456 if GetInTransaction then
457 Exit;
458
459 FDefaultCompletion := DefaultCompletion;
460
461 if Length(FAttachments) = 1 then
462 InternalStartSingle(FAttachments[0])
463 else
464 InternalStartMultiple;
465 for i := 0 to Length(FAttachments) - 1 do
466 if (FAttachments[i] <> nil) and GetJournalingActive(FAttachments[i]) then
467 GetJournalIntf(FAttachments[i]).TransactionStart(self);
468 Inc(FSeqNo);
469 end;
470
471 procedure TFBTransaction.Start(TPB: ITPB; DefaultCompletion: TTransactionCompletion
472 );
473 begin
474 FTPB := TPB;
475 Start(DefaultCompletion);
476 end;
477
478 function TFBTransaction.GetTrInformation(Requests: array of byte
479 ): ITrInformation;
480 var ReqBuffer: PByte;
481 i: integer;
482 begin
483 CheckHandle;
484 if Length(Requests) = 1 then
485 Result := GetTrInformation(Requests[0])
486 else
487 begin
488 GetMem(ReqBuffer,Length(Requests));
489 try
490 for i := 0 to Length(Requests) - 1 do
491 ReqBuffer[i] := Requests[i];
492
493 Result := GetTrInfo(ReqBuffer,Length(Requests));
494
495 finally
496 FreeMem(ReqBuffer);
497 end;
498 end;
499 end;
500
501 function TFBTransaction.GetTrInformation(Request: byte): ITrInformation;
502 begin
503 CheckHandle;
504 Result := GetTrInfo(@Request,1);
505 end;
506
507 function TFBTransaction.GetTransactionName: AnsiString;
508 begin
509 Result := FTransactionName;
510 end;
511
512 procedure TFBTransaction.SetTransactionName(aValue: AnsiString);
513 begin
514 FTransactionName := aValue;
515 end;
516
517 { TTPBItem }
518
519 function TTPBItem.getParamTypeName: AnsiString;
520 begin
521 Result := TPBPrefix + TPBConstantNames[getParamType];
522 end;
523
524
525 {TTPB}
526
527 constructor TTPB.Create(api: TFBClientAPI);
528 begin
529 inherited Create(api);
530 FDataLength := 1;
531 FBuffer^ := isc_tpb_version3;
532 end;
533
534 function TTPB.GetParamTypeName(ParamType: byte): Ansistring;
535 begin
536 if ParamType <= isc_tpb_last_tpb_constant then
537 Result := TPBPrefix + TPBConstantNames[ParamType]
538 else
539 Result := '';
540 end;
541
542 function TTPB.AsText: AnsiString;
543 var i: integer;
544 begin
545 Result := '[';
546 for i := 0 to getCount - 1 do
547 begin
548 Result := Result + GetParamTypeName(getItems(i).getParamType);
549 if i < getCount - 1 then
550 Result := Result + ',';
551 end;
552 Result := Result + ']';
553 end;
554
555 {$IFNDEF FPC}
556 function TTPB.GetDPBParamTypeName(ParamType: byte): Ansistring;
557 begin
558 Result := GetParamTypeName(ParamType);
559 end;
560 {$ENDIF}
561
562
563 function TTPB.LookupItemType(ParamTypeName: AnsiString): byte;
564 var i: byte;
565 begin
566 Result := 0;
567 ParamTypeName := LowerCase(ParamTypeName);
568 if (Pos(TPBPrefix, ParamTypeName) = 1) then
569 Delete(ParamTypeName, 1, Length(TPBPrefix));
570
571 for i := 1 to isc_tpb_last_tpb_constant do
572 if (ParamTypeName = TPBConstantNames[i]) then
573 begin
574 Result := i;
575 break;
576 end;
577 end;
578
579 { TTrInfoItem }
580
581 procedure TTrInfoItem.DecodeTraIsolation(var IsolationType, RecVersion: byte);
582 begin
583 with FFirebirdClientAPI, ItemData^ do
584 if getItemType = isc_info_tra_isolation then
585 begin
586 if FDataLength = 1 then
587 begin
588 IsolationType := getAsInteger;
589 RecVersion := 0;
590 end
591 else
592 begin
593 IsolationType := (FBufPtr + 3)^;
594 RecVersion := (FBufPtr + 4)^;
595 end
596 end
597 else
598 IBError(ibxeInfoBufferTypeError,[integer(FBufPtr^)]);
599 end;
600
601 { TTrInformation }
602
603 procedure TTrInformation.DoParseBuffer;
604 var P: PByte;
605 index: integer;
606 begin
607 P := Buffer;
608 index := 0;
609 SetLength(FItems,0);
610 while (P^ <> isc_info_end) and (P < Buffer + getBufSize) do
611 begin
612 SetLength(FItems,index+1);
613 case byte(P^) of
614 isc_info_tra_id,
615 isc_info_tra_oldest_interesting,
616 isc_info_tra_oldest_active,
617 isc_info_tra_oldest_snapshot,
618 fb_info_tra_snapshot_number,
619 isc_info_tra_lock_timeout:
620 FItems[index] := AddIntegerItem(P);
621
622 isc_info_tra_isolation,
623 {return transaction isolation mode of current transaction.
624 format of returned clumplets is following:
625
626 isc_info_tra_isolation,
627 1, isc_info_tra_consistency | isc_info_tra_concurrency
628 |
629 2, isc_info_tra_read_committed,
630 isc_info_tra_no_rec_version | isc_info_tra_rec_version
631
632 i.e. for read committed transactions returned 2 items while for
633 other transactions returned 1 item}
634
635 isc_info_tra_access:
636 FItems[index] := AddIntegerItem(P);
637 fb_info_tra_dbpath:
638 FItems[index] := AddStringItem(P);
639 else
640 FItems[index] := AddItem(P);
641 end;
642 P := P + FItems[index]^.FSize;
643 Inc(index);
644 end;
645 end;
646
647 constructor TTrInformation.Create(api: TFBClientAPI; aSize: integer);
648 begin
649 inherited Create(api,aSize);
650 FIntegerType := dtInteger;
651 end;
652
653 {$IFNDEF FPC}
654 function TTrInformation.Find(ItemType: byte): ITrInfoItem;
655 begin
656 Result := inherited Find(ItemType);
657 if Result.GetSize = 0 then
658 Result := nil;
659 end;
660 {$ENDIF}
661
662 end.
663