ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/testsuite/testApp/TestApplication.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/testsuite/testApp/TestApplication.pas
File size: 37138 byte(s)
Log Message:
Updated for IBX 4 release

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