ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/testsuite/IBXTestBase.pas
Revision: 319
Committed: Thu Feb 25 12:05:40 2021 UTC (3 years, 9 months ago) by tony
Content type: text/x-pascal
File size: 12033 byte(s)
Log Message:
Merge into public release

File Contents

# 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