trunk/testsuite/IBXTestBase.pas

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