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 ListFields(aDataset: TDataSet);
  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;
  procedure CompareFiles(F1, F2: string);
  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.ListFields(aDataset: TDataSet);
var i: integer;
begin
  writeln(OutFile,'Field Names for ',aDataSet.Name);
  for i := 0 to aDataSet.Fields.Count - 1 do
    writeln(OutFile,aDataSet.Fields[i].FieldName);
  writeln(OutFile);
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
  if aDataset.IsEmpty then
    writeln(Outfile,'Dataset is empty!')
  else
  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;
begin
   CompareFiles(FScriptFile,GetOutFile);
   IBDatabase.Connected := false;
end;

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

procedure TIBXTestBase.CompareFiles(F1, F2: string);
var DiffExe: string;
    Results: string;
    S: TStringList;
    ExitStatus: integer;
begin
  if FileExists(F1) and FileExists(F2) then
  begin
    DiffExe := GetEnvironmentVariable('DIFF');
    if DiffExe = '' then
      DiffExe := 'diff';
    S := TStringList.Create;
    try
      RunCommandInDir(GetCurrentDir,DiffExe ,[F1,F2],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;
end;

end.

Revision:	410
Committed:	Thu Jun 22 13:52:39 2023 UTC (16 months, 3 weeks ago) by tony
Content type:	text/x-pascal
File size:	13399 byte(s)
Log Message:	Release 2.6.0 beta
#	User	Rev	Content
1	tony	323	(*
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	tony	315	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	tony	402	procedure ListFields(aDataset: TDataSet);
63	tony	315	procedure PrintDataSet(aDataSet: TDataSet);
64			procedure PrintDataSetRow(aDataSet: TDataSet); overload;
65			procedure PrintDataSetRow(aField: TField); overload;
66			procedure PrintAffectedRows(query: TIBCustomDataSet); overload;
67			procedure PrintAffectedRows(query: TIBSQL); overload;
68			procedure ReadOnlyTransaction;
69			procedure ReadWriteTransaction;
70			procedure RunScript(aDatabase: TIBDatabase; aFileName: string);
71			procedure ShowStrings(aCaption: string; List: TStrings);
72			procedure WriteStrings(List: TStrings; limit: integer=0);
73			procedure ExecuteSQL(SQL: string);
74			procedure ShowFBVersion(attachment: IAttachment);
75			procedure ShowBoolValue(aValue: integer; WhenTrue, WhenFalse: string);
76			procedure ProcessResults; override;
77			public
78			destructor Destroy; override;
79	tony	402	procedure CompareFiles(F1, F2: string);
80	tony	315	property IBDatabase: TIBDatabase read FIBDatabase;
81			property IBTransaction: TIBTransaction read FIBTransaction;
82			property IBQuery: TIBQuery read FIBQuery;
83			property RoleName: AnsiString read GetRoleName;
84			property IBXScriptObj: TIBXScript read FIBXScript;
85			end;
86
87			implementation
88
89			uses Process, IBUtils;
90
91			const
92			sqlScriptTemplate = 'resources/Test%s.sql';
93			sqlCustomScriptTemplate = 'resources/Test%s.%d.sql';
94			outFileTemplate = 'Test%s.out';
95
96			{ TIBXTestBase }
97
98			procedure TIBXTestBase.HandleCreateDatebase(Sender: TObject);
99			begin
100			if not FInitialising then
101			begin
102			FInitialising := true;
103			try
104			InitialiseDatabase(IBDatabase);
105			finally
106			FInitialising := false;
107			end;
108			end;
109			end;
110
111			function TIBXTestBase.GetRoleName: AnsiString;
112			begin
113			if IBDatabase.Connected then
114			Result := IBDatabase.Attachment.OpenCursorAtStart(IBTransaction.TransactionIntf,
115			'Select CURRENT_ROLE From RDB$Database',[])[0].AsString
116			else
117			Result := '';
118			end;
119
120			function TIBXTestBase.GetScriptFile: AnsiString;
121			begin
122			FScriptFile := '';
123			if IBDatabase.Attachment <> nil then
124			FScriptFile := Format(sqlCustomScriptTemplate,[GetFullTestID,IBDatabase.Attachment.GetODSMajorVersion]);
125			if not FileExists(FScriptFile) then
126			FScriptFile := Format(sqlScriptTemplate,[GetFullTestID]);
127			Result := FScriptFile;
128			end;
129
130			procedure TIBXTestBase.HandleDBFileName(Sender: TObject;
131			var DatabaseFileName: string);
132			begin
133			DatabaseFileName := IBDatabase.DatabaseName;
134			end;
135
136			procedure TIBXTestBase.LogHandler(Sender: TObject; Msg: string);
137			begin
138			writeln(OutFile,Msg);
139			end;
140
141			procedure TIBXTestBase.ErrorLogHandler(Sender: TObject; Msg: string);
142			begin
143			writeln(OutFile,Msg);
144			end;
145
146			procedure TIBXTestBase.ClientLibraryPathChanged;
147			begin
148			inherited ClientLibraryPathChanged;
149			FIBDatabase.FirebirdLibraryPathName := Owner.ClientLibraryPath;
150			end;
151
152			procedure TIBXTestBase.CreateObjects(Application: TTestApplication);
153			begin
154			inherited CreateObjects(Application);
155			{ In console Mode the application should own the database
156			- ensures centralised exception handling }
157			FIBDatabase := TIBDatabase.Create(Application);
158			FIBDatabase.FirebirdLibraryPathName := Owner.ClientLibraryPath;
159			FIBDatabase.LoginPrompt := false;
160			FIBDatabase.Params.Add('user_name=' + Owner.GetUserName);
161			FIBDatabase.Params.Add('password=' + Owner.GetPassword);
162			FIBDatabase.Params.Add('lc_ctype=UTF8');
163			FIBDatabase.OnCreateDatabase := @HandleCreateDatebase;
164			FIBDatabase.Name := 'Test_Database_' + GetTestID;
165			FIBTransaction := TIBTransaction.Create(Application);
166			FIBTransaction.DefaultDatabase := FIBDatabase;
167			FIBDatabase.DefaultTransaction := FIBTransaction;
168			FIBTransaction.Name := 'Test_Transaction_' + GetTestID;
169			FIBQuery := TIBQuery.Create(Application);
170			FIBQuery.Database := FIBDatabase;
171			FIBXScript := TIBXScript.Create(Application);
172			FIBXScript.Database := FIBDatabase;
173			FIBXScript.Transaction := FIBTransaction;
174			FIBXScript.OnOutputLog := @LogHandler;
175			FIBXScript.OnErrorLog := @ErrorLogHandler;
176			FIBXScript.DataOutputFormatter := TIBInsertStmtsOut.Create(Application);
177			FIBXScript.OnCreateDatabase := @HandleDBFileName;
178			FIBXScript.IgnoreCreateDatabase := FALSE;
179			end;
180
181			function TIBXTestBase.GetFullTestID: string;
182			begin
183			Result := GetTestID;
184			if Length(Result) = 1 then
185			Result := '0' + Result;
186			end;
187
188			function TIBXTestBase.GetOutFile: string;
189			begin
190			Result := Format(outFileTemplate,[GetFullTestID]);
191			end;
192
193			function TIBXTestBase.GetSSBackupFile: string;
194			begin
195			Result := ChangeFileExt(Owner.GetBackupFileName,'.fbk');
196			end;
197
198			procedure TIBXTestBase.InitialiseDatabase(aDatabase: TIBDatabase);
199			var aFileName: string;
200			{$IFDEF WINDOWS}
201			F: text;
202			line: AnsiString;
203			{$ENDIF}
204			begin
205			aFileName := GetScriptFile;
206			if FileExists(aFileName) then
207			begin
208			writeln(OutFile,'Creating Database from ' + aFileName);
209			writeln(OutFile);
210			{$IFDEF WINDOWS}
211			assignfile(F,aFileName);
212			try
213			Reset(F);
214			readln(F,line);
215			close(F);
216			if Pos('link ',Line) = 1 then
217			aFileName := ExtractFilePath(aFileName) + system.copy(Line,6,Length(Line)-5);
218			except
219			//do nothing
220			end;
221			{$ENDIF}
222			RunScript(aDatabase,aFileName);
223			end;
224			end;
225
226	tony	402	procedure TIBXTestBase.ListFields(aDataset: TDataSet);
227			var i: integer;
228			begin
229			writeln(OutFile,'Field Names for ',aDataSet.Name);
230			for i := 0 to aDataSet.Fields.Count - 1 do
231			writeln(OutFile,aDataSet.Fields[i].FieldName);
232			writeln(OutFile);
233			end;
234
235	tony	315	procedure TIBXTestBase.PrintDataSet(aDataSet: TDataSet);
236			var rowno: integer;
237			begin
238			if aDataSet.Name <> '' then
239			writeln(OutFile,'Print Dataset for ',aDataSet.Name);
240			aDataSet.First;
241			rowno := 1;
242			if aDataSet.EOF then
243			writeln(OutFile,'Dataset Empty')
244			else
245			while not aDataSet.EOF do
246			begin
247	tony	319	CheckSynchronize(100);
248	tony	315	writeln(OutFile,'Row No = ',rowno);
249			PrintDataSetRow(aDataset);
250			aDataSet.Next;
251			Inc(rowno);
252			writeln(OutFile);
253			end;
254			writeln(Outfile,'Rows printed = ',IntToStr(rowno-1));
255			writeln(Outfile);
256			end;
257
258			procedure TIBXTestBase.PrintDataSetRow(aDataSet: TDataSet);
259			var i: integer;
260			begin
261	tony	410	if aDataset.IsEmpty then
262			writeln(Outfile,'Dataset is empty!')
263			else
264	tony	315	for i := 0 to aDataSet.FieldCount - 1 do
265			PrintDataSetRow(aDataSet.Fields[i]);
266			end;
267
268			procedure TIBXTestBase.PrintDataSetRow(aField: TField);
269			var s: AnsiString;
270			dt: TDateTime;
271			begin
272			if aField.IsNull then
273			writeln(OutFile,aField.FieldName,' = NULL')
274			else
275			case aField.DataType of
276			ftArray:
277			begin
278			if not aField.IsNull then
279			WriteArray(TIBArrayField(aField).ArrayIntf);
280			end;
281
282			ftFloat:
283			writeln(OutFile, aField.FieldName,' = ',FormatFloat('#,##0.000000000000',aField.AsFloat));
284
285			ftLargeint:
286			writeln(OutFile,aField.FieldName,' = ',aField.AsString);
287
288			ftmemo, ftBlob:
289			if TBlobField(aField).BlobType = ftMemo then
290			begin
291			s := aField.AsString;
292			if FHexStrings then
293			begin
294			write(OutFile,aField.FieldName,' = ');
295			PrintHexString(s);
296			writeln(OutFile,' (Charset = ',TIBMemoField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
297			end
298			else
299			begin
300			writeln(OutFile,aField.FieldName,' (Charset = ',TIBMemoField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
301			writeln(OutFile);
302			writeln(OutFile,s);
303			end
304			end
305			else
306			writeln(OutFile,aField.FieldName,' = (blob), Length = ',TBlobField(aField).BlobSize);
307
308			ftString:
309			begin
310			s := aField.AsString;
311			if FHexStrings then
312			begin
313			write(OutFile,aField.FieldName,' = ');
314			PrintHexString(s);
315			writeln(OutFile,' (Charset = ',TIBStringField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')');
316			end
317			else
318			if (aField is TIBStringField) and (TIBStringField(aField).CharacterSetName <> 'NONE') then
319			writeln(OutFile,aField.FieldName,' = ',s,' (Charset = ',TIBStringField(aField).CharacterSetName, ' Codepage = ',StringCodePage(s),')')
320			else
321			writeln(OutFile,aField.FieldName,' = ',s);
322			end;
323
324			else
325			writeln(OutFile,aField.FieldName,' = ',aField.AsString);
326			end;
327			end;
328
329			procedure TIBXTestBase.PrintAffectedRows(query: TIBCustomDataSet);
330			var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
331			begin
332			if query.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount) then
333			begin
334			writeln(OutFile,'Selects = ',SelectCount);
335			writeln(OutFile,'Inserts = ',InsertCount);
336			writeln(OutFile,'Updates = ',UpdateCount);
337			writeln(OutFile,'Deletes = ',DeleteCount);
338			end;
339			end;
340
341			procedure TIBXTestBase.PrintAffectedRows(query: TIBSQL);
342			var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
343			begin
344			if query.statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount) then
345			begin
346			writeln(OutFile,'Selects = ',SelectCount);
347			writeln(OutFile,'Inserts = ',InsertCount);
348			writeln(OutFile,'Updates = ',UpdateCount);
349			writeln(OutFile,'Deletes = ',DeleteCount);
350			end;
351			end;
352
353			procedure TIBXTestBase.ReadOnlyTransaction;
354			begin
355			FIBTransaction.Params.Clear;
356			FIBTransaction.Params.Add('concurrency');
357			FIBTransaction.Params.Add('wait');
358			FIBTransaction.Params.Add('read');
359			end;
360
361
362			procedure TIBXTestBase.ReadWriteTransaction;
363			begin
364			FIBTransaction.Params.Clear;
365			FIBTransaction.Params.Add('concurrency');
366			FIBTransaction.Params.Add('wait');
367			FIBTransaction.Params.Add('write');
368			end;
369
370			procedure TIBXTestBase.RunScript(aDatabase: TIBDatabase; aFileName: string);
371			begin
372			FIBXScript.Database := aDatabase;
373			aDatabase.DefaultTransaction.Active := true;
374			FIBXScript.Transaction := aDatabase.DefaultTransaction;
375			FIBXScript.RunScript(aFileName);
376			end;
377
378			procedure TIBXTestBase.ShowStrings(aCaption: string; List: TStrings);
379			var s: string;
380			i: integer;
381			begin
382			s := aCaption + ': ';
383			for i := 0 to List.Count - 1 do
384			begin
385			if i > 0 then
386			s := s + ', ';
387			s := s + List[i];
388			end;
389			writeln(OutFile,s);
390			end;
391
392			procedure TIBXTestBase.WriteStrings(List: TStrings; limit: integer);
393			var i: integer;
394			begin
395			if Limit <= 0 then
396			Limit := List.Count - 1;
397			for i := 0 to limit do
398			writeln(OutFile,List[i]);
399			writeln(OutFile);
400			end;
401
402			procedure TIBXTestBase.ExecuteSQL(SQL: string);
403			begin
404			FIBXScript.ExecSQLScript(SQL);
405			end;
406
407			procedure TIBXTestBase.ShowFBVersion(attachment: IAttachment);
408			var S: TStrings;
409			begin
410			S := TStringList.Create;
411			try
412			attachment.getFBVersion(S);
413			ShowStrings('FB Version',S);
414			finally
415			S.Free;
416			end;
417			end;
418
419			procedure TIBXTestBase.ShowBoolValue(aValue: integer; WhenTrue,
420			WhenFalse: string);
421			begin
422			if aValue <> 0 then
423			writeln(OutFile,WhenTrue)
424			else
425			writeln(OutFile,WhenFalse);
426			end;
427
428			procedure TIBXTestBase.ProcessResults;
429			begin
430	tony	402	CompareFiles(FScriptFile,GetOutFile);
431	tony	315	IBDatabase.Connected := false;
432			end;
433
434			destructor TIBXTestBase.Destroy;
435			begin
436			if IBDatabase <> nil then
437			IBDatabase.Connected := false;
438			inherited Destroy;
439			end;
440
441	tony	402	procedure TIBXTestBase.CompareFiles(F1, F2: string);
442			var DiffExe: string;
443			Results: string;
444			S: TStringList;
445			ExitStatus: integer;
446			begin
447			if FileExists(F1) and FileExists(F2) then
448			begin
449			DiffExe := GetEnvironmentVariable('DIFF');
450			if DiffExe = '' then
451			DiffExe := 'diff';
452			S := TStringList.Create;
453			try
454			RunCommandInDir(GetCurrentDir,DiffExe ,[F1,F2],Results,ExitStatus);
455			writeln(OutFile,'Run diff command returns ',ExitStatus);
456			if Results <> '' then
457			begin
458			S.Text := Results;
459			writeln(Outfile,'Output from diff command');
460			WriteStrings(S);
461			end;
462			finally
463			S.Free;
464			end;
465			end;
466			end;
467
468	tony	315	end.
469