examples/services/LimboTransactionsUnit.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*) 
            
unit LimboTransactionsUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  Grids, IBServices;

type
  { TLimboTransactionsForm }

  TLimboTransactionsForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    LimboTransactionValidation: TIBValidationService;
    Label1: TLabel;
    StringGrid1: TStringGrid;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure StringGrid1EditingDone(Sender: TObject);
  private
    { private declarations }
    procedure DoRefresh(Data: PtrInt);
    function StateToStr(State: TTransactionState): string;
    function AdviseToStr(Advise: TTransactionAdvise): string;
    function ActionToStr(anAction: TTransactionAction): string;
    procedure RunGFix;
  public
    { public declarations }
  end;

var
  LimboTransactionsForm: TLimboTransactionsForm;

implementation

{$R *.lfm}

uses MainFormUnit;

{ TLimboTransactionsForm }

procedure TLimboTransactionsForm.FormShow(Sender: TObject);
begin
  Application.QueueAsyncCall(@DoRefresh,0);
end;

procedure TLimboTransactionsForm.Button1Click(Sender: TObject);
begin
  LimboTransactionValidation.GlobalAction := CommitGlobal;
  RunGFix;
end;

procedure TLimboTransactionsForm.Button2Click(Sender: TObject);
begin
  LimboTransactionValidation.GlobalAction := RollbackGlobal;
  RunGFix;
end;

procedure TLimboTransactionsForm.Button3Click(Sender: TObject);
begin
  LimboTransactionValidation.GlobalAction := NoGlobalAction;
  RunGFix;
end;

procedure TLimboTransactionsForm.Button4Click(Sender: TObject);
begin
  LimboTransactionValidation.GlobalAction := RecoverTwoPhaseGlobal;
  RunGFix;
end;

procedure TLimboTransactionsForm.FormClose(Sender: TObject;
  var CloseAction: TCloseAction);
begin
end;

procedure TLimboTransactionsForm.StringGrid1EditingDone(Sender: TObject);
begin
  with StringGrid1, LimboTransactionValidation do
  if col = 7 then
  begin
    if Cells[7,row] = 'Commit' then
      LimboTransactionInfo[row-1].Action := CommitAction
    else
      if Cells[7,row] = 'Rollback' then
        LimboTransactionInfo[row-1].Action := RollbackAction
  end;
end;

procedure TLimboTransactionsForm.DoRefresh(Data: PtrInt);
var i: integer;
begin
  with LimboTransactionValidation do
  begin
    Active := true;
    ServiceStart;
    FetchLimboTransactionInfo;
    StringGrid1.RowCount := LimboTransactionInfoCount + 1;
    for i := 0 to LimboTransactionInfoCount - 1 do
    with LimboTransactionInfo[i] do
    begin
      StringGrid1.Cells[0,i+1] := IntToStr(ID);
      if MultiDatabase then
        StringGrid1.Cells[1,i+1] := 'Multi DB'
      else
        StringGrid1.Cells[1,i+1] := 'Single DB';
      StringGrid1.Cells[2,i+1] := HostSite;
      StringGrid1.Cells[3,i+1] := RemoteSite;
      StringGrid1.Cells[4,i+1] := RemoteDatabasePath;
      StringGrid1.Cells[5,i+1] := StateToStr(State);
      StringGrid1.Cells[6,i+1] := AdviseToStr(Advise);
      StringGrid1.Cells[7,i+1] := ActionToStr(Action);
    end;
  end;
end;

function TLimboTransactionsForm.StateToStr(State: TTransactionState): string;
begin
  case State of
  LimboState:
    Result := 'Limbo';
  CommitState:
    Result := 'Commit';
  RollbackState:
    Result := 'Rollback';
  else
    Result := 'Unknown';
  end;
end;

function TLimboTransactionsForm.AdviseToStr(Advise: TTransactionAdvise): string;
begin
  case Advise of
  CommitAdvise:
    Result := 'Commit';
  RollbackAdvise:
    Result := 'Rollback';
  else
    Result := 'Unknown';
  end;
end;

function TLimboTransactionsForm.ActionToStr(anAction: TTransactionAction
  ): string;
begin
  case anAction of
  CommitAction:
    Result := 'Commit';
  RollbackAction:
    Result := 'Rollback';
  end;
end;

procedure TLimboTransactionsForm.RunGFix;
begin
  with LimboTransactionValidation do
  begin
    MainForm.Memo1.Lines.Add('Starting Limbo transaction resolution');
    FixLimboTransactionErrors;
    while not Eof do
    begin
      MainForm.Memo1.Lines.Add(GetNextLine);
      Application.ProcessMessages;
    end;
    MainForm.Memo1.Lines.Add('Limbo Transaction resolution complete');
    Application.QueueAsyncCall(@DoRefresh,0);
  end;
end;

end.

Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	5311 byte(s)
Log Message:	Fixes Merged
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26
27	unit LimboTransactionsUnit;
28
29	{$mode objfpc}{$H+}
30
31	interface
32
33	uses
34	Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
35	Grids, IBServices;
36
37	type
38	{ TLimboTransactionsForm }
39
40	TLimboTransactionsForm = class(TForm)
41	Button1: TButton;
42	Button2: TButton;
43	Button3: TButton;
44	Button4: TButton;
45	LimboTransactionValidation: TIBValidationService;
46	Label1: TLabel;
47	StringGrid1: TStringGrid;
48	procedure Button1Click(Sender: TObject);
49	procedure Button2Click(Sender: TObject);
50	procedure Button3Click(Sender: TObject);
51	procedure Button4Click(Sender: TObject);
52	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
53	procedure FormShow(Sender: TObject);
54	procedure StringGrid1EditingDone(Sender: TObject);
55	private
56	{ private declarations }
57	procedure DoRefresh(Data: PtrInt);
58	function StateToStr(State: TTransactionState): string;
59	function AdviseToStr(Advise: TTransactionAdvise): string;
60	function ActionToStr(anAction: TTransactionAction): string;
61	procedure RunGFix;
62	public
63	{ public declarations }
64	end;
65
66	var
67	LimboTransactionsForm: TLimboTransactionsForm;
68
69	implementation
70
71	{$R *.lfm}
72
73	uses MainFormUnit;
74
75	{ TLimboTransactionsForm }
76
77	procedure TLimboTransactionsForm.FormShow(Sender: TObject);
78	begin
79	Application.QueueAsyncCall(@DoRefresh,0);
80	end;
81
82	procedure TLimboTransactionsForm.Button1Click(Sender: TObject);
83	begin
84	LimboTransactionValidation.GlobalAction := CommitGlobal;
85	RunGFix;
86	end;
87
88	procedure TLimboTransactionsForm.Button2Click(Sender: TObject);
89	begin
90	LimboTransactionValidation.GlobalAction := RollbackGlobal;
91	RunGFix;
92	end;
93
94	procedure TLimboTransactionsForm.Button3Click(Sender: TObject);
95	begin
96	LimboTransactionValidation.GlobalAction := NoGlobalAction;
97	RunGFix;
98	end;
99
100	procedure TLimboTransactionsForm.Button4Click(Sender: TObject);
101	begin
102	LimboTransactionValidation.GlobalAction := RecoverTwoPhaseGlobal;
103	RunGFix;
104	end;
105
106	procedure TLimboTransactionsForm.FormClose(Sender: TObject;
107	var CloseAction: TCloseAction);
108	begin
109	end;
110
111	procedure TLimboTransactionsForm.StringGrid1EditingDone(Sender: TObject);
112	begin
113	with StringGrid1, LimboTransactionValidation do
114	if col = 7 then
115	begin
116	if Cells[7,row] = 'Commit' then
117	LimboTransactionInfo[row-1].Action := CommitAction
118	else
119	if Cells[7,row] = 'Rollback' then
120	LimboTransactionInfo[row-1].Action := RollbackAction
121	end;
122	end;
123
124	procedure TLimboTransactionsForm.DoRefresh(Data: PtrInt);
125	var i: integer;
126	begin
127	with LimboTransactionValidation do
128	begin
129	Active := true;
130	ServiceStart;
131	FetchLimboTransactionInfo;
132	StringGrid1.RowCount := LimboTransactionInfoCount + 1;
133	for i := 0 to LimboTransactionInfoCount - 1 do
134	with LimboTransactionInfo[i] do
135	begin
136	StringGrid1.Cells[0,i+1] := IntToStr(ID);
137	if MultiDatabase then
138	StringGrid1.Cells[1,i+1] := 'Multi DB'
139	else
140	StringGrid1.Cells[1,i+1] := 'Single DB';
141	StringGrid1.Cells[2,i+1] := HostSite;
142	StringGrid1.Cells[3,i+1] := RemoteSite;
143	StringGrid1.Cells[4,i+1] := RemoteDatabasePath;
144	StringGrid1.Cells[5,i+1] := StateToStr(State);
145	StringGrid1.Cells[6,i+1] := AdviseToStr(Advise);
146	StringGrid1.Cells[7,i+1] := ActionToStr(Action);
147	end;
148	end;
149	end;
150
151	function TLimboTransactionsForm.StateToStr(State: TTransactionState): string;
152	begin
153	case State of
154	LimboState:
155	Result := 'Limbo';
156	CommitState:
157	Result := 'Commit';
158	RollbackState:
159	Result := 'Rollback';
160	else
161	Result := 'Unknown';
162	end;
163	end;
164
165	function TLimboTransactionsForm.AdviseToStr(Advise: TTransactionAdvise): string;
166	begin
167	case Advise of
168	CommitAdvise:
169	Result := 'Commit';
170	RollbackAdvise:
171	Result := 'Rollback';
172	else
173	Result := 'Unknown';
174	end;
175	end;
176
177	function TLimboTransactionsForm.ActionToStr(anAction: TTransactionAction
178	): string;
179	begin
180	case anAction of
181	CommitAction:
182	Result := 'Commit';
183	RollbackAction:
184	Result := 'Rollback';
185	end;
186	end;
187
188	procedure TLimboTransactionsForm.RunGFix;
189	begin
190	with LimboTransactionValidation do
191	begin
192	MainForm.Memo1.Lines.Add('Starting Limbo transaction resolution');
193	FixLimboTransactionErrors;
194	while not Eof do
195	begin
196	MainForm.Memo1.Lines.Add(GetNextLine);
197	Application.ProcessMessages;
198	end;
199	MainForm.Memo1.Lines.Add('Limbo Transaction resolution complete');
200	Application.QueueAsyncCall(@DoRefresh,0);
201	end;
202	end;
203
204	end.
205