1 |
(*
|
2 |
* MWA Software Test suite. This unit provides common
|
3 |
* code for all Firebird Database tests.
|
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) 2016-2020 Tony Whyman, MWA Software
|
20 |
* (http://www.mwasoftware.co.uk).
|
21 |
*
|
22 |
* All Rights Reserved.
|
23 |
*
|
24 |
* Contributor(s): ______________________________________.
|
25 |
*
|
26 |
*)
|
27 |
unit TestApplication;
|
28 |
{$IFDEF MSWINDOWS}
|
29 |
{$DEFINE WINDOWS}
|
30 |
{$ENDIF}
|
31 |
|
32 |
{$IFDEF FPC}
|
33 |
{$mode delphi}
|
34 |
{$codepage utf8}
|
35 |
{$ENDIF}
|
36 |
|
37 |
{$IF not defined (DCC) and not defined (FPC)}
|
38 |
{$DEFINE DCC}
|
39 |
{$IFEND}
|
40 |
|
41 |
interface
|
42 |
|
43 |
uses
|
44 |
Classes, SysUtils, {$IFDEF FPC}CustApp,{$ENDIF} Firebird, IB, IBUtils, FmtBCD, FBClientLib;
|
45 |
|
46 |
{$IF not defined(LineEnding)}
|
47 |
const
|
48 |
{$IFDEF WINDOWS}
|
49 |
LineEnding = #$0D#$0A;
|
50 |
{$ELSE}
|
51 |
LineEnding = #$0A;
|
52 |
{$ENDIF}
|
53 |
{$IFEND}
|
54 |
|
55 |
const
|
56 |
Copyright = 'Copyright MWA Software 2016-2021';
|
57 |
|
58 |
type
|
59 |
{$IFDEF DCC}
|
60 |
TCustomApplication = class(TComponent)
|
61 |
private
|
62 |
FTitle: string;
|
63 |
protected
|
64 |
procedure DoRun; virtual; abstract;
|
65 |
public
|
66 |
function Exename: string;
|
67 |
procedure Run;
|
68 |
procedure Terminate;
|
69 |
property Title: string read FTitle write FTitle;
|
70 |
end;
|
71 |
{$ENDIF}
|
72 |
|
73 |
TTestApplication = class;
|
74 |
|
75 |
{ TTestBase }
|
76 |
|
77 |
TTestBase = class
|
78 |
private
|
79 |
FOwner: TTestApplication;
|
80 |
FFloatTpl: AnsiString;
|
81 |
FCursorSeq: integer;
|
82 |
function GetFirebirdAPI: IFirebirdAPI;
|
83 |
procedure SetOwner(AOwner: TTestApplication);
|
84 |
protected
|
85 |
FHexStrings: boolean;
|
86 |
FShowBinaryBlob: boolean;
|
87 |
procedure DumpBCD(bcd: tBCD);
|
88 |
procedure ClientLibraryPathChanged; virtual;
|
89 |
procedure CreateObjects(Application: TTestApplication); virtual;
|
90 |
function ExtractDBName(ConnectString: AnsiString): AnsiString;
|
91 |
function GetTestID: AnsiString; virtual; abstract;
|
92 |
function GetTestTitle: AnsiString; virtual; abstract;
|
93 |
procedure PrintHexString(s: AnsiString);
|
94 |
procedure PrintDPB(DPB: IDPB);
|
95 |
procedure PrintTPB(TPB: ITPB);
|
96 |
procedure PrintSPB(SPB: ISPB);
|
97 |
procedure PrintMetaData(meta: IMetaData);
|
98 |
procedure ParamInfo(SQLParams: ISQLParams);
|
99 |
function ReportResults(Statement: IStatement; ShowCursorName: boolean=false): IResultSet;
|
100 |
procedure ReportResult(aValue: IResults);
|
101 |
function StringToHex(octetString: string; MaxLineLength: integer=0): string;
|
102 |
procedure WriteArray(ar: IArray);
|
103 |
procedure WriteAffectedRows(Statement: IStatement);
|
104 |
procedure WriteDBInfo(DBInfo: IDBInformation);
|
105 |
procedure WriteBytes(Bytes: TByteArray);
|
106 |
procedure WriteOperationCounts(Category: AnsiString; ops: TDBOperationCounts);
|
107 |
procedure WritePerfStats(stats: TPerfCounters);
|
108 |
procedure WriteSQLData(aValue: ISQLData);
|
109 |
procedure CheckActivity(Attachment: IAttachment); overload;
|
110 |
procedure CheckActivity(Transaction: ITransaction); overload;
|
111 |
procedure InitTest; virtual;
|
112 |
function SkipTest: boolean; virtual;
|
113 |
procedure ProcessResults; virtual;
|
114 |
procedure SetFloatTemplate(tpl: Ansistring);
|
115 |
public
|
116 |
constructor Create(aOwner: TTestApplication); virtual;
|
117 |
function ChildProcess: boolean; virtual;
|
118 |
function TestTitle: AnsiString; virtual;
|
119 |
property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI;
|
120 |
procedure RunTest(CharSet: AnsiString; SQLDialect: integer); virtual; abstract;
|
121 |
property Owner: TTestApplication read FOwner;
|
122 |
property TestID: AnsiString read GetTestID;
|
123 |
end;
|
124 |
|
125 |
TTest = class of TTestBase;
|
126 |
|
127 |
{ TTestApplication }
|
128 |
|
129 |
TTestApplication = class(TCustomApplication)
|
130 |
private
|
131 |
class var FTests: TStringList;
|
132 |
private
|
133 |
class procedure CreateTestList;
|
134 |
class procedure DestroyTestList;
|
135 |
private
|
136 |
FClientLibraryPath: string;
|
137 |
FServer: AnsiString;
|
138 |
FEmployeeDatabaseName: AnsiString;
|
139 |
FNewDatabaseName: AnsiString;
|
140 |
FSecondNewDatabaseName: AnsiString;
|
141 |
FTestOption: AnsiString;
|
142 |
FUserName: AnsiString;
|
143 |
FPassword: AnsiString;
|
144 |
FBackupFileName: AnsiString;
|
145 |
FShowStatistics: boolean;
|
146 |
FFirebirdAPI: IFirebirdAPI;
|
147 |
FPortNo: AnsiString;
|
148 |
FCreateObjectsDone: boolean;
|
149 |
FQuiet: boolean;
|
150 |
procedure CleanUp;
|
151 |
function GetFirebirdAPI: IFirebirdAPI;
|
152 |
function GetIndexByTestID(aTestID: AnsiString): integer;
|
153 |
procedure SetClientLibraryPath(aLibName: string);
|
154 |
procedure SetUserName(aValue: AnsiString);
|
155 |
procedure SetPassword(aValue: AnsiString);
|
156 |
procedure SetEmployeeDatabaseName(aValue: AnsiString);
|
157 |
procedure SetNewDatabaseName(aValue: AnsiString);
|
158 |
procedure SetSecondNewDatabaseName(aValue: AnsiString);
|
159 |
procedure SetBackupFileName(aValue: AnsiString);
|
160 |
procedure SetServerName(AValue: AnsiString);
|
161 |
procedure SetPortNum(aValue: AnsiString);
|
162 |
procedure SetTestOption(aValue: AnsiString);
|
163 |
protected
|
164 |
{$IFDEF FPC}
|
165 |
function GetShortOptions: AnsiString; virtual;
|
166 |
function GetLongOptions: AnsiString; virtual;
|
167 |
{$ENDIF}
|
168 |
procedure GetParams(var DoPrompt: boolean; var TestID: string); virtual;
|
169 |
procedure DoRun; override;
|
170 |
procedure DoTest(index: integer);
|
171 |
procedure SetFormatSettings; virtual;
|
172 |
procedure WriteHelp; virtual;
|
173 |
public
|
174 |
constructor Create(AOwner: TComponent); override;
|
175 |
destructor Destroy; override;
|
176 |
function GetUserName: AnsiString;
|
177 |
function GetPassword: AnsiString;
|
178 |
function GetEmployeeDatabaseName: AnsiString;
|
179 |
function GetNewDatabaseName: AnsiString;
|
180 |
function GetTempDatabaseName: AnsiString;
|
181 |
function GetSecondNewDatabaseName: AnsiString;
|
182 |
function GetBackupFileName: AnsiString;
|
183 |
procedure RunAll;
|
184 |
procedure RunTest(TestID: AnsiString);
|
185 |
property ShowStatistics: boolean read FShowStatistics write FShowStatistics;
|
186 |
property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI;
|
187 |
property Server: AnsiString read FServer;
|
188 |
property PortNo: AnsiString read FPortNo;
|
189 |
property ClientLibraryPath: string read FClientLibraryPath;
|
190 |
property TestOption: AnsiString read FTestOption write SetTestOption;
|
191 |
property Quiet: boolean read FQuiet;
|
192 |
end;
|
193 |
|
194 |
{ TMsgHash }
|
195 |
|
196 |
TMsgHash = class
|
197 |
private
|
198 |
FFinalised: boolean;
|
199 |
protected
|
200 |
procedure CheckNotFinalised;
|
201 |
public
|
202 |
procedure AddText(aText: AnsiString); virtual; abstract;
|
203 |
procedure Finalise; virtual;
|
204 |
function SameHash(otherHash: TMsgHash): boolean;
|
205 |
function Digest: AnsiString; virtual; abstract;
|
206 |
class function CreateMsgHash: TMsgHash;
|
207 |
property Finalised: boolean read FFinalised;
|
208 |
end;
|
209 |
|
210 |
ESkipException = class(Exception);
|
211 |
|
212 |
var
|
213 |
TestApp: TTestApplication = nil;
|
214 |
|
215 |
var OutFile: text;
|
216 |
|
217 |
procedure RegisterTest(aTest: TTest);
|
218 |
|
219 |
implementation
|
220 |
|
221 |
{$IFNDEF MSWINDOWS}
|
222 |
uses MD5;
|
223 |
{$ENDIF}
|
224 |
|
225 |
{$IFDEF MSWINDOWS}
|
226 |
uses {$IFDEF FPC}MD5,{$ENDIF} windows;
|
227 |
|
228 |
function GetTempDir: AnsiString;
|
229 |
var
|
230 |
tempFolder: array[0..MAX_PATH] of Char;
|
231 |
begin
|
232 |
GetTempPath(MAX_PATH, @tempFolder);
|
233 |
result := StrPas(tempFolder);
|
234 |
end;
|
235 |
{$ENDIF}
|
236 |
|
237 |
procedure RegisterTest(aTest: TTest);
|
238 |
var test: TTestBase;
|
239 |
begin
|
240 |
TTestApplication.CreateTestList;
|
241 |
test := aTest.Create(TestApp);
|
242 |
TTestApplication.FTests.AddObject(test.GetTestID,test);
|
243 |
// if TestApp <> nil then
|
244 |
// test.CreateObjects(TestApp);
|
245 |
end;
|
246 |
|
247 |
{$IFDEF FPC}
|
248 |
type
|
249 |
|
250 |
{ TMD5MsgHash }
|
251 |
|
252 |
TMD5MsgHash = class(TMsgHash)
|
253 |
private
|
254 |
FMD5Context: TMDContext;
|
255 |
FDigest: TMDDigest;
|
256 |
public
|
257 |
constructor Create;
|
258 |
procedure AddText(aText: AnsiString); override;
|
259 |
procedure Finalise; override;
|
260 |
function Digest: AnsiString; override;
|
261 |
end;
|
262 |
|
263 |
{$DEFINE MSG_HASH_AVAILABLE}
|
264 |
|
265 |
{ TMD5MsgHash }
|
266 |
|
267 |
constructor TMD5MsgHash.Create;
|
268 |
begin
|
269 |
inherited Create;
|
270 |
MDInit(FMD5Context,MD_VERSION_5);
|
271 |
end;
|
272 |
|
273 |
procedure TMD5MsgHash.AddText(aText: AnsiString);
|
274 |
begin
|
275 |
CheckNotFinalised;
|
276 |
MDUpdate(FMD5Context,PAnsiChar(aText)^,Length(aText));
|
277 |
end;
|
278 |
|
279 |
procedure TMD5MsgHash.Finalise;
|
280 |
begin
|
281 |
CheckNotFinalised;
|
282 |
MDFinal(FMD5Context,FDigest);
|
283 |
inherited Finalise;
|
284 |
end;
|
285 |
|
286 |
function TMD5MsgHash.Digest: AnsiString;
|
287 |
begin
|
288 |
if not FFinalised then
|
289 |
Finalise;
|
290 |
Result := MD5Print(FDigest);
|
291 |
end;
|
292 |
|
293 |
class function TMsgHash.CreateMsgHash: TMsgHash;
|
294 |
begin
|
295 |
Result := TMD5MsgHash.Create;
|
296 |
end;
|
297 |
{$ENDIF}
|
298 |
|
299 |
{$IFNDEF MSG_HASH_AVAILABLE}
|
300 |
type
|
301 |
|
302 |
{ TSimpleMsgHash }
|
303 |
|
304 |
TSimpleMsgHash = class(TMsgHash)
|
305 |
private
|
306 |
FDigest: Int64;
|
307 |
Finalised: boolean;
|
308 |
public
|
309 |
procedure AddText(aText: AnsiString); override;
|
310 |
function Digest: AnsiString; override;
|
311 |
end;
|
312 |
|
313 |
{ TSimpleMsgHash }
|
314 |
|
315 |
procedure TSimpleMsgHash.AddText(aText: AnsiString);
|
316 |
const
|
317 |
modulus = high(Int64) div 100;
|
318 |
var i: integer;
|
319 |
begin
|
320 |
CheckNotFinalised;
|
321 |
for i := 1 to length(aText) do
|
322 |
FDigest := (FDigest * 7 + ord(aText[i])) mod modulus;
|
323 |
end;
|
324 |
|
325 |
function TSimpleMsgHash.Digest: AnsiString;
|
326 |
begin
|
327 |
if not Finalised then
|
328 |
Finalise;
|
329 |
Result := IntToStr(FDigest);
|
330 |
end;
|
331 |
|
332 |
class function TMsgHash.CreateMsgHash: TMsgHash;
|
333 |
begin
|
334 |
Result := TSimpleMsgHash.Create;
|
335 |
end;
|
336 |
|
337 |
{$ENDIF}
|
338 |
|
339 |
procedure TMsgHash.CheckNotFinalised;
|
340 |
begin
|
341 |
if FFinalised then
|
342 |
raise Exception.Create('Digest has been finalised');
|
343 |
end;
|
344 |
|
345 |
procedure TMsgHash.Finalise;
|
346 |
begin
|
347 |
FFinalised := true;
|
348 |
end;
|
349 |
|
350 |
function TMsgHash.SameHash(otherHash: TMsgHash): boolean;
|
351 |
begin
|
352 |
Result := Digest = OtherHash.Digest;
|
353 |
end;
|
354 |
|
355 |
{ TTestBase }
|
356 |
|
357 |
constructor TTestBase.Create(aOwner: TTestApplication);
|
358 |
begin
|
359 |
inherited Create;
|
360 |
FOwner := aOwner;
|
361 |
FFloatTpl := '#,###.00';
|
362 |
end;
|
363 |
|
364 |
function TTestBase.ChildProcess: boolean;
|
365 |
begin
|
366 |
Result := false;
|
367 |
end;
|
368 |
|
369 |
function TTestBase.TestTitle: AnsiString;
|
370 |
begin
|
371 |
Result := 'Test ' + GetTestID + ': ' + GetTestTitle;
|
372 |
end;
|
373 |
|
374 |
function TTestBase.GetFirebirdAPI: IFirebirdAPI;
|
375 |
begin
|
376 |
Result := FOwner.FirebirdAPI;
|
377 |
end;
|
378 |
|
379 |
procedure TTestBase.SetOwner(AOwner: TTestApplication);
|
380 |
begin
|
381 |
FOwner := AOwner;
|
382 |
end;
|
383 |
|
384 |
procedure TTestBase.DumpBCD(bcd: tBCD);
|
385 |
var i,l: integer;
|
386 |
begin
|
387 |
with bcd do
|
388 |
begin
|
389 |
writeln(OutFile,' Precision = ',bcd.Precision);
|
390 |
writeln(OutFile,' Sign = ',(SignSpecialPlaces and $80) shr 7);
|
391 |
writeln(OutFile,' Special = ', (SignSpecialPlaces and $40) shl 6);
|
392 |
writeln(OutFile,' Places = ', SignSpecialPlaces and $7F);
|
393 |
write(OutFile,' Digits = ');
|
394 |
l := Precision div 2;
|
395 |
if not odd(Precision) then l := l - 1;
|
396 |
for i := 0 to l do
|
397 |
write(OutFile,Format('%.2x',[Fraction[i]]),' ');
|
398 |
writeln(OutFile);
|
399 |
end;
|
400 |
end;
|
401 |
|
402 |
procedure TTestBase.ClientLibraryPathChanged;
|
403 |
begin
|
404 |
//Do nothing yet
|
405 |
end;
|
406 |
|
407 |
procedure TTestBase.CreateObjects(Application: TTestApplication);
|
408 |
begin
|
409 |
//Do nothing yet
|
410 |
end;
|
411 |
|
412 |
function TTestBase.ExtractDBName(ConnectString: AnsiString): AnsiString;
|
413 |
var ServerName: AnsiString;
|
414 |
Protocol: TProtocolAll;
|
415 |
PortNo: AnsiString;
|
416 |
i: integer;
|
417 |
begin
|
418 |
if not ParseConnectString(ConnectString, ServerName, Result, Protocol,PortNo) then
|
419 |
begin
|
420 |
{assume either inet format (remote) or localhost}
|
421 |
Result := ConnectString;
|
422 |
if Pos('inet',Result) = 1 then
|
423 |
begin
|
424 |
system.Delete(Result,1,7);
|
425 |
i := Pos('/',Result);
|
426 |
if i > 0 then
|
427 |
system.delete(Result,1,i);
|
428 |
end
|
429 |
else
|
430 |
if Pos('localhost:',Result) = 1 then
|
431 |
system.Delete(Result,1,10)
|
432 |
end;
|
433 |
end;
|
434 |
|
435 |
procedure TTestBase.PrintHexString(s: AnsiString);
|
436 |
var i: integer;
|
437 |
begin
|
438 |
for i := 1 to length(s) do
|
439 |
write(OutFile,Format('%x ',[byte(s[i])]));
|
440 |
end;
|
441 |
|
442 |
procedure TTestBase.PrintDPB(DPB: IDPB);
|
443 |
var i: integer;
|
444 |
begin
|
445 |
writeln(OutFile,'DPB: Item Count = ', DPB.getCount);
|
446 |
for i := 0 to DPB.getCount - 1 do
|
447 |
begin
|
448 |
write(OutFile,' ',DPB[i].getParamTypeName);
|
449 |
if DPB[i].AsString <> '' then
|
450 |
writeln(Outfile,' = ', DPB[i].AsString)
|
451 |
else
|
452 |
writeln(OutFile);
|
453 |
end;
|
454 |
writeln(OutFile);
|
455 |
end;
|
456 |
|
457 |
procedure TTestBase.PrintTPB(TPB: ITPB);
|
458 |
var i: integer;
|
459 |
begin
|
460 |
writeln(OutFile,'TPB: Item Count = ', TPB.getCount);
|
461 |
for i := 0 to TPB.getCount - 1 do
|
462 |
begin
|
463 |
write(OutFile,' ',TPB[i].getParamTypeName);
|
464 |
if TPB[i].AsString <> '' then
|
465 |
writeln(Outfile,' = ', TPB[i].AsString)
|
466 |
else
|
467 |
writeln(OutFile);
|
468 |
end;
|
469 |
writeln(OutFile);
|
470 |
end;
|
471 |
|
472 |
procedure TTestBase.PrintSPB(SPB: ISPB);
|
473 |
var i: integer;
|
474 |
begin
|
475 |
writeln(OutFile,'SPB: Item Count = ', SPB.getCount);
|
476 |
for i := 0 to SPB.getCount - 1 do
|
477 |
begin
|
478 |
write(OutFile,' ',SPB[i].getParamTypeName);
|
479 |
if SPB[i].AsString <> '' then
|
480 |
writeln(Outfile,' = ', SPB[i].AsString)
|
481 |
else
|
482 |
writeln(OutFile);
|
483 |
end;
|
484 |
writeln(OutFile);
|
485 |
end;
|
486 |
|
487 |
procedure TTestBase.PrintMetaData(meta: IMetaData);
|
488 |
var i, j: integer;
|
489 |
ar: IArrayMetaData;
|
490 |
bm: IBlobMetaData;
|
491 |
Bounds: TArrayBounds;
|
492 |
begin
|
493 |
writeln(OutFile,'Metadata');
|
494 |
for i := 0 to meta.GetCount - 1 do
|
495 |
with meta[i] do
|
496 |
begin
|
497 |
writeln(OutFile,'SQLType =',GetSQLTypeName);
|
498 |
writeln(OutFile,'sub type = ',getSubType);
|
499 |
writeln(OutFile,'Table = ',getRelationName);
|
500 |
writeln(OutFile,'Owner = ',getOwnerName);
|
501 |
writeln(OutFile,'Column Name = ',getSQLName);
|
502 |
writeln(OutFile,'Alias Name = ',getAliasName);
|
503 |
writeln(OutFile,'Field Name = ',getName);
|
504 |
writeln(OutFile,'Scale = ',getScale);
|
505 |
writeln(OutFile,'Charset id = ',getCharSetID);
|
506 |
if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
|
507 |
writeln(OutFile,'Size = ',GetSize);
|
508 |
case getSQLType of
|
509 |
SQL_ARRAY:
|
510 |
begin
|
511 |
writeln(OutFile,'Array Meta Data:');
|
512 |
ar := GetArrayMetaData;
|
513 |
writeln(OutFile,'SQLType =',ar.GetSQLTypeName);
|
514 |
writeln(OutFile,'Scale = ',ar.getScale);
|
515 |
writeln(OutFile,'Charset id = ',ar.getCharSetID);
|
516 |
writeln(OutFile,'Size = ',ar.GetSize);
|
517 |
writeln(OutFile,'Table = ',ar.GetTableName);
|
518 |
writeln(OutFile,'Column = ',ar.GetColumnName);
|
519 |
writeln(OutFile,'Dimensions = ',ar.GetDimensions);
|
520 |
write(OutFile,'Bounds: ');
|
521 |
Bounds := ar.GetBounds;
|
522 |
for j := 0 to Length(Bounds) - 1 do
|
523 |
write(OutFile,'(',Bounds[j].LowerBound,':',Bounds[j].UpperBound,') ');
|
524 |
writeln(OutFile);
|
525 |
end;
|
526 |
SQL_BLOB:
|
527 |
begin
|
528 |
writeln(OutFile);
|
529 |
writeln(OutFile,'Blob Meta Data');
|
530 |
bm := GetBlobMetaData;
|
531 |
writeln(OutFile,'SQL SubType =',bm.GetSubType);
|
532 |
writeln(OutFile,'Table = ',bm.GetRelationName);
|
533 |
writeln(OutFile,'Column = ',bm.GetColumnName);
|
534 |
writeln(OutFile,'CharSetID = ',bm.GetCharSetID);
|
535 |
writeln(OutFile,'Segment Size = ',bm.GetSegmentSize);
|
536 |
writeln(OutFile);
|
537 |
end;
|
538 |
end;
|
539 |
writeln(OutFile);
|
540 |
end;
|
541 |
end;
|
542 |
|
543 |
procedure TTestBase.ParamInfo(SQLParams: ISQLParams);
|
544 |
var i: integer;
|
545 |
begin
|
546 |
writeln(OutFile,'SQL Params');
|
547 |
for i := 0 to SQLParams.Count - 1 do
|
548 |
with SQLParams[i] do
|
549 |
begin
|
550 |
writeln(OutFile,'SQLType =',GetSQLTypeName);
|
551 |
writeln(OutFile,'sub type = ',getSubType);
|
552 |
writeln(OutFile,'Field Name = ',getName);
|
553 |
writeln(OutFile,'Scale = ',getScale);
|
554 |
writeln(OutFile,'Charset id = ',getCharSetID);
|
555 |
if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
|
556 |
writeln(OutFile,'Size = ',GetSize);
|
557 |
if not IsNull then
|
558 |
writeln(Outfile,'Value = ',getAsString);
|
559 |
writeln(OutFile);
|
560 |
end;
|
561 |
end;
|
562 |
|
563 |
function TTestBase.ReportResults(Statement: IStatement; ShowCursorName: boolean): IResultSet;
|
564 |
begin
|
565 |
Result := Statement.OpenCursor;
|
566 |
try
|
567 |
if ShowCursorName then
|
568 |
writeln(Outfile,'Results for Cursor: ',Result.GetCursorName);
|
569 |
while Result.FetchNext do
|
570 |
ReportResult(Result);
|
571 |
finally
|
572 |
Result.Close;
|
573 |
end;
|
574 |
writeln(OutFile);
|
575 |
end;
|
576 |
|
577 |
procedure TTestBase.ReportResult(aValue: IResults);
|
578 |
var i: integer;
|
579 |
begin
|
580 |
for i := 0 to aValue.getCount - 1 do
|
581 |
WriteSQLData(aValue[i]);
|
582 |
end;
|
583 |
|
584 |
function TTestBase.StringToHex(octetString: string; MaxLineLength: integer
|
585 |
): string;
|
586 |
|
587 |
function ToHex(aValue: byte): string;
|
588 |
const
|
589 |
HexChars: array [0..15] of char = '0123456789ABCDEF';
|
590 |
begin
|
591 |
Result := HexChars[aValue shr 4] +
|
592 |
HexChars[(aValue and $0F)];
|
593 |
end;
|
594 |
|
595 |
var i, j: integer;
|
596 |
begin
|
597 |
i := 1;
|
598 |
Result := '';
|
599 |
if MaxLineLength = 0 then
|
600 |
while i <= Length(octetString) do
|
601 |
begin
|
602 |
Result := Result + ToHex(byte(octetString[i]));
|
603 |
Inc(i);
|
604 |
end
|
605 |
else
|
606 |
while i <= Length(octetString) do
|
607 |
begin
|
608 |
for j := 1 to MaxLineLength do
|
609 |
begin
|
610 |
if i > Length(octetString) then
|
611 |
Exit
|
612 |
else
|
613 |
Result := Result + ToHex(byte(octetString[i]));
|
614 |
inc(i);
|
615 |
end;
|
616 |
Result := Result + LineEnding;
|
617 |
end;
|
618 |
end;
|
619 |
|
620 |
procedure TTestBase.WriteArray(ar: IArray);
|
621 |
var Bounds: TArrayBounds;
|
622 |
i,j: integer;
|
623 |
begin
|
624 |
write(OutFile,'Array: ');
|
625 |
Bounds := ar.GetBounds;
|
626 |
case ar.GetDimensions of
|
627 |
1:
|
628 |
begin
|
629 |
for i := Bounds[0].LowerBound to Bounds[0].UpperBound do
|
630 |
write(OutFile,'(',i,': ',ar.GetAsVariant([i]),') ');
|
631 |
end;
|
632 |
|
633 |
2:
|
634 |
begin
|
635 |
for i := Bounds[0].LowerBound to Bounds[0].UpperBound do
|
636 |
for j := Bounds[1].LowerBound to Bounds[1].UpperBound do
|
637 |
write(OutFile,'(',i,',',j,': ',ar.GetAsVariant([i,j]),') ');
|
638 |
end;
|
639 |
end;
|
640 |
writeln(OutFile);
|
641 |
writeln(OutFile);
|
642 |
end;
|
643 |
|
644 |
procedure TTestBase.WriteAffectedRows(Statement: IStatement);
|
645 |
var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
|
646 |
begin
|
647 |
Statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount);
|
648 |
writeln(OutFile,'Select Count = ', SelectCount,' InsertCount = ',InsertCount,' UpdateCount = ', UpdateCount, ' DeleteCount = ',DeleteCount);
|
649 |
end;
|
650 |
|
651 |
procedure TTestBase.WriteDBInfo(DBInfo: IDBInformation);
|
652 |
var i, j: integer;
|
653 |
bytes: TByteArray;
|
654 |
ConType: integer;
|
655 |
DBFileName: AnsiString;
|
656 |
DBSiteName: AnsiString;
|
657 |
Version: byte;
|
658 |
VersionString: AnsiString;
|
659 |
Users: TStringList;
|
660 |
begin
|
661 |
for i := 0 to DBInfo.GetCount - 1 do
|
662 |
with DBInfo[i] do
|
663 |
case getItemType of
|
664 |
isc_info_db_read_only:
|
665 |
if getAsInteger <> 0 then
|
666 |
writeln(OutFile,'Database is Read Only')
|
667 |
else
|
668 |
writeln(OutFile,'Database is Read/Write');
|
669 |
isc_info_allocation:
|
670 |
writeln(OutFile,'Pages =',getAsInteger);
|
671 |
isc_info_base_level:
|
672 |
begin
|
673 |
bytes := getAsBytes;
|
674 |
write(OutFile,'Base Level = ');
|
675 |
WriteBytes(Bytes);
|
676 |
end;
|
677 |
isc_info_db_id:
|
678 |
begin
|
679 |
DecodeIDCluster(ConType,DBFileName,DBSiteName);
|
680 |
writeln(OutFile,'Database ID = ', ConType,' FB = ', DBFileName, ' SN = ',DBSiteName);
|
681 |
end;
|
682 |
isc_info_implementation:
|
683 |
begin
|
684 |
bytes := getAsBytes;
|
685 |
write(OutFile,'Implementation = ');
|
686 |
WriteBytes(Bytes);
|
687 |
end;
|
688 |
isc_info_no_reserve:
|
689 |
writeln(OutFile,'Reserved = ',getAsInteger);
|
690 |
isc_info_ods_minor_version:
|
691 |
writeln(OutFile,'ODS minor = ',getAsInteger);
|
692 |
isc_info_ods_version:
|
693 |
writeln(OutFile,'ODS major = ',getAsInteger);
|
694 |
isc_info_page_size:
|
695 |
writeln(OutFile,'Page Size = ',getAsInteger);
|
696 |
isc_info_version:
|
697 |
begin
|
698 |
DecodeVersionString(Version,VersionString);
|
699 |
writeln(OutFile,'Version = ',Version,': ',VersionString);
|
700 |
end;
|
701 |
isc_info_current_memory:
|
702 |
writeln(OutFile,'Server Memory = ',getAsInteger);
|
703 |
isc_info_forced_writes:
|
704 |
writeln(OutFile,'Forced Writes = ',getAsInteger);
|
705 |
isc_info_max_memory:
|
706 |
writeln(OutFile,'Max Memory = ',getAsInteger);
|
707 |
isc_info_num_buffers:
|
708 |
writeln(OutFile,'Num Buffers = ',getAsInteger);
|
709 |
isc_info_sweep_interval:
|
710 |
writeln(OutFile,'Sweep Interval = ',getAsInteger);
|
711 |
isc_info_user_names:
|
712 |
begin
|
713 |
Users := TStringList.Create;
|
714 |
try
|
715 |
write(OutFile,'Logged in Users: ');
|
716 |
DecodeUserNames(Users);
|
717 |
for j := 0 to Users.Count - 1 do
|
718 |
write(OutFile,Users[j],',');
|
719 |
|
720 |
finally
|
721 |
Users.Free;
|
722 |
end;
|
723 |
writeln(OutFile);
|
724 |
end;
|
725 |
isc_info_fetches:
|
726 |
writeln(OutFile,'Fetches = ',getAsInteger);
|
727 |
isc_info_marks:
|
728 |
writeln(OutFile,'Writes = ',getAsInteger);
|
729 |
isc_info_reads:
|
730 |
writeln(OutFile,'Reads = ',getAsInteger);
|
731 |
isc_info_writes:
|
732 |
writeln(OutFile,'Page Writes = ',getAsInteger);
|
733 |
isc_info_backout_count:
|
734 |
WriteOperationCounts('Record Version Removals',getOperationCounts);
|
735 |
isc_info_delete_count:
|
736 |
WriteOperationCounts('Deletes',getOperationCounts);
|
737 |
isc_info_expunge_count:
|
738 |
WriteOperationCounts('Expunge Count',getOperationCounts);
|
739 |
isc_info_insert_count:
|
740 |
WriteOperationCounts('Insert Count',getOperationCounts);
|
741 |
isc_info_purge_count:
|
742 |
WriteOperationCounts('Purge Count Countites',getOperationCounts);
|
743 |
isc_info_read_idx_count:
|
744 |
WriteOperationCounts('Indexed Reads Count',getOperationCounts);
|
745 |
isc_info_read_seq_count:
|
746 |
WriteOperationCounts('Sequential Table Scans',getOperationCounts);
|
747 |
isc_info_update_count:
|
748 |
WriteOperationCounts('Update Count',getOperationCounts);
|
749 |
isc_info_db_SQL_Dialect:
|
750 |
writeln(OutFile,'SQL Dialect = ',getAsInteger);
|
751 |
isc_info_creation_date:
|
752 |
writeln(OutFile,'Database Created: ',DateTimeToStr(getAsDateTime));
|
753 |
isc_info_active_tran_count:
|
754 |
writeln(OutFile,'Active Transaction Count = ',getAsInteger);
|
755 |
fb_info_page_contents:
|
756 |
begin
|
757 |
writeln('Database Page');
|
758 |
PrintHexString(getAsString);
|
759 |
writeln;
|
760 |
end;
|
761 |
fb_info_pages_used:
|
762 |
writeln(OutFile,'Pages Used = ',getAsInteger);
|
763 |
fb_info_pages_free:
|
764 |
writeln(OutFile,'Pages Free = ',getAsInteger);
|
765 |
|
766 |
isc_info_truncated:
|
767 |
writeln(OutFile,'Results Truncated');
|
768 |
else
|
769 |
writeln(OutFile,'Unknown Response ',getItemType);
|
770 |
end;
|
771 |
end;
|
772 |
|
773 |
procedure TTestBase.WriteBytes(Bytes: TByteArray);
|
774 |
var i: integer;
|
775 |
begin
|
776 |
for i := 0 to length(Bytes) - 1 do
|
777 |
write(OutFile,Bytes[i],',');
|
778 |
writeln(OutFile);
|
779 |
end;
|
780 |
|
781 |
procedure TTestBase.WriteOperationCounts(Category: AnsiString;
|
782 |
ops: TDBOperationCounts);
|
783 |
var i: integer;
|
784 |
begin
|
785 |
writeln(OutFile,Category,' Operation Counts');
|
786 |
for i := 0 to Length(ops) - 1 do
|
787 |
begin
|
788 |
writeln(OutFile,'Table ID = ',ops[i].TableID);
|
789 |
writeln(OutFile,'Count = ',ops[i].Count);
|
790 |
end;
|
791 |
writeln(OutFile);
|
792 |
end;
|
793 |
|
794 |
procedure TTestBase.WritePerfStats(stats: TPerfCounters);
|
795 |
var LargeCompFormat: string;
|
796 |
ThreeSigPlacesFormat: string;
|
797 |
begin
|
798 |
{$IF declared(DefaultFormatSettings)}
|
799 |
with DefaultFormatSettings do
|
800 |
{$ELSE}
|
801 |
{$IF declared(FormatSettings)}
|
802 |
with FormatSettings do
|
803 |
{$IFEND}
|
804 |
{$IFEND}
|
805 |
begin
|
806 |
LargeCompFormat := '#' + ThousandSeparator + '##0';
|
807 |
ThreeSigPlacesFormat := '#0' + DecimalSeparator + '000';
|
808 |
end;
|
809 |
writeln(OutFile,'Current memory = ', FormatFloat(LargeCompFormat,stats[psCurrentMemory]));
|
810 |
writeln(OutFile,'Delta memory = ', FormatFloat(LargeCompFormat,stats[psDeltaMemory]));
|
811 |
writeln(OutFile,'Max memory = ', FormatFloat(LargeCompFormat,stats[psMaxMemory]));
|
812 |
writeln(OutFile,'Elapsed time= ', FormatFloat(ThreeSigPlacesFormat,stats[psRealTime]/1000),' sec');
|
813 |
writeln(OutFile,'Cpu = ', FormatFloat(ThreeSigPlacesFormat,stats[psUserTime]/1000),' sec');
|
814 |
writeln(OutFile,'Buffers = ', FormatFloat('#0',stats[psBuffers]));
|
815 |
writeln(OutFile,'Reads = ', FormatFloat('#0',stats[psReads]));
|
816 |
writeln(OutFile,'Writes = ', FormatFloat('#0',stats[psWrites]));
|
817 |
writeln(OutFile,'Fetches = ', FormatFloat('#0',stats[psFetches]));
|
818 |
end;
|
819 |
|
820 |
procedure TTestBase.WriteSQLData(aValue: ISQLData);
|
821 |
var s: AnsiString;
|
822 |
dt: TDateTime;
|
823 |
dstOffset: SmallInt;
|
824 |
aTimeZone: AnsiString;
|
825 |
begin
|
826 |
if aValue.IsNull then
|
827 |
writeln(OutFile,aValue.Name,' = NULL')
|
828 |
else
|
829 |
case aValue.SQLType of
|
830 |
SQL_ARRAY:
|
831 |
begin
|
832 |
write(OutFile, aValue.Name,' = ');
|
833 |
if not aValue.IsNull then
|
834 |
WriteArray(aValue.AsArray)
|
835 |
else
|
836 |
writeln(OutFile,'NULL');
|
837 |
end;
|
838 |
SQL_FLOAT,SQL_DOUBLE,
|
839 |
SQL_D_FLOAT:
|
840 |
writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble));
|
841 |
|
842 |
SQL_INT64:
|
843 |
if aValue.Scale <> 0 then
|
844 |
writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble))
|
845 |
else
|
846 |
writeln(OutFile,aValue.Name,' = ',aValue.AsString);
|
847 |
|
848 |
SQL_BLOB:
|
849 |
if aValue.IsNull then
|
850 |
writeln(OutFile,aValue.Name,' = (null blob)')
|
851 |
else
|
852 |
if aValue.SQLSubType = 1 then
|
853 |
begin
|
854 |
s := aValue.AsString;
|
855 |
if FHexStrings then
|
856 |
begin
|
857 |
write(OutFile,aValue.Name,' = ');
|
858 |
PrintHexString(s);
|
859 |
writeln(OutFile,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')');
|
860 |
end
|
861 |
else
|
862 |
begin
|
863 |
writeln(OutFile,aValue.Name,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')');
|
864 |
writeln(OutFile);
|
865 |
writeln(OutFile,s);
|
866 |
end
|
867 |
end
|
868 |
else
|
869 |
begin
|
870 |
writeln(OutFile,aValue.Name,' = (blob), Length = ',aValue.AsBlob.GetBlobSize);
|
871 |
if FShowBinaryBlob then
|
872 |
PrintHexString(aValue.AsString);
|
873 |
end;
|
874 |
|
875 |
SQL_TEXT,SQL_VARYING:
|
876 |
begin
|
877 |
if aValue.GetCharSetID = 1 then
|
878 |
s := aValue.AsString
|
879 |
else
|
880 |
s := TrimRight(aValue.AsString);
|
881 |
if FHexStrings then
|
882 |
begin
|
883 |
write(OutFile,aValue.Name,' = ');
|
884 |
PrintHexString(s);
|
885 |
writeln(OutFile,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')');
|
886 |
end
|
887 |
else
|
888 |
if aValue.GetCharSetID > 0 then
|
889 |
writeln(OutFile,aValue.Name,' = ',s,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')')
|
890 |
else
|
891 |
writeln(OutFile,aValue.Name,' = ',s);
|
892 |
end;
|
893 |
|
894 |
SQL_TIMESTAMP:
|
895 |
writeln(OutFile,aValue.Name,' = ',FBFormatDateTime('yyyy/mm/dd hh:nn:ss.zzzz',aValue.AsDateTime));
|
896 |
SQL_TYPE_DATE:
|
897 |
writeln(OutFile,aValue.Name,' = ',FBFormatDateTime('yyyy/mm/dd',aValue.AsDate));
|
898 |
SQL_TYPE_TIME:
|
899 |
writeln(OutFile,aValue.Name,' = ',FBFormatDateTime('hh:nn:ss.zzzz',aValue.AsTime));
|
900 |
SQL_TIMESTAMP_TZ,
|
901 |
SQL_TIMESTAMP_TZ_EX:
|
902 |
begin
|
903 |
aValue.GetAsDateTime(dt,dstOffset,aTimeZone);
|
904 |
writeln(OutFile,aValue.Name,' =');
|
905 |
writeln(OutFile,' AsString = ',aValue.GetAsString);
|
906 |
writeln(OutFile,' Formatted = ',FBFormatDateTime('yyyy/mm/dd hh:nn:ss.zzzz',dt),' ',aTimeZone);
|
907 |
writeln(OutFile,' TimeZoneID = ',aValue.GetStatement.GetAttachment.GetTimeZoneServices.TimeZoneName2TimeZoneID(aTimeZone));
|
908 |
writeln(OutFile,' Time Zone Name = ',aTimeZone);
|
909 |
writeln(OutFile,' UTC Time = ',DateTimeToStr( aValue.GetAsUTCDateTime));
|
910 |
writeln(OutFile,' DST Offset = ',dstOffset);
|
911 |
end;
|
912 |
SQL_TIME_TZ,
|
913 |
SQL_TIME_TZ_EX:
|
914 |
begin
|
915 |
aValue.GetAsDateTime(dt,dstOffset,aTimeZone);
|
916 |
writeln(OutFile,aValue.Name,' =');
|
917 |
writeln(OutFile,' AsString = ',aValue.GetAsString);
|
918 |
writeln(OutFile,' Formatted = ',FBFormatDateTime('hh:nn:ss.zzzz',dt),' ',aTimeZone);
|
919 |
writeln(OutFile,' TimeZoneID = ',aValue.GetStatement.GetAttachment.GetTimeZoneServices.TimeZoneName2TimeZoneID(aTimeZone));
|
920 |
writeln(OutFile,' Time Zone Name = ',aTimeZone);
|
921 |
writeln(OutFile,' UTC Time = ',TimeToStr( aValue.GetAsUTCDateTime));
|
922 |
writeln(OutFile,' DST Offset = ',dstOffset);
|
923 |
end;
|
924 |
|
925 |
else
|
926 |
writeln(OutFile,aValue.Name,' = ',aValue.AsString);
|
927 |
end;
|
928 |
end;
|
929 |
|
930 |
procedure TTestBase.CheckActivity(Attachment: IAttachment);
|
931 |
begin
|
932 |
writeln(OutFile,'Database Activity = ',Attachment.HasActivity)
|
933 |
end;
|
934 |
|
935 |
procedure TTestBase.CheckActivity(Transaction: ITransaction);
|
936 |
begin
|
937 |
writeln(OutFile,'Transaction Activity = ',Transaction.HasActivity)
|
938 |
end;
|
939 |
|
940 |
procedure TTestBase.InitTest;
|
941 |
begin
|
942 |
//Do nothing yet
|
943 |
end;
|
944 |
|
945 |
function TTestBase.SkipTest: boolean;
|
946 |
begin
|
947 |
Result := false;
|
948 |
end;
|
949 |
|
950 |
procedure TTestBase.ProcessResults;
|
951 |
begin
|
952 |
//Do nothing
|
953 |
end;
|
954 |
|
955 |
procedure TTestBase.SetFloatTemplate(tpl: Ansistring);
|
956 |
begin
|
957 |
FFloatTpl := tpl;
|
958 |
end;
|
959 |
|
960 |
{ TTestApplication }
|
961 |
|
962 |
class procedure TTestApplication.CreateTestList;
|
963 |
begin
|
964 |
if FTests = nil then
|
965 |
begin
|
966 |
FTests := TStringList.Create;
|
967 |
FTests.Sorted := true;
|
968 |
FTests.Duplicates := dupError;
|
969 |
end;
|
970 |
end;
|
971 |
|
972 |
class procedure TTestApplication.DestroyTestList;
|
973 |
var i: integer;
|
974 |
TestID: Ansistring;
|
975 |
begin
|
976 |
if assigned(FTests) then
|
977 |
begin
|
978 |
for i := 0 to FTests.Count - 1 do
|
979 |
if FTests.Objects[i] <> nil then
|
980 |
try
|
981 |
TestID := TTestBase(FTests.Objects[i]).TestID;
|
982 |
FTests.Objects[i].Free;
|
983 |
except on E: Exception do
|
984 |
writeln('Error Freeing Test ',TestID,' Error message = ',E.Message);
|
985 |
end;
|
986 |
FreeAndNil(FTests);
|
987 |
end;
|
988 |
end;
|
989 |
|
990 |
procedure TTestApplication.CleanUp;
|
991 |
var DPB: IDPB;
|
992 |
Attachment: IAttachment;
|
993 |
begin
|
994 |
DPB := FirebirdAPI.AllocateDPB;
|
995 |
DPB.Add(isc_dpb_user_name).setAsString(GetUserName);
|
996 |
DPB.Add(isc_dpb_password).setAsString(GetPassword);
|
997 |
Attachment := FirebirdAPI.OpenDatabase(GetNewDatabaseName,DPB,false);
|
998 |
if Attachment <> nil then
|
999 |
Attachment.DropDatabase;
|
1000 |
Attachment := FirebirdAPI.OpenDatabase(GetSecondNewDatabaseName,DPB,false);
|
1001 |
if Attachment <> nil then
|
1002 |
Attachment.DropDatabase;
|
1003 |
end;
|
1004 |
|
1005 |
function TTestApplication.GetFirebirdAPI: IFirebirdAPI;
|
1006 |
begin
|
1007 |
if FFirebirdAPI = nil then
|
1008 |
begin
|
1009 |
FFirebirdAPI := IB.FirebirdAPI;
|
1010 |
FFirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);;
|
1011 |
end;
|
1012 |
Result := FFirebirdAPI;
|
1013 |
end;
|
1014 |
|
1015 |
function TTestApplication.GetIndexByTestID(aTestID: AnsiString): integer;
|
1016 |
begin
|
1017 |
try
|
1018 |
Result := FTests.IndexOf(aTestID);
|
1019 |
except
|
1020 |
raise Exception.CreateFmt('Invalid Test ID - %s',[aTestID]);
|
1021 |
end;
|
1022 |
if Result = -1 then
|
1023 |
raise Exception. CreateFmt('Invalid Test ID - %s',[aTestID]);
|
1024 |
end;
|
1025 |
|
1026 |
constructor TTestApplication.Create(AOwner: TComponent);
|
1027 |
var i: integer;
|
1028 |
begin
|
1029 |
inherited Create(AOwner);
|
1030 |
TestApp := self;
|
1031 |
CreateTestList;
|
1032 |
FNewDatabaseName := GetTempDir + 'fbtestsuite.fdb';
|
1033 |
FSecondNewDatabaseName := GetTempDir + 'fbtestsuite2.fdb';
|
1034 |
FUserName := 'SYSDBA';
|
1035 |
FPassword := 'masterkey';
|
1036 |
FEmployeeDatabaseName := 'employee';
|
1037 |
FBackupFileName := GetTempDir + 'testbackup.gbk';
|
1038 |
FServer := 'localhost';
|
1039 |
for i := 0 to FTests.Count - 1 do
|
1040 |
begin
|
1041 |
TTestBase(FTests.Objects[i]).SetOwner(self);
|
1042 |
// TTestBase(FTests.Objects[i]).CreateObjects(self);
|
1043 |
end;
|
1044 |
end;
|
1045 |
|
1046 |
destructor TTestApplication.Destroy;
|
1047 |
begin
|
1048 |
DestroyTestList;
|
1049 |
TestApp := nil;
|
1050 |
inherited Destroy;
|
1051 |
end;
|
1052 |
|
1053 |
function TTestApplication.GetUserName: AnsiString;
|
1054 |
begin
|
1055 |
Result := FUserName;
|
1056 |
end;
|
1057 |
|
1058 |
function TTestApplication.GetPassword: AnsiString;
|
1059 |
begin
|
1060 |
Result := FPassword;
|
1061 |
end;
|
1062 |
|
1063 |
function TTestApplication.GetEmployeeDatabaseName: AnsiString;
|
1064 |
begin
|
1065 |
if FirebirdAPI.GetClientMajor < 3 then
|
1066 |
Result := MakeConnectString(FServer, FEmployeeDatabaseName, TCP,FPortNo)
|
1067 |
else
|
1068 |
Result := MakeConnectString(FServer, FEmployeeDatabaseName, inet,FPortNo);
|
1069 |
end;
|
1070 |
|
1071 |
function TTestApplication.GetNewDatabaseName: AnsiString;
|
1072 |
begin
|
1073 |
if FirebirdAPI.GetClientMajor < 3 then
|
1074 |
Result := MakeConnectString(FServer, FNewDatabaseName, TCP,FPortNo)
|
1075 |
else
|
1076 |
Result := MakeConnectString(FServer, FNewDatabaseName, inet,FPortNo);
|
1077 |
end;
|
1078 |
|
1079 |
function TTestApplication.GetTempDatabaseName: AnsiString;
|
1080 |
begin
|
1081 |
Result := GetTempDir + 'fbtest.fbd';
|
1082 |
end;
|
1083 |
|
1084 |
function TTestApplication.GetSecondNewDatabaseName: AnsiString;
|
1085 |
begin
|
1086 |
if FirebirdAPI.GetClientMajor < 3 then
|
1087 |
Result := MakeConnectString(FServer, FSecondNewDatabaseName, TCP,FPortNo)
|
1088 |
else
|
1089 |
Result := MakeConnectString(FServer, FSecondNewDatabaseName, inet,FPortNo);
|
1090 |
end;
|
1091 |
|
1092 |
function TTestApplication.GetBackupFileName: AnsiString;
|
1093 |
begin
|
1094 |
Result := FBackupFileName;
|
1095 |
end;
|
1096 |
|
1097 |
procedure TTestApplication.RunAll;
|
1098 |
var i: integer;
|
1099 |
begin
|
1100 |
CleanUp;
|
1101 |
for i := 0 to FTests.Count - 1 do
|
1102 |
begin
|
1103 |
DoTest(i);
|
1104 |
if not Quiet then
|
1105 |
writeln(Outfile,'------------------------------------------------------');
|
1106 |
Sleep(500);
|
1107 |
end;
|
1108 |
end;
|
1109 |
|
1110 |
procedure TTestApplication.RunTest(TestID: AnsiString);
|
1111 |
begin
|
1112 |
CleanUp;
|
1113 |
DoTest(GetIndexByTestID(TestID));
|
1114 |
end;
|
1115 |
|
1116 |
procedure TTestApplication.SetClientLibraryPath(aLibName: string);
|
1117 |
var i: integer;
|
1118 |
begin
|
1119 |
FFirebirdAPI := LoadFBLibrary(aLibName).GetFirebirdAPI;
|
1120 |
FClientLibraryPath := aLibName;
|
1121 |
for i := 0 to FTests.Count - 1 do
|
1122 |
TTestBase(FTests.Objects[i]).ClientLibraryPathChanged;
|
1123 |
|
1124 |
end;
|
1125 |
|
1126 |
procedure TTestApplication.SetUserName(aValue: AnsiString);
|
1127 |
begin
|
1128 |
FUserName := aValue;
|
1129 |
end;
|
1130 |
|
1131 |
procedure TTestApplication.SetPassword(aValue: AnsiString);
|
1132 |
begin
|
1133 |
FPassword := aValue;
|
1134 |
end;
|
1135 |
|
1136 |
procedure TTestApplication.SetEmployeeDatabaseName(aValue: AnsiString);
|
1137 |
begin
|
1138 |
FEmployeeDatabaseName := aValue;
|
1139 |
end;
|
1140 |
|
1141 |
procedure TTestApplication.SetNewDatabaseName(aValue: AnsiString);
|
1142 |
begin
|
1143 |
FNewDatabaseName := aValue;
|
1144 |
end;
|
1145 |
|
1146 |
procedure TTestApplication.SetSecondNewDatabaseName(aValue: AnsiString);
|
1147 |
begin
|
1148 |
FSecondNewDatabaseName := aValue;
|
1149 |
end;
|
1150 |
|
1151 |
procedure TTestApplication.SetBackupFileName(aValue: AnsiString);
|
1152 |
begin
|
1153 |
FBackupFileName := aValue;
|
1154 |
end;
|
1155 |
|
1156 |
procedure TTestApplication.SetServerName(AValue: AnsiString);
|
1157 |
begin
|
1158 |
if FServer = AValue then Exit;
|
1159 |
FServer := AValue;
|
1160 |
end;
|
1161 |
|
1162 |
procedure TTestApplication.SetPortNum(aValue: AnsiString);
|
1163 |
begin
|
1164 |
FPortNo := aValue;
|
1165 |
end;
|
1166 |
|
1167 |
procedure TTestApplication.SetTestOption(aValue: AnsiString);
|
1168 |
begin
|
1169 |
FTestOption := AValue;
|
1170 |
end;
|
1171 |
|
1172 |
{$IFDEF FPC}
|
1173 |
function TTestApplication.GetShortOptions: AnsiString;
|
1174 |
begin
|
1175 |
Result := 'htupensbolrSPXOq';
|
1176 |
end;
|
1177 |
|
1178 |
function TTestApplication.GetLongOptions: AnsiString;
|
1179 |
begin
|
1180 |
Result := 'help test user passwd employeedb newdbname secondnewdbname backupfile '+
|
1181 |
'outfile fbclientlibrary server stats port prompt TestOption quiet';
|
1182 |
end;
|
1183 |
|
1184 |
procedure TTestApplication.GetParams(var DoPrompt: boolean; var TestID: string);
|
1185 |
var ErrorMsg: String;
|
1186 |
begin
|
1187 |
// quick check parameters
|
1188 |
ErrorMsg := CheckOptions(GetShortOptions,GetLongOptions);
|
1189 |
if ErrorMsg <> '' then begin
|
1190 |
ShowException(Exception.Create(ErrorMsg));
|
1191 |
Terminate;
|
1192 |
Exit;
|
1193 |
end;
|
1194 |
|
1195 |
// parse parameters
|
1196 |
if HasOption('h', 'help') then begin
|
1197 |
WriteHelp;
|
1198 |
Terminate;
|
1199 |
Exit;
|
1200 |
end;
|
1201 |
|
1202 |
if HasOption('t') then
|
1203 |
TestID := GetOptionValue('t');
|
1204 |
if Length(TestID) = 1 then
|
1205 |
TestID := '0' + TestID;
|
1206 |
|
1207 |
DoPrompt := HasOption('X','prompt');
|
1208 |
|
1209 |
if HasOption('u','user') then
|
1210 |
SetUserName(GetOptionValue('u'));
|
1211 |
|
1212 |
if HasOption('p','passwd') then
|
1213 |
SetPassword(GetOptionValue('p'));
|
1214 |
|
1215 |
if HasOption('e','employeedb') then
|
1216 |
SetEmployeeDatabaseName(GetOptionValue('e'));
|
1217 |
|
1218 |
if HasOption('n','newdbname') then
|
1219 |
SetNewDatabaseName(GetOptionValue('n'));
|
1220 |
|
1221 |
if HasOption('s','secondnewdbname') then
|
1222 |
SetSecondNewDatabaseName(GetOptionValue('s'));
|
1223 |
|
1224 |
if HasOption('b','backupfile') then
|
1225 |
SetBackupFileName(GetOptionValue('b'));
|
1226 |
|
1227 |
if HasOption('l','fbclientlibrary') then
|
1228 |
SetClientLibraryPath(GetOptionValue('l'));
|
1229 |
|
1230 |
if HasOption('r','server') then
|
1231 |
SetServerName(GetOptionValue('r'));
|
1232 |
|
1233 |
if HasOption('o','outfile') then
|
1234 |
begin
|
1235 |
system.Assign(outFile,GetOptionValue('o'));
|
1236 |
ReWrite(outFile);
|
1237 |
end;
|
1238 |
|
1239 |
if HasOption('P','port') then
|
1240 |
SetPortNum(GetOptionValue('P'));
|
1241 |
|
1242 |
ShowStatistics := HasOption('S','stats');
|
1243 |
|
1244 |
if HasOption('O','TestOption') then
|
1245 |
SetTestOption(GetOptionValue('O'));
|
1246 |
|
1247 |
FQuiet := HasOption('q','quiet')
|
1248 |
end;
|
1249 |
{$ENDIF}
|
1250 |
|
1251 |
{$IFDEF DCC}
|
1252 |
procedure TTestApplication.GetParams(var DoPrompt: boolean; var TestID: string);
|
1253 |
|
1254 |
function GetCmdLineValue(const Switch: string; var aValue: string): boolean;
|
1255 |
var i: integer;
|
1256 |
begin
|
1257 |
aValue := '';
|
1258 |
Result := FindCmdLineSwitch(Switch,false);
|
1259 |
if Result then
|
1260 |
begin
|
1261 |
for i := 0 to ParamCount do
|
1262 |
if (ParamStr(i) = '-' + Switch) and (i <= ParamCount) then
|
1263 |
begin
|
1264 |
aValue := ParamStr(i+1);
|
1265 |
exit;
|
1266 |
end;
|
1267 |
Result := false;
|
1268 |
end;
|
1269 |
end;
|
1270 |
|
1271 |
var aValue: string;
|
1272 |
|
1273 |
begin
|
1274 |
// parse parameters
|
1275 |
if FindCmdLineSwitch('h') or FindCmdLineSwitch('help') then
|
1276 |
begin
|
1277 |
WriteHelp;
|
1278 |
Exit;
|
1279 |
end;
|
1280 |
|
1281 |
if GetCmdLineValue('t',aValue) then
|
1282 |
TestID := aValue;
|
1283 |
|
1284 |
DoPrompt := GetCmdLineValue('X',aValue);
|
1285 |
|
1286 |
if GetCmdLineValue('u',aValue) or GetCmdLineValue('user',aValue) then
|
1287 |
SetUserName(aValue);
|
1288 |
|
1289 |
if GetCmdLineValue('p',aValue) or GetCmdLineValue('passwd',aValue) then
|
1290 |
SetPassword(aValue);
|
1291 |
|
1292 |
if GetCmdLineValue('e',aValue) or GetCmdLineValue('employeedb',aValue) then
|
1293 |
SetEmployeeDatabaseName(aValue);
|
1294 |
|
1295 |
if GetCmdLineValue('n',aValue) or GetCmdLineValue('newdbname',aValue) then
|
1296 |
SetNewDatabaseName(aValue);
|
1297 |
|
1298 |
if GetCmdLineValue('s',aValue) or GetCmdLineValue('secondnewdbname',aValue) then
|
1299 |
SetSecondNewDatabaseName(aValue);
|
1300 |
|
1301 |
if GetCmdLineValue('b',aValue) or GetCmdLineValue('backupfile',aValue) then
|
1302 |
SetBackupFileName(aValue);
|
1303 |
|
1304 |
if GetCmdLineValue('r',aValue) or GetCmdLineValue('server',aValue) then
|
1305 |
SetServerName(aValue);
|
1306 |
|
1307 |
if GetCmdLineValue('P',aValue) or GetCmdLineValue('port',aValue) then
|
1308 |
SetPortNum(aValue);
|
1309 |
|
1310 |
if GetCmdLineValue('l',aValue) or GetCmdLineValue('fbclientlibrary',aValue) then
|
1311 |
SetClientLibraryPath(aValue);
|
1312 |
|
1313 |
if GetCmdLineValue('o',aValue) or GetCmdLineValue('outfile',aValue) then
|
1314 |
begin
|
1315 |
system.Assign(outFile,aValue);
|
1316 |
ReWrite(outFile);
|
1317 |
end;
|
1318 |
|
1319 |
ShowStatistics := FindCmdLineSwitch('S',false) or FindCmdLineSwitch('stats');
|
1320 |
|
1321 |
if GetCmdLineValue('O',aValue) or GetCmdLineValue('TestOption',aValue) then
|
1322 |
SetTestOption(aValue);
|
1323 |
|
1324 |
FQuiet := FindCmdLineSwitch('q',false) or FindCmdLineSwitch('quiet');
|
1325 |
end;
|
1326 |
{$ENDIF}
|
1327 |
|
1328 |
procedure TTestApplication.DoRun;
|
1329 |
var
|
1330 |
DoPrompt: boolean;
|
1331 |
TestID: string;
|
1332 |
MasterProvider: IFBIMasterProvider;
|
1333 |
begin
|
1334 |
{$IFDEF FPC}
|
1335 |
OutFile := stdout;
|
1336 |
{$ELSE}
|
1337 |
AssignFile(OutFile,'');
|
1338 |
ReWrite(outFile);
|
1339 |
{$ENDIF}
|
1340 |
|
1341 |
GetParams(DoPrompt,TestID);
|
1342 |
if length(TestID) = 1 then
|
1343 |
TestID := '0' + TestID;
|
1344 |
{$IF declared(SetTextCodePage)}
|
1345 |
{Ensure consistent UTF-8 output}
|
1346 |
SetTextCodePage(OutFile,cp_utf8);
|
1347 |
{$IFEND}
|
1348 |
{$IF declared(SetConsoleOutputCP)}
|
1349 |
SetConsoleOutputCP(cp_utf8);
|
1350 |
{$IFEND}
|
1351 |
|
1352 |
|
1353 |
{Ensure consistent date reporting across platforms}
|
1354 |
SetFormatSettings;
|
1355 |
|
1356 |
if not Quiet then
|
1357 |
begin
|
1358 |
writeln(OutFile,Title);
|
1359 |
writeln(OutFile,Copyright);
|
1360 |
writeln(OutFile);
|
1361 |
writeln(OutFile,'Starting Tests');
|
1362 |
writeln(OutFile,'Client API Version = ',FirebirdAPI.GetImplementationVersion);
|
1363 |
writeln(OutFile,'Firebird Environment Variable = ',sysutils.GetEnvironmentVariable('FIREBIRD'));
|
1364 |
if FirebirdAPI.HasMasterIntf and (FirebirdAPI.QueryInterface(IFBIMasterProvider,MasterProvider) = S_OK) then
|
1365 |
with MasterProvider.GetIMasterIntf.getConfigManager do
|
1366 |
begin
|
1367 |
writeln(OutFile,'Firebird Bin Directory = ', getDirectory(DIR_BIN));
|
1368 |
writeln(OutFile,'Firebird Conf Directory = ', getDirectory(DIR_CONF));
|
1369 |
end;
|
1370 |
writeln(OutFile,'Firebird Client Library Path = ',FirebirdAPI.GetFBLibrary.GetLibraryFilePath);
|
1371 |
end;
|
1372 |
|
1373 |
try
|
1374 |
if TestID = '' then
|
1375 |
RunAll
|
1376 |
else
|
1377 |
RunTest(TestID);
|
1378 |
CleanUp;
|
1379 |
except on E: Exception do
|
1380 |
begin
|
1381 |
writeln('Exception: ',E.Message);
|
1382 |
writeln(OutFile,'Exception: ',E.Message);
|
1383 |
end;
|
1384 |
end;
|
1385 |
|
1386 |
writeln(OutFile,'Test Suite Ends');
|
1387 |
Flush(OutFile);
|
1388 |
{$IFDEF WINDOWS}
|
1389 |
if DoPrompt then
|
1390 |
begin
|
1391 |
write('Press Entry to continue');
|
1392 |
readln; {when running from IDE and console window closes before you can view results}
|
1393 |
end;
|
1394 |
{$ENDIF}
|
1395 |
|
1396 |
// stop program loop
|
1397 |
Terminate;
|
1398 |
end;
|
1399 |
|
1400 |
procedure TTestApplication.DoTest(index: integer);
|
1401 |
begin
|
1402 |
if FTests.Objects[index] = nil then Exit;
|
1403 |
try
|
1404 |
with TTestBase(FTests.Objects[index]) do
|
1405 |
if SkipTest then
|
1406 |
writeln(OutFile,' Skipping ' + TestID)
|
1407 |
else
|
1408 |
begin
|
1409 |
if not Quiet then
|
1410 |
writeln(OutFile,'Running ' + TestTitle);
|
1411 |
if not ChildProcess then
|
1412 |
writeln(ErrOutput,'Running ' + TestTitle);
|
1413 |
try
|
1414 |
CreateObjects(self);
|
1415 |
InitTest;
|
1416 |
RunTest('UTF8',3);
|
1417 |
ProcessResults;
|
1418 |
except
|
1419 |
on E:ESkipException do
|
1420 |
writeln(OutFile,'Skipping Test: ' + E.Message);
|
1421 |
on E:Exception do
|
1422 |
begin
|
1423 |
writeln(OutFile,'Test Completed with Error: ' + E.Message);
|
1424 |
Exit;
|
1425 |
end;
|
1426 |
end;
|
1427 |
if not Quiet then
|
1428 |
begin
|
1429 |
writeln(OutFile);
|
1430 |
writeln(OutFile);
|
1431 |
end;
|
1432 |
end;
|
1433 |
finally
|
1434 |
FTests.Objects[index].Free;
|
1435 |
FTests.Objects[index] := nil;
|
1436 |
DestroyComponents;
|
1437 |
end;
|
1438 |
end;
|
1439 |
|
1440 |
procedure TTestApplication.SetFormatSettings;
|
1441 |
begin
|
1442 |
{$IF declared(DefaultFormatSettings)}
|
1443 |
with DefaultFormatSettings do
|
1444 |
{$ELSE}
|
1445 |
{$IF declared(FormatSettings)}
|
1446 |
with FormatSettings do
|
1447 |
{$IFEND}{$IFEND}
|
1448 |
begin
|
1449 |
ShortDateFormat := 'dd/m/yyyy';
|
1450 |
LongTimeFormat := 'HH:MM:SS';
|
1451 |
DateSeparator := '/';
|
1452 |
end;
|
1453 |
end;
|
1454 |
|
1455 |
procedure TTestApplication.WriteHelp;
|
1456 |
begin
|
1457 |
{ add your help code here }
|
1458 |
writeln(OutFile,'Usage: ', ExeName, ' -h');
|
1459 |
end;
|
1460 |
|
1461 |
{$IFNDEF FPC}
|
1462 |
function TCustomApplication.Exename: string;
|
1463 |
begin
|
1464 |
Result := ParamStr(0);
|
1465 |
end;
|
1466 |
|
1467 |
procedure TCustomApplication.Run;
|
1468 |
begin
|
1469 |
try
|
1470 |
DoRun;
|
1471 |
except on E: Exception do
|
1472 |
writeln(OutFile,E.Message);
|
1473 |
end;
|
1474 |
end;
|
1475 |
|
1476 |
procedure TCustomApplication.Terminate;
|
1477 |
begin
|
1478 |
|
1479 |
end;
|
1480 |
{$ENDIF}
|
1481 |
|
1482 |
end.
|
1483 |
|