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