ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/testsuite/TestManager.pas
Revision: 309
Committed: Tue Jul 21 08:00:42 2020 UTC (3 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 24852 byte(s)
Log Message:
Fixes Merged

File Contents

# Content
1 unit TestManager;
2 {$IFDEF MSWINDOWS}
3 {$DEFINE WINDOWS}
4 {$ENDIF}
5
6 {$IFDEF FPC}
7 {$mode delphi}
8 {$codepage utf8}
9 {$ENDIF}
10
11 interface
12
13 uses
14 Classes, SysUtils, IB;
15
16 {$IFDEF MSWINDOWS}
17 const LineEnding = #$0D#$0A;
18 {$ENDIF}
19
20 type
21 TTestManager = class;
22
23 { TTestBase }
24
25 TTestBase = class
26 private
27 FOwner: TTestManager;
28 protected
29 FHexStrings: boolean;
30 function ExtractDBName(ConnectString: AnsiString): AnsiString;
31 function ReportResults(Statement: IStatement): IResultSet;
32 procedure ReportResult(aValue: IResults);
33 procedure PrintHexString(s: AnsiString);
34 procedure PrintDPB(DPB: IDPB);
35 procedure PrintMetaData(meta: IMetaData);
36 procedure ParamInfo(SQLParams: ISQLParams);
37 procedure WriteArray(ar: IArray);
38 procedure WriteAffectedRows(Statement: IStatement);
39 function WriteServiceQueryResult(QueryResult: IServiceQueryResults): boolean;
40 procedure writeLicence(Item: IServiceQueryResultItem);
41 procedure WriteConfig(config: IServiceQueryResultItem);
42 procedure WriteUsers(users: IServiceQueryResultItem);
43 procedure WriteDBAttachments(att: IServiceQueryResultItem);
44 procedure WriteLimboTransactions(limbo: IServiceQueryResultItem);
45 procedure WriteDBInfo(DBInfo: IDBInformation);
46 procedure WriteBytes(Bytes: TByteArray);
47 procedure WriteOperationCounts(Category: AnsiString; ops: TDBOperationCounts);
48 procedure WritePerfStats(stats: TPerfCounters);
49 procedure CheckActivity(Attachment: IAttachment); overload;
50 procedure CheckActivity(Transaction: ITransaction); overload;
51 public
52 constructor Create(aOwner: TTestManager); virtual;
53 function TestTitle: AnsiString; virtual; abstract;
54 procedure RunTest(CharSet: AnsiString; SQLDialect: integer); virtual; abstract;
55 property Owner: TTestManager read FOwner;
56 end;
57
58 TTest = class of TTestBase;
59
60 { TTestManager }
61
62 TTestManager = class
63 private
64 FTests: TList;
65 FServer: AnsiString;
66 FPortNo: AnsiString;
67 FEmployeeDatabaseName: AnsiString;
68 FNewDatabaseName: AnsiString;
69 FSecondNewDatabaseName: AnsiString;
70 FUserName: AnsiString;
71 FPassword: AnsiString;
72 FBackupFileName: AnsiString;
73 FShowStatistics: boolean;
74 procedure CleanUp;
75 public
76 constructor Create;
77 destructor Destroy; override;
78 function GetUserName: AnsiString;
79 function GetPassword: AnsiString;
80 function GetEmployeeDatabaseName: AnsiString;
81 function GetNewDatabaseName: AnsiString;
82 function GetSecondNewDatabaseName: AnsiString;
83 function GetBackupFileName: AnsiString;
84 procedure RunAll;
85 procedure Run(TestID: integer);
86 procedure SetUserName(aValue: AnsiString);
87 procedure SetPassword(aValue: AnsiString);
88 procedure SetEmployeeDatabaseName(aValue: AnsiString);
89 procedure SetNewDatabaseName(aValue: AnsiString);
90 procedure SetSecondNewDatabaseName(aValue: AnsiString);
91 procedure SetBackupFileName(aValue: AnsiString);
92 property ShowStatistics: boolean read FShowStatistics write FShowStatistics;
93 property Server: AnsiString read FServer;
94 end;
95
96 var
97 TestMgr: TTestManager = nil;
98
99 var OutFile: text;
100
101 procedure RegisterTest(aTest: TTest);
102
103 implementation
104
105 uses IBUtils
106 {$IFDEF MSWINDOWS}
107 , windows;
108
109 function GetTempDir: AnsiString;
110 var
111 tempFolder: array[0..MAX_PATH] of Char;
112 begin
113 GetTempPath(MAX_PATH, @tempFolder);
114 result := StrPas(tempFolder);
115 end;
116 {$ELSE}
117 ;
118 {$ENDIF}
119
120 procedure RegisterTest(aTest: TTest);
121 begin
122 if TestMgr = nil then
123 TestMgr := TTestManager.Create;
124 TestMgr.FTests.Add(aTest.Create(TestMgr));
125 end;
126
127 { TTestBase }
128
129 constructor TTestBase.Create(aOwner: TTestManager);
130 begin
131 inherited Create;
132 FOwner := aOwner;
133 end;
134
135 function TTestBase.ExtractDBName(ConnectString: AnsiString): AnsiString;
136 var ServerName: AnsiString;
137 Protocol: TProtocolAll;
138 PortNo: AnsiString;
139 i: integer;
140 begin
141 if not ParseConnectString(ConnectString, ServerName, Result, Protocol,PortNo) then
142 begin
143 {assume either inet format (remote) or localhost}
144 Result := ConnectString;
145 if Pos('inet',Result) = 1 then
146 begin
147 system.Delete(Result,1,7);
148 i := Pos('/',Result);
149 if i > 0 then
150 system.delete(Result,1,i);
151 end
152 else
153 if Pos('localhost:',Result) = 1 then
154 system.Delete(Result,1,10)
155 end;
156 end;
157
158 function TTestBase.ReportResults(Statement: IStatement): IResultSet;
159 begin
160 Result := Statement.OpenCursor;
161 try
162 while Result.FetchNext do
163 ReportResult(Result);
164 finally
165 Result.Close;
166 end;
167 writeln(OutFile);
168 end;
169
170 procedure TTestBase.ReportResult(aValue: IResults);
171 var i: integer;
172 s: AnsiString;
173 begin
174 for i := 0 to aValue.getCount - 1 do
175 begin
176 if aValue[i].IsNull then
177 writeln(OutFile,aValue[i].Name,' = NULL')
178 else
179 case aValue[i].SQLType of
180 SQL_ARRAY:
181 begin
182 if not aValue[i].IsNull then
183 WriteArray(aValue[i].AsArray);
184 end;
185 SQL_FLOAT,SQL_DOUBLE,
186 SQL_D_FLOAT:
187 writeln(OutFile, aValue[i].Name,' = ',FormatFloat('#,##0.00',aValue[i].AsFloat));
188
189 SQL_INT64:
190 if aValue[i].Scale <> 0 then
191 writeln(OutFile, aValue[i].Name,' = ',FormatFloat('#,##0.00',aValue[i].AsFloat))
192 else
193 writeln(OutFile,aValue[i].Name,' = ',aValue[i].AsString);
194
195 SQL_BLOB:
196 if aValue[i].IsNull then
197 writeln(OutFile,aValue[i].Name,' = (null blob)')
198 else
199 if aValue[i].SQLSubType = 1 then
200 begin
201 s := aValue[i].AsString;
202 if FHexStrings then
203 begin
204 write(OutFile,aValue[i].Name,' = ');
205 PrintHexString(s);
206 writeln(OutFile,' (Charset Id = ',aValue[i].GetCharSetID, ' Codepage = ',StringCodePage(s),')');
207 end
208 else
209 begin
210 writeln(OutFile,aValue[i].Name,' (Charset Id = ',aValue[i].GetCharSetID, ' Codepage = ',StringCodePage(s),')');
211 writeln(OutFile);
212 writeln(OutFile,s);
213 end
214 end
215 else
216 writeln(OutFile,aValue[i].Name,' = (blob), Length = ',aValue[i].AsBlob.GetBlobSize);
217
218 SQL_TEXT,SQL_VARYING:
219 begin
220 if aValue[i].GetCharSetID = 1 then
221 s := aValue[i].AsString
222 else
223 s := Trim(aValue[i].AsString);
224 if FHexStrings then
225 begin
226 write(OutFile,aValue[i].Name,' = ');
227 PrintHexString(s);
228 writeln(OutFile,' (Charset Id = ',aValue[i].GetCharSetID, ' Codepage = ',StringCodePage(s),
229 ' Byte Length = ',Length(aValue[i].AsString),')');
230 end
231 else
232 if aValue[i].GetCharSetID > 0 then
233 writeln(OutFile,aValue[i].Name,' = ',s,' (Charset Id = ',aValue[i].GetCharSetID, ' Codepage = ',StringCodePage(s),
234 ' Byte Length = ',Length(aValue[i].AsString), ')')
235 else
236 writeln(OutFile,aValue[i].Name,' = ',s);
237 end;
238
239 else
240 writeln(OutFile,aValue[i].Name,' = ',aValue[i].AsString);
241 end;
242 end;
243 end;
244
245 procedure TTestBase.PrintHexString(s: AnsiString);
246 var i: integer;
247 begin
248 for i := 1 to length(s) do
249 write(OutFile,Format('%x ',[byte(s[i])]));
250 end;
251
252 procedure TTestBase.PrintDPB(DPB: IDPB);
253 var i: integer;
254 begin
255 writeln(OutFile,'DPB');
256 writeln(OutFile,'Count = ', DPB.getCount);
257 for i := 0 to DPB.getCount - 1 do
258 writeln(OutFile,DPB[i].getParamType,' = ', DPB[i].AsString);
259 writeln(OutFile);
260 end;
261
262 procedure TTestBase.PrintMetaData(meta: IMetaData);
263 var i, j: integer;
264 ar: IArrayMetaData;
265 bm: IBlobMetaData;
266 Bounds: TArrayBounds;
267 begin
268 writeln(OutFile,'Metadata');
269 for i := 0 to meta.GetCount - 1 do
270 with meta[i] do
271 begin
272 writeln(OutFile,'SQLType =',GetSQLTypeName);
273 writeln(OutFile,'sub type = ',getSubType);
274 writeln(OutFile,'Table = ',getRelationName);
275 writeln(OutFile,'Owner = ',getOwnerName);
276 writeln(OutFile,'Column Name = ',getSQLName);
277 writeln(OutFile,'Alias Name = ',getAliasName);
278 writeln(OutFile,'Field Name = ',getName);
279 writeln(OutFile,'Scale = ',getScale);
280 writeln(OutFile,'Charset id = ',getCharSetID);
281 if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
282 writeln(OutFile,'Size = ',GetSize);
283 case getSQLType of
284 SQL_ARRAY:
285 begin
286 writeln(OutFile,'Array Meta Data:');
287 ar := GetArrayMetaData;
288 writeln(OutFile,'SQLType =',ar.GetSQLTypeName);
289 writeln(OutFile,'Scale = ',ar.getScale);
290 writeln(OutFile,'Charset id = ',ar.getCharSetID);
291 writeln(OutFile,'Size = ',ar.GetSize);
292 writeln(OutFile,'Table = ',ar.GetTableName);
293 writeln(OutFile,'Column = ',ar.GetColumnName);
294 writeln(OutFile,'Dimensions = ',ar.GetDimensions);
295 write(OutFile,'Bounds: ');
296 Bounds := ar.GetBounds;
297 for j := 0 to Length(Bounds) - 1 do
298 write(OutFile,'(',Bounds[j].LowerBound,':',Bounds[j].UpperBound,') ');
299 writeln(OutFile);
300 end;
301 SQL_BLOB:
302 begin
303 writeln(OutFile);
304 writeln(OutFile,'Blob Meta Data');
305 bm := GetBlobMetaData;
306 writeln(OutFile,'SQL SubType =',bm.GetSubType);
307 writeln(OutFile,'Table = ',bm.GetRelationName);
308 writeln(OutFile,'Column = ',bm.GetColumnName);
309 writeln(OutFile,'CharSetID = ',bm.GetCharSetID);
310 writeln(OutFile,'Segment Size = ',bm.GetSegmentSize);
311 writeln(OutFile);
312 end;
313 end;
314 writeln(OutFile);
315 end;
316 end;
317
318 procedure TTestBase.ParamInfo(SQLParams: ISQLParams);
319 var i: integer;
320 begin
321 writeln(OutFile,'SQL Params');
322 for i := 0 to SQLParams.Count - 1 do
323 with SQLParams[i] do
324 begin
325 writeln(OutFile,'SQLType =',GetSQLTypeName);
326 writeln(OutFile,'sub type = ',getSubType);
327 writeln(OutFile,'Field Name = ',getName);
328 writeln(OutFile,'Scale = ',getScale);
329 writeln(OutFile,'Charset id = ',getCharSetID);
330 if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
331 writeln(OutFile,'Size = ',GetSize);
332 writeln(OutFile);
333 end;
334 end;
335
336 procedure TTestBase.WriteArray(ar: IArray);
337 var Bounds: TArrayBounds;
338 i,j: integer;
339 begin
340 write(OutFile,'Array: ');
341 Bounds := ar.GetBounds;
342 case ar.GetDimensions of
343 1:
344 begin
345 for i := Bounds[0].LowerBound to Bounds[0].UpperBound do
346 write(OutFile,'(',i,': ',ar.GetAsVariant([i]),') ');
347 end;
348
349 2:
350 begin
351 for i := Bounds[0].LowerBound to Bounds[0].UpperBound do
352 for j := Bounds[1].LowerBound to Bounds[1].UpperBound do
353 write(OutFile,'(',i,',',j,': ',ar.GetAsVariant([i,j]),') ');
354 end;
355 end;
356 writeln(OutFile);
357 end;
358
359 procedure TTestBase.WriteAffectedRows(Statement: IStatement);
360 var SelectCount, InsertCount, UpdateCount, DeleteCount: integer;
361 begin
362 Statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount);
363 writeln(OutFile,'Select Count = ', SelectCount,' InsertCount = ',InsertCount,' UpdateCount = ', UpdateCount, ' DeleteCount = ',DeleteCount);
364 end;
365
366 function TTestBase.WriteServiceQueryResult(QueryResult: IServiceQueryResults): boolean;
367 var i: integer;
368 line: AnsiString;
369 begin
370 Result := true;
371 for i := 0 to QueryResult.GetCount - 1 do
372 with QueryResult[i] do
373 case getItemType of
374 isc_info_svc_version:
375 writeln(OutFile,'Service Manager Version = ',getAsInteger);
376 isc_info_svc_server_version:
377 writeln(OutFile,'Server Version = ',getAsString);
378 isc_info_svc_implementation:
379 writeln(OutFile,'Implementation = ',getAsString);
380 isc_info_svc_get_license:
381 writeLicence(QueryResult[i]);
382 isc_info_svc_get_license_mask:
383 writeln(OutFile,'Licence Mask = ',getAsInteger);
384 isc_info_svc_capabilities:
385 writeln(OutFile,'Capabilities = ',getAsInteger);
386 isc_info_svc_get_config:
387 WriteConfig(QueryResult[i]);
388 isc_info_svc_get_env:
389 writeln(OutFile,'Root Directory = ',getAsString);
390 isc_info_svc_get_env_lock:
391 writeln(OutFile,'Lock Directory = ',getAsString);
392 isc_info_svc_get_env_msg:
393 writeln(OutFile,'Message File = ',getAsString);
394 isc_info_svc_user_dbpath:
395 writeln(OutFile,'Security File = ',getAsString);
396 isc_info_svc_get_licensed_users:
397 writeln(OutFile,'Max Licenced Users = ',getAsInteger);
398 isc_info_svc_get_users:
399 WriteUsers(QueryResult[i]);
400 isc_info_svc_svr_db_info:
401 WriteDBAttachments(QueryResult[i]);
402 isc_info_svc_line:
403 begin
404 line := getAsString;
405 writeln(OutFile,line);
406 Result := line <> '';
407 end;
408 isc_info_svc_running:
409 writeln(OutFile,'Is Running = ',getAsInteger);
410 isc_info_svc_limbo_trans:
411 WriteLimboTransactions(QueryResult[i]);
412 isc_info_svc_to_eof,
413 isc_info_svc_timeout,
414 isc_info_truncated,
415 isc_info_data_not_ready,
416 isc_info_svc_stdin:
417 {ignore};
418 else
419 writeln(OutFile,'Unknown Service Response Item ', getItemType);
420 end;
421 writeln(OutFile);
422 end;
423
424 procedure TTestBase.writeLicence(Item: IServiceQueryResultItem);
425 var i: integer;
426 begin
427 for i := 0 to Item.getCount - 1 do
428 with Item[i] do
429 case getItemType of
430 isc_spb_lic_id:
431 writeln(OutFile,'Licence ID = ',GetAsString);
432 isc_spb_lic_key:
433 writeln(OutFile,'Licence Key = ',GetAsString);
434 end;
435 end;
436
437 procedure TTestBase.WriteConfig(config: IServiceQueryResultItem);
438 var i: integer;
439 begin
440 writeln(OutFile,'Firebird Configuration File');
441 for i := 0 to config.getCount - 1 do
442 writeln(OutFile,'Key = ',config[i].getItemType,', Value = ',config[i].getAsInteger);
443 writeln(OutFile);
444 end;
445
446 procedure TTestBase.WriteUsers(users: IServiceQueryResultItem);
447 var i: integer;
448 begin
449 writeln(OutFile,'Sec. Database User');
450 for i := 0 to users.getCount - 1 do
451 with users[i] do
452 case getItemType of
453 isc_spb_sec_username:
454 writeln(OutFile,'User Name = ',getAsString);
455 isc_spb_sec_firstname:
456 writeln(OutFile,'First Name = ',getAsString);
457 isc_spb_sec_middlename:
458 writeln(OutFile,'Middle Name = ',getAsString);
459 isc_spb_sec_lastname:
460 writeln(OutFile,'Last Name = ',getAsString);
461 isc_spb_sec_userid:
462 writeln(OutFile,'User ID = ',getAsInteger);
463 isc_spb_sec_groupid:
464 writeln(OutFile,'Group ID = ',getAsInteger);
465 else
466 writeln(OutFile,'Unknown user info ', getItemType);
467 end;
468 writeln(OutFile);
469 end;
470
471 procedure TTestBase.WriteDBAttachments(att: IServiceQueryResultItem);
472 var i: integer;
473 begin
474 writeln(OutFile,'DB Attachments');
475 for i := 0 to att.getCount - 1 do
476 with att[i] do
477 case getItemType of
478 isc_spb_num_att:
479 writeln(OutFile,'No. of Attachments = ',getAsInteger);
480 isc_spb_num_db:
481 writeln(OutFile,'Databases In Use = ',getAsInteger);
482 isc_spb_dbname:
483 writeln(OutFile,'DB Name = ',getAsString);
484 end;
485 end;
486
487 procedure TTestBase.WriteLimboTransactions(limbo: IServiceQueryResultItem);
488 var i: integer;
489 begin
490 writeln(OutFile,'Limbo Transactions');
491 for i := 0 to limbo.getCount - 1 do
492 with limbo[i] do
493 case getItemType of
494 isc_spb_single_tra_id:
495 writeln(OutFile,'Single DB Transaction = ',getAsInteger);
496 isc_spb_multi_tra_id:
497 writeln(OutFile,'Multi DB Transaction = ',getAsInteger);
498 isc_spb_tra_host_site:
499 writeln(OutFile,'Host Name = ',getAsString);
500 isc_spb_tra_advise:
501 writeln(OutFile,'Resolution Advisory = ',getAsInteger);
502 isc_spb_tra_remote_site:
503 writeln(OutFile,'Server Name = ',getAsString);
504 isc_spb_tra_db_path:
505 writeln(OutFile,'DB Primary File Name = ',getAsString);
506 isc_spb_tra_state:
507 begin
508 write(OutFile,'State = ');
509 case getAsInteger of
510 isc_spb_tra_state_limbo:
511 writeln(OutFile,'limbo');
512 isc_spb_tra_state_commit:
513 writeln(OutFile,'commit');
514 isc_spb_tra_state_rollback:
515 writeln(OutFile,'rollback');
516 isc_spb_tra_state_unknown:
517 writeln(OutFile,'Unknown');
518 end;
519 end;
520 end;
521 end;
522
523 procedure TTestBase.WriteDBInfo(DBInfo: IDBInformation);
524 var i, j: integer;
525 bytes: TByteArray;
526 ConType: integer;
527 DBFileName: AnsiString;
528 DBSiteName: AnsiString;
529 Version: byte;
530 VersionString: AnsiString;
531 Users: TStringList;
532 begin
533 for i := 0 to DBInfo.GetCount - 1 do
534 with DBInfo[i] do
535 case getItemType of
536 isc_info_db_read_only:
537 if getAsInteger <> 0 then
538 writeln(OutFile,'Database is Read Only')
539 else
540 writeln(OutFile,'Database is Read/Write');
541 isc_info_allocation:
542 writeln(OutFile,'Pages =',getAsInteger);
543 isc_info_base_level:
544 begin
545 bytes := getAsBytes;
546 write(OutFile,'Base Level = ');
547 WriteBytes(Bytes);
548 end;
549 isc_info_db_id:
550 begin
551 DecodeIDCluster(ConType,DBFileName,DBSiteName);
552 writeln(OutFile,'Database ID = ', ConType,' FB = ', DBFileName, ' SN = ',DBSiteName);
553 end;
554 isc_info_implementation:
555 begin
556 bytes := getAsBytes;
557 write(OutFile,'Implementation = ');
558 WriteBytes(Bytes);
559 end;
560 isc_info_no_reserve:
561 writeln(OutFile,'Reserved = ',getAsInteger);
562 isc_info_ods_minor_version:
563 writeln(OutFile,'ODS minor = ',getAsInteger);
564 isc_info_ods_version:
565 writeln(OutFile,'ODS major = ',getAsInteger);
566 isc_info_page_size:
567 writeln(OutFile,'Page Size = ',getAsInteger);
568 isc_info_version:
569 begin
570 DecodeVersionString(Version,VersionString);
571 writeln(OutFile,'Version = ',Version,': ',VersionString);
572 end;
573 isc_info_current_memory:
574 writeln(OutFile,'Server Memory = ',getAsInteger);
575 isc_info_forced_writes:
576 writeln(OutFile,'Forced Writes = ',getAsInteger);
577 isc_info_max_memory:
578 writeln(OutFile,'Max Memory = ',getAsInteger);
579 isc_info_num_buffers:
580 writeln(OutFile,'Num Buffers = ',getAsInteger);
581 isc_info_sweep_interval:
582 writeln(OutFile,'Sweep Interval = ',getAsInteger);
583 isc_info_user_names:
584 begin
585 Users := TStringList.Create;
586 try
587 write(OutFile,'Logged in Users: ');
588 DecodeUserNames(Users);
589 for j := 0 to Users.Count - 1 do
590 write(OutFile,Users[j],',');
591
592 finally
593 Users.Free;
594 end;
595 writeln(OutFile);
596 end;
597 isc_info_fetches:
598 writeln(OutFile,'Fetches = ',getAsInteger);
599 isc_info_marks:
600 writeln(OutFile,'Writes = ',getAsInteger);
601 isc_info_reads:
602 writeln(OutFile,'Reads = ',getAsInteger);
603 isc_info_writes:
604 writeln(OutFile,'Page Writes = ',getAsInteger);
605 isc_info_backout_count:
606 WriteOperationCounts('Record Version Removals',getOperationCounts);
607 isc_info_delete_count:
608 WriteOperationCounts('Deletes',getOperationCounts);
609 isc_info_expunge_count:
610 WriteOperationCounts('Expunge Count',getOperationCounts);
611 isc_info_insert_count:
612 WriteOperationCounts('Insert Count',getOperationCounts);
613 isc_info_purge_count:
614 WriteOperationCounts('Purge Count Countites',getOperationCounts);
615 isc_info_read_idx_count:
616 WriteOperationCounts('Indexed Reads Count',getOperationCounts);
617 isc_info_read_seq_count:
618 WriteOperationCounts('Sequential Table Scans',getOperationCounts);
619 isc_info_update_count:
620 WriteOperationCounts('Update Count',getOperationCounts);
621 isc_info_db_SQL_Dialect:
622 writeln(OutFile,'SQL Dialect = ',getAsInteger);
623 isc_info_creation_date:
624 writeln(OutFile,'Database Created: ',DateTimeToStr(getAsDateTime));
625 isc_info_active_tran_count:
626 writeln(OutFile,'Active Transaction Count = ',getAsInteger);
627 fb_info_page_contents:
628 begin
629 writeln('Database Page');
630 PrintHexString(getAsString);
631 writeln;
632 end;
633 fb_info_pages_used:
634 writeln(OutFile,'Pages Used = ',getAsInteger);
635 fb_info_pages_free:
636 writeln(OutFile,'Pages Free = ',getAsInteger);
637
638 isc_info_truncated:
639 writeln(OutFile,'Results Truncated');
640 else
641 writeln(OutFile,'Unknown Response ',getItemType);
642 end;
643 end;
644
645 procedure TTestBase.WriteBytes(Bytes: TByteArray);
646 var i: integer;
647 begin
648 for i := 0 to length(Bytes) - 1 do
649 write(OutFile,Bytes[i],',');
650 writeln(OutFile);
651 end;
652
653 procedure TTestBase.WriteOperationCounts(Category: AnsiString;
654 ops: TDBOperationCounts);
655 var i: integer;
656 begin
657 writeln(OutFile,Category,' Operation Counts');
658 for i := 0 to Length(ops) - 1 do
659 begin
660 writeln(OutFile,'Table ID = ',ops[i].TableID);
661 writeln(OutFile,'Count = ',ops[i].Count);
662 end;
663 writeln(OutFile);
664 end;
665
666 procedure TTestBase.WritePerfStats(stats: TPerfCounters);
667 begin
668 writeln(OutFile,'Current memory = ', stats[psCurrentMemory]);
669 writeln(OutFile,'Delta memory = ', stats[psDeltaMemory]);
670 writeln(OutFile,'Max memory = ', stats[psMaxMemory]);
671 writeln(OutFile,'Elapsed time= ', FormatFloat('#0.000',stats[psRealTime]/1000),' sec');
672 writeln(OutFile,'Cpu = ', FormatFloat('#0.000',stats[psUserTime]/1000),' sec');
673 writeln(OutFile,'Buffers = ', stats[psBuffers]);
674 writeln(OutFile,'Reads = ', stats[psReads]);
675 writeln(OutFile,'Writes = ', stats[psWrites]);
676 writeln(OutFile,'Fetches = ', stats[psFetches]);
677 end;
678
679 procedure TTestBase.CheckActivity(Attachment: IAttachment);
680 begin
681 writeln(OutFile,'Database Activity = ',Attachment.HasActivity)
682 end;
683
684 procedure TTestBase.CheckActivity(Transaction: ITransaction);
685 begin
686 writeln(OutFile,'Transaction Activity = ',Transaction.HasActivity)
687 end;
688
689 { TTestManager }
690
691 procedure TTestManager.CleanUp;
692 var DPB: IDPB;
693 Attachment: IAttachment;
694 begin
695 DPB := FirebirdAPI.AllocateDPB;
696 DPB.Add(isc_dpb_user_name).setAsString(GetUserName);
697 DPB.Add(isc_dpb_password).setAsString(GetPassword);
698 Attachment := FirebirdAPI.OpenDatabase(GetNewDatabaseName,DPB,false);
699 if Attachment <> nil then
700 Attachment.DropDatabase;
701 Attachment := FirebirdAPI.OpenDatabase(GetSecondNewDatabaseName,DPB,false);
702 if Attachment <> nil then
703 Attachment.DropDatabase;
704 end;
705
706 constructor TTestManager.Create;
707 begin
708 inherited Create;
709 FTests := TList.Create;
710 FNewDatabaseName := GetTempDir + 'fbtestsuite.fdb';
711 FSecondNewDatabaseName := GetTempDir + 'fbtestsuite2.fdb';
712 FUserName := 'SYSDBA';
713 FPassword := 'masterkey';
714 FEmployeeDatabaseName := 'employee';
715 FBackupFileName := GetTempDir + 'testbackup.gbk';
716 FServer := 'localhost';
717 end;
718
719 destructor TTestManager.Destroy;
720 var i: integer;
721 begin
722 if assigned(FTests) then
723 begin
724 for i := 0 to FTests.Count - 1 do
725 TObject(FTests[i]).Free;
726 FTests.Free;
727 end;
728 inherited Destroy;
729 end;
730
731 function TTestManager.GetUserName: AnsiString;
732 begin
733 Result := FUserName;
734 end;
735
736 function TTestManager.GetPassword: AnsiString;
737 begin
738 Result := FPassword;
739 end;
740
741 function TTestManager.GetEmployeeDatabaseName: AnsiString;
742 begin
743 if FirebirdAPI.GetClientMajor < 3 then
744 Result := MakeConnectString(FServer, FEmployeeDatabaseName, TCP,FPortNo)
745 else
746 Result := MakeConnectString(FServer, FEmployeeDatabaseName, inet,FPortNo);
747 end;
748
749 function TTestManager.GetNewDatabaseName: AnsiString;
750 begin
751 if FirebirdAPI.GetClientMajor < 3 then
752 Result := MakeConnectString(FServer, FNewDatabaseName, TCP,FPortNo)
753 else
754 Result := MakeConnectString(FServer, FNewDatabaseName, inet,FPortNo);
755 end;
756
757 function TTestManager.GetSecondNewDatabaseName: AnsiString;
758 begin
759 if FirebirdAPI.GetClientMajor < 3 then
760 Result := MakeConnectString(FServer, FSecondNewDatabaseName, TCP,FPortNo)
761 else
762 Result := MakeConnectString(FServer, FSecondNewDatabaseName, inet,FPortNo);
763 end;
764
765 function TTestManager.GetBackupFileName: AnsiString;
766 begin
767 Result := FBackupFileName;
768 end;
769
770 procedure TTestManager.RunAll;
771 var i: integer;
772 begin
773 CleanUP;
774 for i := 0 to FTests.Count - 1 do
775 with TTestBase(FTests[i]) do
776 begin
777 writeln(OutFile,'Running ' + TestTitle);
778 writeln(ErrOutput,'Running ' + TestTitle);
779 try
780 RunTest('UTF8',3);
781 except on E:Exception do
782 begin
783 writeln(OutFile,'Test Completed with Error: ' + E.Message);
784 Exit;
785 end;
786 end;
787 writeln(OutFile);
788 writeln(OutFile);
789 end;
790 end;
791
792 procedure TTestManager.Run(TestID: integer);
793 begin
794 CleanUp;
795 if (TestID <= 0 ) or (TestID > FTests.Count) then
796 begin
797 writeln(OutFile,'Invalid Test ID - ',TestID);
798 Exit;
799 end;
800 with TTestBase(FTests[TestID-1]) do
801 begin
802 writeln(OutFile,'Running ' + TestTitle);
803 writeln(ErrOutput,'Running ' + TestTitle);
804 try
805 RunTest('UTF8',3);
806 except on E:Exception do
807 begin
808 writeln(OutFile,'Test Completed with Error: ' + E.Message);
809 Exit;
810 end;
811 end;
812 writeln(OutFile);
813 writeln(OutFile);
814 end;
815 end;
816
817 procedure TTestManager.SetUserName(aValue: AnsiString);
818 begin
819 FUserName := aValue;
820 end;
821
822 procedure TTestManager.SetPassword(aValue: AnsiString);
823 begin
824 FPassword := aValue;
825 end;
826
827 procedure TTestManager.SetEmployeeDatabaseName(aValue: AnsiString);
828 begin
829 FEmployeeDatabaseName := aValue;
830 end;
831
832 procedure TTestManager.SetNewDatabaseName(aValue: AnsiString);
833 begin
834 FNewDatabaseName := aValue;
835 end;
836
837 procedure TTestManager.SetSecondNewDatabaseName(aValue: AnsiString);
838 begin
839 FSecondNewDatabaseName := aValue;
840 end;
841
842 procedure TTestManager.SetBackupFileName(aValue: AnsiString);
843 begin
844 FBackupFileName := aValue;
845 end;
846
847 end.
848