ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/testsuite/IBXTestBase.pas
Revision: 380
Committed: Mon Jan 10 10:13:17 2022 UTC (2 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 12990 byte(s)
Log Message:
propset for eol-style

File Contents

# 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     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 tony 319 CheckSynchronize(100);
237 tony 315 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    

Properties

Name Value
svn:eol-style native