ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/testsuite/testApp/TestApplication.pas
Revision: 351
Committed: Wed Oct 20 15:04:35 2021 UTC (2 years, 5 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/testsuite/testApp/TestApplication.pas
File size: 40431 byte(s)
Log Message:
Add Missing testsuite files

File Contents

# Content
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