ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/testsuite/testApp/TestApplication.pas
(Generate patch)

Comparing:
ibx/trunk/testsuite/testApp/TestApplication.pas (file contents), Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC vs.
ibx/branches/journaling/testsuite/testApp/TestApplication.pas (file contents), Revision 363 by tony, Tue Dec 7 13:30:05 2021 UTC

# Line 77 | Line 77 | type
77    TTestBase = class
78    private
79      FOwner: TTestApplication;
80 +    FFloatTpl: AnsiString;
81 +    FCursorSeq: integer;
82      function GetFirebirdAPI: IFirebirdAPI;
83      procedure SetOwner(AOwner: TTestApplication);
84 +    procedure HandleOnJnlEntry(JnlEntry: TJnlEntry);
85    protected
86      FHexStrings: boolean;
87 +    FShowBinaryBlob: boolean;
88      procedure DumpBCD(bcd: tBCD);
89      procedure ClientLibraryPathChanged; virtual;
90      procedure CreateObjects(Application: TTestApplication); virtual;
# Line 93 | Line 97 | type
97      procedure PrintSPB(SPB: ISPB);
98      procedure PrintMetaData(meta: IMetaData);
99      procedure ParamInfo(SQLParams: ISQLParams);
100 <    function ReportResults(Statement: IStatement): IResultSet;
100 >    procedure PrintJournalFile(aFileName: AnsiString);
101 >    procedure PrintJournalTable(Attachment: IAttachment);
102 >    function ReportResults(Statement: IStatement; ShowCursorName: boolean=false): IResultSet;
103      procedure ReportResult(aValue: IResults);
104      function StringToHex(octetString: string; MaxLineLength: integer=0): string;
105 +    procedure WriteAttachmentInfo(Attachment: IAttachment);
106      procedure WriteArray(ar: IArray);
107      procedure WriteAffectedRows(Statement: IStatement);
108      procedure WriteDBInfo(DBInfo: IDBInformation);
109 +    procedure WriteTRInfo(TrInfo: ITrInformation);
110      procedure WriteBytes(Bytes: TByteArray);
111      procedure WriteOperationCounts(Category: AnsiString; ops: TDBOperationCounts);
112      procedure WritePerfStats(stats: TPerfCounters);
# Line 108 | Line 116 | type
116      procedure InitTest; virtual;
117      function SkipTest: boolean; virtual;
118      procedure ProcessResults; virtual;
119 +    procedure SetFloatTemplate(tpl: Ansistring);
120    public
121      constructor Create(aOwner: TTestApplication);  virtual;
122      function ChildProcess: boolean; virtual;
# Line 173 | Line 182 | type
182      function GetPassword: AnsiString;
183      function GetEmployeeDatabaseName: AnsiString;
184      function GetNewDatabaseName: AnsiString;
185 +    function GetTempDatabaseName: AnsiString;
186      function GetSecondNewDatabaseName: AnsiString;
187      function GetBackupFileName: AnsiString;
188      procedure RunAll;
# Line 186 | Line 196 | type
196      property Quiet: boolean read FQuiet;
197    end;
198  
199 +  { TMsgHash }
200 +
201 +  TMsgHash = class
202 +  private
203 +    FFinalised: boolean;
204 +  protected
205 +    procedure CheckNotFinalised;
206 +  public
207 +    procedure AddText(aText: AnsiString); virtual; abstract;
208 +    procedure Finalise; virtual;
209 +    function SameHash(otherHash: TMsgHash): boolean;
210 +    function Digest: AnsiString; virtual; abstract;
211 +    class function CreateMsgHash: TMsgHash;
212 +    property Finalised: boolean read FFinalised;
213 +  end;
214 +
215    ESkipException = class(Exception);
216  
217   var
# Line 197 | Line 223 | procedure RegisterTest(aTest: TTest);
223  
224   implementation
225  
226 + {$IFNDEF MSWINDOWS}
227 + uses MD5;
228 + {$ENDIF}
229 +
230   {$IFDEF MSWINDOWS}
231 < uses windows;
231 > uses {$IFDEF FPC}MD5,{$ENDIF} windows;
232  
233   function GetTempDir: AnsiString;
234   var
# Line 219 | Line 249 | begin
249   //    test.CreateObjects(TestApp);
250   end;
251  
252 + {$IFDEF FPC}
253 + type
254 +
255 +  { TMD5MsgHash }
256 +
257 +  TMD5MsgHash = class(TMsgHash)
258 +  private
259 +    FMD5Context: TMDContext;
260 +    FDigest: TMDDigest;
261 +  public
262 +    constructor Create;
263 +    procedure AddText(aText: AnsiString); override;
264 +    procedure Finalise; override;
265 +    function Digest: AnsiString; override;
266 +  end;
267 +
268 + {$DEFINE MSG_HASH_AVAILABLE}
269 +
270 + { TMD5MsgHash }
271 +
272 + constructor TMD5MsgHash.Create;
273 + begin
274 +  inherited Create;
275 +  MDInit(FMD5Context,MD_VERSION_5);
276 + end;
277 +
278 + procedure TMD5MsgHash.AddText(aText: AnsiString);
279 + begin
280 +  CheckNotFinalised;
281 +  MDUpdate(FMD5Context,PAnsiChar(aText)^,Length(aText));
282 + end;
283 +
284 + procedure TMD5MsgHash.Finalise;
285 + begin
286 +  CheckNotFinalised;
287 +  MDFinal(FMD5Context,FDigest);
288 +  inherited Finalise;
289 + end;
290 +
291 + function TMD5MsgHash.Digest: AnsiString;
292 + begin
293 +  if not FFinalised then
294 +    Finalise;
295 +  Result :=  MD5Print(FDigest);
296 + end;
297 +
298 + class function TMsgHash.CreateMsgHash: TMsgHash;
299 + begin
300 +  Result := TMD5MsgHash.Create;
301 + end;
302 + {$ENDIF}
303 +
304 + {$IFNDEF MSG_HASH_AVAILABLE}
305 + type
306 +
307 +  { TSimpleMsgHash }
308 +
309 +  TSimpleMsgHash = class(TMsgHash)
310 +  private
311 +    FDigest: Int64;
312 +    Finalised: boolean;
313 +  public
314 +    procedure AddText(aText: AnsiString); override;
315 +    function Digest: AnsiString; override;
316 +  end;
317 +
318 + { TSimpleMsgHash }
319 +
320 + procedure TSimpleMsgHash.AddText(aText: AnsiString);
321 + const
322 +  modulus = high(Int64) div 100;
323 + var i: integer;
324 + begin
325 +  CheckNotFinalised;
326 +  for i := 1 to length(aText) do
327 +    FDigest := (FDigest * 7 + ord(aText[i])) mod modulus;
328 + end;
329 +
330 + function TSimpleMsgHash.Digest: AnsiString;
331 + begin
332 +  if not Finalised then
333 +    Finalise;
334 +  Result := IntToStr(FDigest);
335 + end;
336 +
337 + class function TMsgHash.CreateMsgHash: TMsgHash;
338 + begin
339 +  Result := TSimpleMsgHash.Create;
340 + end;
341 +
342 + {$ENDIF}
343 +
344 + procedure TMsgHash.CheckNotFinalised;
345 + begin
346 +  if FFinalised then
347 +    raise Exception.Create('Digest has been finalised');
348 + end;
349 +
350 + procedure TMsgHash.Finalise;
351 + begin
352 +  FFinalised := true;
353 + end;
354 +
355 + function TMsgHash.SameHash(otherHash: TMsgHash): boolean;
356 + begin
357 +  Result := Digest = OtherHash.Digest;
358 + end;
359 +
360   { TTestBase }
361  
362   constructor TTestBase.Create(aOwner: TTestApplication);
363   begin
364    inherited Create;
365    FOwner := aOwner;
366 +  FFloatTpl := '#,###.00';
367   end;
368  
369   function TTestBase.ChildProcess: boolean;
# Line 247 | Line 386 | begin
386    FOwner := AOwner;
387   end;
388  
389 + procedure TTestBase.HandleOnJnlEntry(JnlEntry: TJnlEntry);
390 + begin
391 + with JnlEntry do
392 + begin
393 +   {$IFNDEF FPC}
394 +   writeln(OutFile,'Journal Entry = ',ord(JnlEntryType),'(', TJournalProcessor.JnlEntryText(JnlEntryType),')');
395 +   {$ELSE}
396 +   writeln(OutFile,'Journal Entry = ',JnlEntryType,'(', TJournalProcessor.JnlEntryText(JnlEntryType),')');
397 +   {$ENDIF}
398 +   writeln(OutFIle,'Timestamp = ',FBFormatDateTime('yyyy/mm/dd hh:nn:ss.zzzz',Timestamp));
399 +   writeln(OutFile,'Session ID = ',SessionID);
400 +   writeln(OutFile,'Transaction ID = ',TransactionID);
401 +   case JnlEntry.JnlEntryType of
402 +   jeTransStart:
403 +     begin
404 +       writeln(OutFile,'Transaction Name = "',TransactionName,'"');
405 +       PrintTPB(TPB);
406 +       {$IFNDEF FPC}
407 +       writeln(OutFile,'Default Completion = ',ord(DefaultCompletion));
408 +       {$ELSE}
409 +       writeln(OutFile,'Default Completion = ',DefaultCompletion);
410 +       {$ENDIF}
411 +     end;
412 +
413 +   jeQuery:
414 +     begin
415 +       writeln(OutFile,'Query = ',QueryText);
416 +     end;
417 +
418 +   jeTransCommitRet,
419 +   jeTransRollbackRet:
420 +     writeln(Outfile,'Old TransactionID = ',OldTransactionID);
421 +   end;
422 + end;
423 + writeln(OutFile);
424 + end;
425 +
426   procedure TTestBase.DumpBCD(bcd: tBCD);
427   var i,l: integer;
428   begin
# Line 420 | Line 596 | begin
596      writeln(OutFile,'Charset id = ',getCharSetID);
597      if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
598      writeln(OutFile,'Size = ',GetSize);
599 +    if not IsNull then
600 +      writeln(Outfile,'Value = ',getAsString);
601      writeln(OutFile);
602    end;
603   end;
604  
605 < function TTestBase.ReportResults(Statement: IStatement): IResultSet;
605 > procedure TTestBase.PrintJournalFile(aFileName: AnsiString);
606 > begin
607 > writeln(OutFile,'Journal Entries');
608 > with TJournalProcessor.Create do
609 > try
610 >    Execute(aFileName,FirebirdAPI,HandleOnJnlEntry);
611 > finally
612 >   Free
613 > end;
614 > end;
615 >
616 > procedure TTestBase.PrintJournalTable(Attachment: IAttachment);
617 > var Results: IResultSet;
618 > begin
619 >  writeln(OutFile,'Journal Table');
620 >  Results := Attachment.OpenCursorAtStart('Select * From IBX$JOURNALS');
621 >  while not Results.IsEof do
622 >  begin
623 >    ReportResult(Results);
624 >    Results.Fetchnext;
625 >  end;
626 > end;
627 >
628 > function TTestBase.ReportResults(Statement: IStatement; ShowCursorName: boolean): IResultSet;
629   begin
630    Result := Statement.OpenCursor;
631    try
632 +   if ShowCursorName then
633 +      writeln(Outfile,'Results for Cursor: ',Result.GetCursorName);
634      while Result.FetchNext do
635        ReportResult(Result);
636    finally
# Line 479 | Line 682 | begin
682    end;
683   end;
684  
685 + procedure TTestBase.WriteAttachmentInfo(Attachment: IAttachment);
686 + begin
687 + writeln(outfile,'DB Connect String = ',Attachment.GetConnectString);
688 + writeln(outfile,'DB Charset ID = ',Attachment.GetDefaultCharSetID);
689 + writeln(outfile,'DB SQL Dialect = ',Attachment.GetSQLDialect);
690 + writeln(outfile,'DB Remote Protocol = ', Attachment.GetRemoteProtocol);
691 + writeln(outfile,'DB ODS Major Version = ',Attachment.GetODSMajorVersion);
692 + writeln(outfile,'DB ODS Minor Version = ',Attachment.GetODSMinorVersion);
693 + writeln(outfile,'User Authentication Method = ',Attachment.GetAuthenticationMethod);
694 + writeln(outfile,'Firebird Library Path = ',Attachment.getFirebirdAPI.GetFBLibrary.GetLibraryFilePath);
695 + writeln(outfile,'DB Client Implementation Version = ',Attachment.getFirebirdAPI.GetImplementationVersion);
696 + end;
697 +
698   procedure TTestBase.WriteArray(ar: IArray);
699   var Bounds: TArrayBounds;
700      i,j: integer;
# Line 632 | Line 848 | begin
848    end;
849   end;
850  
851 + procedure TTestBase.WriteTRInfo(TrInfo: ITrInformation);
852 + var IsolationType, RecVersion: byte;
853 +    i: integer;
854 +    access: integer;
855 + begin
856 + for i := 0 to TrInfo.GetCount - 1 do
857 + with TrInfo[i] do
858 + case getItemType of
859 +   isc_info_tra_id:
860 +     writeln(OutFile,'Transaction ID = ',getAsInteger);
861 +   isc_info_tra_oldest_interesting:
862 +     writeln(OutFile,'Oldest Interesting = ',getAsInteger);
863 +   isc_info_tra_oldest_active:
864 +     writeln(OutFile,'Oldest Action = ',getAsInteger);
865 +   isc_info_tra_oldest_snapshot:
866 +     writeln(OutFile,'Oldest Snapshot = ',getAsInteger);
867 +   fb_info_tra_snapshot_number:
868 +     writeln(OutFile,'Oldest Snapshot Number = ',getAsInteger);
869 +   isc_info_tra_lock_timeout:
870 +     writeln(OutFile,'Lock Timeout = ',getAsInteger);
871 +   isc_info_tra_isolation:
872 +     begin
873 +       DecodeTraIsolation(IsolationType, RecVersion);
874 +       write(OutFile,'Isolation Type = ');
875 +       case IsolationType of
876 +       isc_info_tra_consistency:
877 +         write(OutFile,'isc_info_tra_consistency');
878 +       isc_info_tra_concurrency:
879 +         write(OutFile,'isc_info_tra_concurrency');
880 +       isc_info_tra_read_committed:
881 +         begin
882 +          write(OutFile,'isc_info_tra_read_committed, Options =');
883 +          case RecVersion of
884 +          isc_info_tra_no_rec_version:
885 +            write(OutFile,'isc_info_tra_no_rec_version');
886 +          isc_info_tra_rec_version:
887 +            write(OutFile,'isc_info_tra_rec_version');
888 +          isc_info_tra_read_consistency:
889 +            write(OutFile,'isc_info_tra_read_consistency');
890 +          end;
891 +         end;
892 +       end;
893 +       writeln(OutFile);
894 +     end;
895 +   isc_info_tra_access:
896 +     begin
897 +       write(OutFile,'Transaction Access = ');
898 +       access :=  getAsInteger;
899 +       case access of
900 +       isc_info_tra_readonly:
901 +         writeln(OutFile,'isc_info_tra_readonly');
902 +       isc_info_tra_readwrite:
903 +         writeln(OutFile,'isc_info_tra_readwrite');
904 +       end;
905 +     end;
906 +   fb_info_tra_dbpath:
907 +     writeln(OutFile,'Transaction Database Path = ',getAsString);
908 + end;
909 +
910 + end;
911 +
912   procedure TTestBase.WriteBytes(Bytes: TByteArray);
913   var i: integer;
914   begin
# Line 699 | Line 976 | begin
976      end;
977    SQL_FLOAT,SQL_DOUBLE,
978    SQL_D_FLOAT:
979 <    writeln(OutFile, aValue.Name,' = ',FormatFloat('#,##0.00',aValue.AsFloat));
979 >    writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble));
980  
981    SQL_INT64:
982      if aValue.Scale <> 0 then
983 <      writeln(OutFile, aValue.Name,' = ',FormatFloat('#,##0.00',aValue.AsFloat))
983 >      writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble))
984      else
985        writeln(OutFile,aValue.Name,' = ',aValue.AsString);
986  
# Line 728 | Line 1005 | begin
1005        end
1006      end
1007      else
1008 +    begin
1009        writeln(OutFile,aValue.Name,' = (blob), Length = ',aValue.AsBlob.GetBlobSize);
1010 +      if FShowBinaryBlob then
1011 +        PrintHexString(aValue.AsString);
1012 +    end;
1013  
1014    SQL_TEXT,SQL_VARYING:
1015    begin
# Line 810 | Line 1091 | begin
1091    //Do nothing
1092   end;
1093  
1094 + procedure TTestBase.SetFloatTemplate(tpl: Ansistring);
1095 + begin
1096 +  FFloatTpl := tpl;
1097 + end;
1098 +
1099   { TTestApplication }
1100  
1101   class procedure TTestApplication.CreateTestList;
# Line 858 | Line 1144 | end;
1144   function TTestApplication.GetFirebirdAPI: IFirebirdAPI;
1145   begin
1146    if FFirebirdAPI = nil then
1147 +  begin
1148      FFirebirdAPI := IB.FirebirdAPI;
1149 +    FFirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);;
1150 +  end;
1151    Result := FFirebirdAPI;
1152   end;
1153  
# Line 926 | Line 1215 | begin
1215      Result := MakeConnectString(FServer,  FNewDatabaseName, inet,FPortNo);
1216   end;
1217  
1218 + function TTestApplication.GetTempDatabaseName: AnsiString;
1219 + begin
1220 +  Result := GetTempDir + 'fbtest.fbd';
1221 + end;
1222 +
1223   function TTestApplication.GetSecondNewDatabaseName: AnsiString;
1224   begin
1225    if FirebirdAPI.GetClientMajor < 3 then
# Line 948 | Line 1242 | begin
1242      DoTest(i);
1243      if not Quiet then
1244        writeln(Outfile,'------------------------------------------------------');
1245 +    Sleep(500);
1246    end;
1247   end;
1248  
# Line 1219 | Line 1514 | begin
1514        RunAll
1515      else
1516        RunTest(TestID);
1517 +    CleanUp;
1518    except on E: Exception do
1519      begin
1520        writeln('Exception: ',E.Message);

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines