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