trunk/testsuite/IBXTestBase.pas

(*
 *  IBX Test suite. This program is used to test the IBX non-visual
 *  components and provides a semi-automated pass/fail check for each test.
 *
 *  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) 2021 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)      
unit IBXTestBase;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, TestApplication, CustApp, DB, IB, IBCustomDataSet, IBDatabase, IBQuery,
  ibxscript, IBDataOutput, IBSQL;

type

{ TIBXTestBase }

TIBXTestBase = class(TTestBase)
private
  FIBDatabase: TIBDatabase;
  FIBTransaction: TIBTransaction;
  FIBQuery: TIBQuery;
  FIBXScript: TIBXScript;
  FInitialising: boolean;
  FScriptFile: AnsiString;
  function GetRoleName: AnsiString;
  function GetScriptFile: AnsiString;
  procedure HandleCreateDatebase(Sender: TObject);
  procedure HandleDBFileName(Sender: TObject; var DatabaseFileName: string);
  procedure LogHandler(Sender: TObject; Msg: string);
  procedure ErrorLogHandler(Sender: TObject; Msg: string);
protected
  procedure ClientLibraryPathChanged; override;
  procedure CreateObjects(Application: TTestApplication); override;
  function GetFullTestID: string;
  function GetOutFile: string;
  function GetSSBackupFile: string;
  procedure InitialiseDatabase(aDatabase: TIBDatabase); virtual;
  procedure PrintDataSet(aDataSet: TDataSet);
  procedure PrintDataSetRow(aDataSet: TDataSet); overload;
  procedure PrintDataSetRow(aField: TField); overload;
  procedure PrintAffectedRows(query: TIBCustomDataSet); overload;
  procedure PrintAffectedRows(query: TIBSQL); overload;
  procedure ReadOnlyTransaction;
  procedure ReadWriteTransaction;
  procedure RunScript(aDatabase: TIBDatabase; aFileName: string);
  procedure ShowStrings(aCaption: string; List: TStrings);
  procedure WriteStrings(List: TStrings; limit: integer=0);
  procedure ExecuteSQL(SQL: string);
  procedure ShowFBVersion(attachment: IAttachment);
  procedure ShowBoolValue(aValue: integer; WhenTrue, WhenFalse: string);
  procedure ProcessResults; override;
public
  destructor Destroy; override;
  property IBDatabase: TIBDatabase read  FIBDatabase;
  property IBTransaction: TIBTransaction read FIBTransaction;
  property IBQuery: TIBQuery read FIBQuery;
  property RoleName: AnsiString read GetRoleName;
  property IBXScriptObj: TIBXScript read FIBXScript;
end;

implementation

uses Process, IBUtils;

const
  sqlScriptTemplate = 'resources/Test%s.sql';
  sqlCustomScriptTemplate = 'resources/Test%s.%d.sql';
  outFileTemplate   = 'Test%s.out';

{ TIBXTestBase }

procedure TIBXTestBase.HandleCreateDatebase(Sender: TObject);
begin
  if not FInitialising then
  begin
    FInitialising := true;
    try
      InitialiseDatabase(IBDatabase);
    finally
      FInitialising := false;
    end;
  end;
end;

function TIBXTestBase.GetRoleName: AnsiString;
begin
  if IBDatabase.Connected then
    Result := IBDatabase.Attachment.OpenCursorAtStart(IBTransaction.TransactionIntf,
                  'Select CURRENT_ROLE From RDB$Database',[])[0].AsString
  else
    Result := '';
end;

function TIBXTestBase.GetScriptFile: AnsiString;
begin
  FScriptFile := '';
  if IBDatabase.Attachment <> nil then
    FScriptFile := Format(sqlCustomScriptTemplate,[GetFullTestID,IBDatabase.Attachment.GetODSMajorVersion]);
  if not FileExists(FScriptFile) then
    FScriptFile := Format(sqlScriptTemplate,[GetFullTestID]);
  Result := FScriptFile;
end;

procedure TIBXTestBase.HandleDBFileName(Sender: TObject;
  var DatabaseFileName: string);
begin
  DatabaseFileName := IBDatabase.DatabaseName;
end;

procedure TIBXTestBase.LogHandler(Sender: TObject; Msg: string);
begin
   writeln(OutFile,Msg);
end;

procedure TIBXTestBase.ErrorLogHandler(Sender: TObject; Msg: string);
begin
  writeln(OutFile,Msg);
end;

procedure TIBXTestBase.ClientLibraryPathChanged;
begin
  inherited ClientLibraryPathChanged;
  FIBDatabase.FirebirdLibraryPathName := Owner.ClientLibraryPath;
end;

procedure TIBXTestBase.CreateObjects(Application: TTestApplication);
begin
  inherited CreateObjects(Application);
  { In console Mode the application should own the database
    - ensures centralised exception handling }
  FIBDatabase := TIBDatabase.Create(Application);
  FIBDatabase.FirebirdLibraryPathName := Owner.ClientLibraryPath;
  FIBDatabase.LoginPrompt := false;
  FIBDatabase.Params.Add('user_name=' + Owner.GetUserName);
  FIBDatabase.Params.Add('password=' + Owner.GetPassword);
  FIBDatabase.Params.Add('lc_ctype=UTF8');
  FIBDatabase.OnCreateDatabase := @HandleCreateDatebase;
  FIBDatabase.Name := 'Test_Database_' + GetTestID;
  FIBTransaction := TIBTransaction.Create(Application);
  FIBTransaction.DefaultDatabase := FIBDatabase;
  FIBDatabase.DefaultTransaction := FIBTransaction;
  FIBTransaction.Name := 'Test_Transaction_' + GetTestID;
  FIBQuery := TIBQuery.Create(Application);
  FIBQuery.Database := FIBDatabase;
  FIBXScript := TIBXScript.Create(Application);
  FIBXScript.Database := FIBDatabase;
  FIBXScript.Transaction := FIBTransaction;
  FIBXScript.OnOutputLog := @LogHandler;
  FIBXScript.OnErrorLog := @ErrorLogHandler;
  FIBXScript.DataOutputFormatter := TIBInsertStmtsOut.Create(Application);
  FIBXScript.OnCreateDatabase := @HandleDBFileName;
  FIBXScript.IgnoreCreateDatabase := FALSE;
end;

function TIBXTestBase.GetFullTestID: string;
begin
  Result := GetTestID;
  if Length(Result) = 1 then
    Result := '0' + Result;
end;

function TIBXTestBase.GetOutFile: string;
begin
  Result := Format(outFileTemplate,[GetFullTestID]);
end;

function TIBXTestBase.GetSSBackupFile: string;
begin
  Result := ChangeFileExt(Owner.GetBackupFileName,'.fbk');
end;

procedure TIBXTestBase.InitialiseDatabase(aDatabase: TIBDatabase);
var aFileName: string;
    {$IFDEF WINDOWS}
    F: text;
    line: AnsiString;
    {$ENDIF}
begin
  aFileName := GetScriptFile;
  if FileExists(aFileName) then
  begin
    writeln(OutFile,'Creating Database from ' + aFileName);
    writeln(OutFile);
    {$IFDEF WINDOWS}
    assignfile(F,aFileName);
    try
      Reset(F);
      readln(F,line);
      close(F);
      if Pos('link ',Line) = 1 then
         aFileName := ExtractFilePath(aFileName) + system.copy(Line,6,Length(Line)-5);
    except
      //do nothing
    end;
    {$ENDIF}
    RunScript(aDatabase,aFileName);
  end;
end;

procedure TIBXTestBase.PrintDataSet(aDataSet: TDataSet);
var rowno: integer;
begin
  if aDataSet.Name <> '' then
    writeln(OutFile,'Print Dataset for ',aDataSet.Name);
  aDataSet.First;
  rowno := 1;
  if aDataSet.EOF then
    writeln(OutFile,'Dataset Empty')
  else
  while not aDataSet.EOF do
  begin
    CheckSynchronize(100);
    writeln(OutFile,'Row No = ',rowno);
    PrintDataSetRow(aDataset);
    aDataSet.Next;
    Inc(rowno);
    writeln(OutFile);
  end;
  writeln(Outfile,'Rows printed = ',IntToStr(rowno-1));
  writeln(Outfile);
end;

procedure TIBXTestBase.PrintDataSetRow(aDataSet: TDataSet);
var i: integer;
begin
  for i := 0 to aDataSet.FieldCount - 1 do
    PrintDataSetRow(aDataSet.Fields[i]);
end;

procedure TIBXTestBase.PrintDataSetRow(aField: TField);
var s: AnsiString;
    dt: TDateTime;
begin
  if aField.IsNull then
    writeln(OutFile,aField.FieldName,' = NULL')
  else
  case aField.DataType of
  ftArray:
    begin
      if not aField.IsNull then
        WriteArray(TIBArrayField(aField).ArrayIntf);
    end;

  ftFloat:
    writeln(OutFile, aField.FieldName,' = ',FormatFloat('#,##0.000000000000',aField.AsFloat));

  ftLargeint:
    writeln(OutFile,aField.FieldName,' = ',aField.AsString);

  ftmemo, ftBlob:
    if TBlobField(aField).BlobType = ftMemo then
    begin
      s := aField.AsString;
      if FHexStrings then
      begin
        write(OutFile,aField.FieldName,' = ');
        PrintHexString(s);
        writeln(OutFile,' (Charset = ',TIBMemoField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
      end
      else
      begin
        writeln(OutFile,aField.FieldName,' (Charset  = ',TIBMemoField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
        writeln(OutFile);
        writeln(OutFile,s);
      end
    end
    else
      writeln(OutFile,aField.FieldName,' = (blob), Length = ',TBlobField(aField).BlobSize);

  ftString:
  begin
    s := aField.AsString;
    if FHexStrings then
    begin
      write(OutFile,aField.FieldName,' = ');
      PrintHexString(s);
      writeln(OutFile,' (Charset = ',TIBStringField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
    end
    else
    if (aField is TIBStringField) and (TIBStringField(aField).CharacterSetName <> 'NONE') then
      writeln(OutFile,aField.FieldName,' = ',s,' (Charset = ',TIBStringField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')')
    else
      writeln(OutFile,aField.FieldName,' = ',s);
  end;

  else
    writeln(OutFile,aField.FieldName,' = ',aField.AsString);
  end;
end;

procedure TIBXTestBase.PrintAffectedRows(query: TIBCustomDataSet);
var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
begin
  if query.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount) then
  begin
    writeln(OutFile,'Selects = ',SelectCount);
    writeln(OutFile,'Inserts = ',InsertCount);
    writeln(OutFile,'Updates = ',UpdateCount);
    writeln(OutFile,'Deletes = ',DeleteCount);
  end;
end;

procedure TIBXTestBase.PrintAffectedRows(query: TIBSQL);
var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
begin
  if query.statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount) then
  begin
    writeln(OutFile,'Selects = ',SelectCount);
    writeln(OutFile,'Inserts = ',InsertCount);
    writeln(OutFile,'Updates = ',UpdateCount);
    writeln(OutFile,'Deletes = ',DeleteCount);
  end;
end;

procedure TIBXTestBase.ReadOnlyTransaction;
begin
  FIBTransaction.Params.Clear;
  FIBTransaction.Params.Add('concurrency');
  FIBTransaction.Params.Add('wait');
  FIBTransaction.Params.Add('read');
end;


procedure TIBXTestBase.ReadWriteTransaction;
begin
  FIBTransaction.Params.Clear;
  FIBTransaction.Params.Add('concurrency');
  FIBTransaction.Params.Add('wait');
  FIBTransaction.Params.Add('write');
end;

procedure TIBXTestBase.RunScript(aDatabase: TIBDatabase; aFileName: string);
begin
  FIBXScript.Database := aDatabase;
  aDatabase.DefaultTransaction.Active := true;
  FIBXScript.Transaction := aDatabase.DefaultTransaction;
  FIBXScript.RunScript(aFileName);
end;

procedure TIBXTestBase.ShowStrings(aCaption: string; List: TStrings);
var s: string;
    i: integer;
begin
  s := aCaption + ': ';
  for i := 0 to List.Count - 1 do
  begin
    if i > 0 then
      s := s + ', ';
    s := s + List[i];
  end;
 writeln(OutFile,s);
end;

procedure TIBXTestBase.WriteStrings(List: TStrings; limit: integer);
var i: integer;
begin
 if Limit <= 0 then
   Limit := List.Count - 1;
  for i := 0 to limit do
    writeln(OutFile,List[i]);
  writeln(OutFile);
end;

procedure TIBXTestBase.ExecuteSQL(SQL: string);
begin
  FIBXScript.ExecSQLScript(SQL);
end;

procedure TIBXTestBase.ShowFBVersion(attachment: IAttachment);
var S: TStrings;
begin
  S := TStringList.Create;
  try
    attachment.getFBVersion(S);
    ShowStrings('FB Version',S);
  finally
    S.Free;
  end;
end;

procedure TIBXTestBase.ShowBoolValue(aValue: integer; WhenTrue,
  WhenFalse: string);
begin
 if aValue <> 0 then
   writeln(OutFile,WhenTrue)
 else
   writeln(OutFile,WhenFalse);
end;

procedure TIBXTestBase.ProcessResults;
var DiffExe: string;
    ResourceFile: string;
    S: TStrings;
    Results: string;
    ExitStatus: integer;
begin
   ResourceFile := FScriptFile;
   if FileExists(GetOutFile) and FileExists(ResourceFile) then
   begin
     DiffExe := GetEnvironmentVariable('DIFF');
     if DiffExe = '' then
       DiffExe := 'diff';
     S := TStringList.Create;
     try
       RunCommandInDir(GetCurrentDir,DiffExe ,[ResourceFile,GetOutFile],Results,ExitStatus);
       writeln(OutFile,'Run diff command returns ',ExitStatus);
       if Results <> '' then
       begin
         S.Text := Results;
         writeln(Outfile,'Output from diff command');
         WriteStrings(S);
       end;
     finally
       S.Free;
     end;
   end;
   IBDatabase.Connected := false;
end;

destructor TIBXTestBase.Destroy;
begin
  if IBDatabase <> nil then
    IBDatabase.Connected := false;
  inherited Destroy;
end;

end.

Revision:	323
Committed:	Thu Feb 25 12:14:35 2021 UTC (3 years, 2 months ago) by tony
Content type:	text/x-pascal
File size:	12990 byte(s)
Log Message:	Fixed Merged
#	Content
1	(*
2	* IBX Test suite. This program is used to test the IBX non-visual
3	* components and provides a semi-automated pass/fail check for each test.
4	*
5	* The contents of this file are subject to the Initial Developer's
6	* Public License Version 1.0 (the "License"); you may not use this
7	* file except in compliance with the License. You may obtain a copy
8	* of the License here:
9	*
10	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11	*
12	* Software distributed under the License is distributed on an "AS
13	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14	* implied. See the License for the specific language governing rights
15	* and limitations under the License.
16	*
17	* The Initial Developer of the Original Code is Tony Whyman.
18	*
19	* The Original Code is (C) 2021 Tony Whyman, MWA Software
20	* (http://www.mwasoftware.co.uk).
21	*
22	* All Rights Reserved.
23	*
24	* Contributor(s): ______________________________________.
25	*
26	*)
27	unit IBXTestBase;
28
29	{$mode objfpc}{$H+}
30
31	interface
32
33	uses
34	Classes, SysUtils, TestApplication, CustApp, DB, IB, IBCustomDataSet, IBDatabase, IBQuery,
35	ibxscript, IBDataOutput, IBSQL;
36
37	type
38
39	{ TIBXTestBase }
40
41	TIBXTestBase = class(TTestBase)
42	private
43	FIBDatabase: TIBDatabase;
44	FIBTransaction: TIBTransaction;
45	FIBQuery: TIBQuery;
46	FIBXScript: TIBXScript;
47	FInitialising: boolean;
48	FScriptFile: AnsiString;
49	function GetRoleName: AnsiString;
50	function GetScriptFile: AnsiString;
51	procedure HandleCreateDatebase(Sender: TObject);
52	procedure HandleDBFileName(Sender: TObject; var DatabaseFileName: string);
53	procedure LogHandler(Sender: TObject; Msg: string);
54	procedure ErrorLogHandler(Sender: TObject; Msg: string);
55	protected
56	procedure ClientLibraryPathChanged; override;
57	procedure CreateObjects(Application: TTestApplication); override;
58	function GetFullTestID: string;
59	function GetOutFile: string;
60	function GetSSBackupFile: string;
61	procedure InitialiseDatabase(aDatabase: TIBDatabase); virtual;
62	procedure PrintDataSet(aDataSet: TDataSet);
63	procedure PrintDataSetRow(aDataSet: TDataSet); overload;
64	procedure PrintDataSetRow(aField: TField); overload;
65	procedure PrintAffectedRows(query: TIBCustomDataSet); overload;
66	procedure PrintAffectedRows(query: TIBSQL); overload;
67	procedure ReadOnlyTransaction;
68	procedure ReadWriteTransaction;
69	procedure RunScript(aDatabase: TIBDatabase; aFileName: string);
70	procedure ShowStrings(aCaption: string; List: TStrings);
71	procedure WriteStrings(List: TStrings; limit: integer=0);
72	procedure ExecuteSQL(SQL: string);
73	procedure ShowFBVersion(attachment: IAttachment);
74	procedure ShowBoolValue(aValue: integer; WhenTrue, WhenFalse: string);
75	procedure ProcessResults; override;
76	public
77	destructor Destroy; override;
78	property IBDatabase: TIBDatabase read FIBDatabase;
79	property IBTransaction: TIBTransaction read FIBTransaction;
80	property IBQuery: TIBQuery read FIBQuery;
81	property RoleName: AnsiString read GetRoleName;
82	property IBXScriptObj: TIBXScript read FIBXScript;
83	end;
84
85	implementation
86
87	uses Process, IBUtils;
88
89	const
90	sqlScriptTemplate = 'resources/Test%s.sql';
91	sqlCustomScriptTemplate = 'resources/Test%s.%d.sql';
92	outFileTemplate = 'Test%s.out';
93
94	{ TIBXTestBase }
95
96	procedure TIBXTestBase.HandleCreateDatebase(Sender: TObject);
97	begin
98	if not FInitialising then
99	begin
100	FInitialising := true;
101	try
102	InitialiseDatabase(IBDatabase);
103	finally
104	FInitialising := false;
105	end;
106	end;
107	end;
108
109	function TIBXTestBase.GetRoleName: AnsiString;
110	begin
111	if IBDatabase.Connected then
112	Result := IBDatabase.Attachment.OpenCursorAtStart(IBTransaction.TransactionIntf,
113	'Select CURRENT_ROLE From RDB$Database',[])[0].AsString
114	else
115	Result := '';
116	end;
117
118	function TIBXTestBase.GetScriptFile: AnsiString;
119	begin
120	FScriptFile := '';
121	if IBDatabase.Attachment <> nil then
122	FScriptFile := Format(sqlCustomScriptTemplate,[GetFullTestID,IBDatabase.Attachment.GetODSMajorVersion]);
123	if not FileExists(FScriptFile) then
124	FScriptFile := Format(sqlScriptTemplate,[GetFullTestID]);
125	Result := FScriptFile;
126	end;
127
128	procedure TIBXTestBase.HandleDBFileName(Sender: TObject;
129	var DatabaseFileName: string);
130	begin
131	DatabaseFileName := IBDatabase.DatabaseName;
132	end;
133
134	procedure TIBXTestBase.LogHandler(Sender: TObject; Msg: string);
135	begin
136	writeln(OutFile,Msg);
137	end;
138
139	procedure TIBXTestBase.ErrorLogHandler(Sender: TObject; Msg: string);
140	begin
141	writeln(OutFile,Msg);
142	end;
143
144	procedure TIBXTestBase.ClientLibraryPathChanged;
145	begin
146	inherited ClientLibraryPathChanged;
147	FIBDatabase.FirebirdLibraryPathName := Owner.ClientLibraryPath;
148	end;
149
150	procedure TIBXTestBase.CreateObjects(Application: TTestApplication);
151	begin
152	inherited CreateObjects(Application);
153	{ In console Mode the application should own the database
154	- ensures centralised exception handling }
155	FIBDatabase := TIBDatabase.Create(Application);
156	FIBDatabase.FirebirdLibraryPathName := Owner.ClientLibraryPath;
157	FIBDatabase.LoginPrompt := false;
158	FIBDatabase.Params.Add('user_name=' + Owner.GetUserName);
159	FIBDatabase.Params.Add('password=' + Owner.GetPassword);
160	FIBDatabase.Params.Add('lc_ctype=UTF8');
161	FIBDatabase.OnCreateDatabase := @HandleCreateDatebase;
162	FIBDatabase.Name := 'Test_Database_' + GetTestID;
163	FIBTransaction := TIBTransaction.Create(Application);
164	FIBTransaction.DefaultDatabase := FIBDatabase;
165	FIBDatabase.DefaultTransaction := FIBTransaction;
166	FIBTransaction.Name := 'Test_Transaction_' + GetTestID;
167	FIBQuery := TIBQuery.Create(Application);
168	FIBQuery.Database := FIBDatabase;
169	FIBXScript := TIBXScript.Create(Application);
170	FIBXScript.Database := FIBDatabase;
171	FIBXScript.Transaction := FIBTransaction;
172	FIBXScript.OnOutputLog := @LogHandler;
173	FIBXScript.OnErrorLog := @ErrorLogHandler;
174	FIBXScript.DataOutputFormatter := TIBInsertStmtsOut.Create(Application);
175	FIBXScript.OnCreateDatabase := @HandleDBFileName;
176	FIBXScript.IgnoreCreateDatabase := FALSE;
177	end;
178
179	function TIBXTestBase.GetFullTestID: string;
180	begin
181	Result := GetTestID;
182	if Length(Result) = 1 then
183	Result := '0' + Result;
184	end;
185
186	function TIBXTestBase.GetOutFile: string;
187	begin
188	Result := Format(outFileTemplate,[GetFullTestID]);
189	end;
190
191	function TIBXTestBase.GetSSBackupFile: string;
192	begin
193	Result := ChangeFileExt(Owner.GetBackupFileName,'.fbk');
194	end;
195
196	procedure TIBXTestBase.InitialiseDatabase(aDatabase: TIBDatabase);
197	var aFileName: string;
198	{$IFDEF WINDOWS}
199	F: text;
200	line: AnsiString;
201	{$ENDIF}
202	begin
203	aFileName := GetScriptFile;
204	if FileExists(aFileName) then
205	begin
206	writeln(OutFile,'Creating Database from ' + aFileName);
207	writeln(OutFile);
208	{$IFDEF WINDOWS}
209	assignfile(F,aFileName);
210	try
211	Reset(F);
212	readln(F,line);
213	close(F);
214	if Pos('link ',Line) = 1 then
215	aFileName := ExtractFilePath(aFileName) + system.copy(Line,6,Length(Line)-5);
216	except
217	//do nothing
218	end;
219	{$ENDIF}
220	RunScript(aDatabase,aFileName);
221	end;
222	end;
223
224	procedure TIBXTestBase.PrintDataSet(aDataSet: TDataSet);
225	var rowno: integer;
226	begin
227	if aDataSet.Name <> '' then
228	writeln(OutFile,'Print Dataset for ',aDataSet.Name);
229	aDataSet.First;
230	rowno := 1;
231	if aDataSet.EOF then
232	writeln(OutFile,'Dataset Empty')
233	else
234	while not aDataSet.EOF do
235	begin
236	CheckSynchronize(100);
237	writeln(OutFile,'Row No = ',rowno);
238	PrintDataSetRow(aDataset);
239	aDataSet.Next;
240	Inc(rowno);
241	writeln(OutFile);
242	end;
243	writeln(Outfile,'Rows printed = ',IntToStr(rowno-1));
244	writeln(Outfile);
245	end;
246
247	procedure TIBXTestBase.PrintDataSetRow(aDataSet: TDataSet);
248	var i: integer;
249	begin
250	for i := 0 to aDataSet.FieldCount - 1 do
251	PrintDataSetRow(aDataSet.Fields[i]);
252	end;
253
254	procedure TIBXTestBase.PrintDataSetRow(aField: TField);
255	var s: AnsiString;
256	dt: TDateTime;
257	begin
258	if aField.IsNull then
259	writeln(OutFile,aField.FieldName,' = NULL')
260	else
261	case aField.DataType of
262	ftArray:
263	begin
264	if not aField.IsNull then
265	WriteArray(TIBArrayField(aField).ArrayIntf);
266	end;
267
268	ftFloat:
269	writeln(OutFile, aField.FieldName,' = ',FormatFloat('#,##0.000000000000',aField.AsFloat));
270
271	ftLargeint:
272	writeln(OutFile,aField.FieldName,' = ',aField.AsString);
273
274	ftmemo, ftBlob:
275	if TBlobField(aField).BlobType = ftMemo then
276	begin
277	s := aField.AsString;
278	if FHexStrings then
279	begin
280	write(OutFile,aField.FieldName,' = ');
281	PrintHexString(s);
282	writeln(OutFile,' (Charset = ',TIBMemoField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
283	end
284	else
285	begin
286	writeln(OutFile,aField.FieldName,' (Charset = ',TIBMemoField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
287	writeln(OutFile);
288	writeln(OutFile,s);
289	end
290	end
291	else
292	writeln(OutFile,aField.FieldName,' = (blob), Length = ',TBlobField(aField).BlobSize);
293
294	ftString:
295	begin
296	s := aField.AsString;
297	if FHexStrings then
298	begin
299	write(OutFile,aField.FieldName,' = ');
300	PrintHexString(s);
301	writeln(OutFile,' (Charset = ',TIBStringField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
302	end
303	else
304	if (aField is TIBStringField) and (TIBStringField(aField).CharacterSetName <> 'NONE') then
305	writeln(OutFile,aField.FieldName,' = ',s,' (Charset = ',TIBStringField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')')
306	else
307	writeln(OutFile,aField.FieldName,' = ',s);
308	end;
309
310	else
311	writeln(OutFile,aField.FieldName,' = ',aField.AsString);
312	end;
313	end;
314
315	procedure TIBXTestBase.PrintAffectedRows(query: TIBCustomDataSet);
316	var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
317	begin
318	if query.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount) then
319	begin
320	writeln(OutFile,'Selects = ',SelectCount);
321	writeln(OutFile,'Inserts = ',InsertCount);
322	writeln(OutFile,'Updates = ',UpdateCount);
323	writeln(OutFile,'Deletes = ',DeleteCount);
324	end;
325	end;
326
327	procedure TIBXTestBase.PrintAffectedRows(query: TIBSQL);
328	var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
329	begin
330	if query.statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount) then
331	begin
332	writeln(OutFile,'Selects = ',SelectCount);
333	writeln(OutFile,'Inserts = ',InsertCount);
334	writeln(OutFile,'Updates = ',UpdateCount);
335	writeln(OutFile,'Deletes = ',DeleteCount);
336	end;
337	end;
338
339	procedure TIBXTestBase.ReadOnlyTransaction;
340	begin
341	FIBTransaction.Params.Clear;
342	FIBTransaction.Params.Add('concurrency');
343	FIBTransaction.Params.Add('wait');
344	FIBTransaction.Params.Add('read');
345	end;
346
347
348	procedure TIBXTestBase.ReadWriteTransaction;
349	begin
350	FIBTransaction.Params.Clear;
351	FIBTransaction.Params.Add('concurrency');
352	FIBTransaction.Params.Add('wait');
353	FIBTransaction.Params.Add('write');
354	end;
355
356	procedure TIBXTestBase.RunScript(aDatabase: TIBDatabase; aFileName: string);
357	begin
358	FIBXScript.Database := aDatabase;
359	aDatabase.DefaultTransaction.Active := true;
360	FIBXScript.Transaction := aDatabase.DefaultTransaction;
361	FIBXScript.RunScript(aFileName);
362	end;
363
364	procedure TIBXTestBase.ShowStrings(aCaption: string; List: TStrings);
365	var s: string;
366	i: integer;
367	begin
368	s := aCaption + ': ';
369	for i := 0 to List.Count - 1 do
370	begin
371	if i > 0 then
372	s := s + ', ';
373	s := s + List[i];
374	end;
375	writeln(OutFile,s);
376	end;
377
378	procedure TIBXTestBase.WriteStrings(List: TStrings; limit: integer);
379	var i: integer;
380	begin
381	if Limit <= 0 then
382	Limit := List.Count - 1;
383	for i := 0 to limit do
384	writeln(OutFile,List[i]);
385	writeln(OutFile);
386	end;
387
388	procedure TIBXTestBase.ExecuteSQL(SQL: string);
389	begin
390	FIBXScript.ExecSQLScript(SQL);
391	end;
392
393	procedure TIBXTestBase.ShowFBVersion(attachment: IAttachment);
394	var S: TStrings;
395	begin
396	S := TStringList.Create;
397	try
398	attachment.getFBVersion(S);
399	ShowStrings('FB Version',S);
400	finally
401	S.Free;
402	end;
403	end;
404
405	procedure TIBXTestBase.ShowBoolValue(aValue: integer; WhenTrue,
406	WhenFalse: string);
407	begin
408	if aValue <> 0 then
409	writeln(OutFile,WhenTrue)
410	else
411	writeln(OutFile,WhenFalse);
412	end;
413
414	procedure TIBXTestBase.ProcessResults;
415	var DiffExe: string;
416	ResourceFile: string;
417	S: TStrings;
418	Results: string;
419	ExitStatus: integer;
420	begin
421	ResourceFile := FScriptFile;
422	if FileExists(GetOutFile) and FileExists(ResourceFile) then
423	begin
424	DiffExe := GetEnvironmentVariable('DIFF');
425	if DiffExe = '' then
426	DiffExe := 'diff';
427	S := TStringList.Create;
428	try
429	RunCommandInDir(GetCurrentDir,DiffExe ,[ResourceFile,GetOutFile],Results,ExitStatus);
430	writeln(OutFile,'Run diff command returns ',ExitStatus);
431	if Results <> '' then
432	begin
433	S.Text := Results;
434	writeln(Outfile,'Output from diff command');
435	WriteStrings(S);
436	end;
437	finally
438	S.Free;
439	end;
440	end;
441	IBDatabase.Connected := false;
442	end;
443
444	destructor TIBXTestBase.Destroy;
445	begin
446	if IBDatabase <> nil then
447	IBDatabase.Connected := false;
448	inherited Destroy;
449	end;
450
451	end.
452