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, 1 month ago) by tony
Content type: text/x-pascal
File size: 12033 byte(s)
Log Message:
Merge into public release

File Contents

# Content
1 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 CheckSynchronize(100);
211 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