ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/testsuite/testApp/TestApplication.pas
Revision: 379
Committed: Mon Jan 10 10:08:03 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 45385 byte(s)
Log Message:
set line ending property

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

Properties

Name Value
svn:eol-style native