(* * MWA Software Test suite. This unit provides common * code for all Firebird Database tests. * * The contents of this file are subject to the Initial Developer's * Public License Version 1.0 (the "License"); you may not use this * file except in compliance with the License. You may obtain a copy * of the License here: * * http://www.firebirdsql.org/index.php?op=doc&id=idpl * * Software distributed under the License is distributed on an "AS * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or * implied. See the License for the specific language governing rights * and limitations under the License. * * The Initial Developer of the Original Code is Tony Whyman. * * The Original Code is (C) 2016-2020 Tony Whyman, MWA Software * (http://www.mwasoftware.co.uk). * * All Rights Reserved. * * Contributor(s): ______________________________________. * *) unit TestApplication; {$IFDEF MSWINDOWS} {$DEFINE WINDOWS} {$ENDIF} {$IFDEF FPC} {$mode delphi} {$codepage utf8} {$ENDIF} {$IF not defined (DCC) and not defined (FPC)} {$DEFINE DCC} {$IFEND} interface uses Classes, SysUtils, {$IFDEF FPC}CustApp,{$ENDIF} Firebird, IB, IBUtils, FmtBCD, FBClientLib; {$IF not defined(LineEnding)} const {$IFDEF WINDOWS} LineEnding = #$0D#$0A; {$ELSE} LineEnding = #$0A; {$ENDIF} {$IFEND} const Copyright = 'Copyright MWA Software 2016-2021'; type {$IFDEF DCC} TCustomApplication = class(TComponent) private FTitle: string; protected procedure DoRun; virtual; abstract; public function Exename: string; procedure Run; procedure Terminate; property Title: string read FTitle write FTitle; end; {$ENDIF} TTestApplication = class; { TTestBase } TTestBase = class private FOwner: TTestApplication; FFloatTpl: AnsiString; FCursorSeq: integer; function GetFirebirdAPI: IFirebirdAPI; procedure SetOwner(AOwner: TTestApplication); protected FHexStrings: boolean; FShowBinaryBlob: boolean; procedure DumpBCD(bcd: tBCD); procedure ClientLibraryPathChanged; virtual; procedure CreateObjects(Application: TTestApplication); virtual; function ExtractDBName(ConnectString: AnsiString): AnsiString; function GetTestID: AnsiString; virtual; abstract; function GetTestTitle: AnsiString; virtual; abstract; procedure PrintHexString(s: AnsiString); procedure PrintDPB(DPB: IDPB); procedure PrintTPB(TPB: ITPB); procedure PrintSPB(SPB: ISPB); procedure PrintMetaData(meta: IMetaData); procedure ParamInfo(SQLParams: ISQLParams); function ReportResults(Statement: IStatement; ShowCursorName: boolean=false): IResultSet; procedure ReportResult(aValue: IResults); function StringToHex(octetString: string; MaxLineLength: integer=0): string; procedure WriteArray(ar: IArray); procedure WriteAffectedRows(Statement: IStatement); procedure WriteDBInfo(DBInfo: IDBInformation); procedure WriteBytes(Bytes: TByteArray); procedure WriteOperationCounts(Category: AnsiString; ops: TDBOperationCounts); procedure WritePerfStats(stats: TPerfCounters); procedure WriteSQLData(aValue: ISQLData); procedure CheckActivity(Attachment: IAttachment); overload; procedure CheckActivity(Transaction: ITransaction); overload; procedure InitTest; virtual; function SkipTest: boolean; virtual; procedure ProcessResults; virtual; procedure SetFloatTemplate(tpl: Ansistring); public constructor Create(aOwner: TTestApplication); virtual; function ChildProcess: boolean; virtual; function TestTitle: AnsiString; virtual; property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI; procedure RunTest(CharSet: AnsiString; SQLDialect: integer); virtual; abstract; property Owner: TTestApplication read FOwner; property TestID: AnsiString read GetTestID; end; TTest = class of TTestBase; { TTestApplication } TTestApplication = class(TCustomApplication) private class var FTests: TStringList; private class procedure CreateTestList; class procedure DestroyTestList; private FClientLibraryPath: string; FServer: AnsiString; FEmployeeDatabaseName: AnsiString; FNewDatabaseName: AnsiString; FSecondNewDatabaseName: AnsiString; FTestOption: AnsiString; FUserName: AnsiString; FPassword: AnsiString; FBackupFileName: AnsiString; FShowStatistics: boolean; FFirebirdAPI: IFirebirdAPI; FPortNo: AnsiString; FCreateObjectsDone: boolean; FQuiet: boolean; procedure CleanUp; function GetFirebirdAPI: IFirebirdAPI; function GetIndexByTestID(aTestID: AnsiString): integer; procedure SetClientLibraryPath(aLibName: string); procedure SetUserName(aValue: AnsiString); procedure SetPassword(aValue: AnsiString); procedure SetEmployeeDatabaseName(aValue: AnsiString); procedure SetNewDatabaseName(aValue: AnsiString); procedure SetSecondNewDatabaseName(aValue: AnsiString); procedure SetBackupFileName(aValue: AnsiString); procedure SetServerName(AValue: AnsiString); procedure SetPortNum(aValue: AnsiString); procedure SetTestOption(aValue: AnsiString); protected {$IFDEF FPC} function GetShortOptions: AnsiString; virtual; function GetLongOptions: AnsiString; virtual; {$ENDIF} procedure GetParams(var DoPrompt: boolean; var TestID: string); virtual; procedure DoRun; override; procedure DoTest(index: integer); procedure SetFormatSettings; virtual; procedure WriteHelp; virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetUserName: AnsiString; function GetPassword: AnsiString; function GetEmployeeDatabaseName: AnsiString; function GetNewDatabaseName: AnsiString; function GetTempDatabaseName: AnsiString; function GetSecondNewDatabaseName: AnsiString; function GetBackupFileName: AnsiString; procedure RunAll; procedure RunTest(TestID: AnsiString); property ShowStatistics: boolean read FShowStatistics write FShowStatistics; property FirebirdAPI: IFirebirdAPI read GetFirebirdAPI; property Server: AnsiString read FServer; property PortNo: AnsiString read FPortNo; property ClientLibraryPath: string read FClientLibraryPath; property TestOption: AnsiString read FTestOption write SetTestOption; property Quiet: boolean read FQuiet; end; { TMsgHash } TMsgHash = class private FFinalised: boolean; protected procedure CheckNotFinalised; public procedure AddText(aText: AnsiString); virtual; abstract; procedure Finalise; virtual; function SameHash(otherHash: TMsgHash): boolean; function Digest: AnsiString; virtual; abstract; class function CreateMsgHash: TMsgHash; property Finalised: boolean read FFinalised; end; ESkipException = class(Exception); var TestApp: TTestApplication = nil; var OutFile: text; procedure RegisterTest(aTest: TTest); implementation {$IFNDEF MSWINDOWS} uses MD5; {$ENDIF} {$IFDEF MSWINDOWS} uses {$IFDEF FPC}MD5,{$ENDIF} windows; function GetTempDir: AnsiString; var tempFolder: array[0..MAX_PATH] of Char; begin GetTempPath(MAX_PATH, @tempFolder); result := StrPas(tempFolder); end; {$ENDIF} procedure RegisterTest(aTest: TTest); var test: TTestBase; begin TTestApplication.CreateTestList; test := aTest.Create(TestApp); TTestApplication.FTests.AddObject(test.GetTestID,test); // if TestApp <> nil then // test.CreateObjects(TestApp); end; {$IFDEF FPC} type { TMD5MsgHash } TMD5MsgHash = class(TMsgHash) private FMD5Context: TMDContext; FDigest: TMDDigest; public constructor Create; procedure AddText(aText: AnsiString); override; procedure Finalise; override; function Digest: AnsiString; override; end; {$DEFINE MSG_HASH_AVAILABLE} { TMD5MsgHash } constructor TMD5MsgHash.Create; begin inherited Create; MDInit(FMD5Context,MD_VERSION_5); end; procedure TMD5MsgHash.AddText(aText: AnsiString); begin CheckNotFinalised; MDUpdate(FMD5Context,PAnsiChar(aText)^,Length(aText)); end; procedure TMD5MsgHash.Finalise; begin CheckNotFinalised; MDFinal(FMD5Context,FDigest); inherited Finalise; end; function TMD5MsgHash.Digest: AnsiString; begin if not FFinalised then Finalise; Result := MD5Print(FDigest); end; class function TMsgHash.CreateMsgHash: TMsgHash; begin Result := TMD5MsgHash.Create; end; {$ENDIF} {$IFNDEF MSG_HASH_AVAILABLE} type { TSimpleMsgHash } TSimpleMsgHash = class(TMsgHash) private FDigest: Int64; Finalised: boolean; public procedure AddText(aText: AnsiString); override; function Digest: AnsiString; override; end; { TSimpleMsgHash } procedure TSimpleMsgHash.AddText(aText: AnsiString); const modulus = high(Int64) div 100; var i: integer; begin CheckNotFinalised; for i := 1 to length(aText) do FDigest := (FDigest * 7 + ord(aText[i])) mod modulus; end; function TSimpleMsgHash.Digest: AnsiString; begin if not Finalised then Finalise; Result := IntToStr(FDigest); end; class function TMsgHash.CreateMsgHash: TMsgHash; begin Result := TSimpleMsgHash.Create; end; {$ENDIF} procedure TMsgHash.CheckNotFinalised; begin if FFinalised then raise Exception.Create('Digest has been finalised'); end; procedure TMsgHash.Finalise; begin FFinalised := true; end; function TMsgHash.SameHash(otherHash: TMsgHash): boolean; begin Result := Digest = OtherHash.Digest; end; { TTestBase } constructor TTestBase.Create(aOwner: TTestApplication); begin inherited Create; FOwner := aOwner; FFloatTpl := '#,###.00'; end; function TTestBase.ChildProcess: boolean; begin Result := false; end; function TTestBase.TestTitle: AnsiString; begin Result := 'Test ' + GetTestID + ': ' + GetTestTitle; end; function TTestBase.GetFirebirdAPI: IFirebirdAPI; begin Result := FOwner.FirebirdAPI; end; procedure TTestBase.SetOwner(AOwner: TTestApplication); begin FOwner := AOwner; end; procedure TTestBase.DumpBCD(bcd: tBCD); var i,l: integer; begin with bcd do begin writeln(OutFile,' Precision = ',bcd.Precision); writeln(OutFile,' Sign = ',(SignSpecialPlaces and $80) shr 7); writeln(OutFile,' Special = ', (SignSpecialPlaces and $40) shl 6); writeln(OutFile,' Places = ', SignSpecialPlaces and $7F); write(OutFile,' Digits = '); l := Precision div 2; if not odd(Precision) then l := l - 1; for i := 0 to l do write(OutFile,Format('%.2x',[Fraction[i]]),' '); writeln(OutFile); end; end; procedure TTestBase.ClientLibraryPathChanged; begin //Do nothing yet end; procedure TTestBase.CreateObjects(Application: TTestApplication); begin //Do nothing yet end; function TTestBase.ExtractDBName(ConnectString: AnsiString): AnsiString; var ServerName: AnsiString; Protocol: TProtocolAll; PortNo: AnsiString; i: integer; begin if not ParseConnectString(ConnectString, ServerName, Result, Protocol,PortNo) then begin {assume either inet format (remote) or localhost} Result := ConnectString; if Pos('inet',Result) = 1 then begin system.Delete(Result,1,7); i := Pos('/',Result); if i > 0 then system.delete(Result,1,i); end else if Pos('localhost:',Result) = 1 then system.Delete(Result,1,10) end; end; procedure TTestBase.PrintHexString(s: AnsiString); var i: integer; begin for i := 1 to length(s) do write(OutFile,Format('%x ',[byte(s[i])])); end; procedure TTestBase.PrintDPB(DPB: IDPB); var i: integer; begin writeln(OutFile,'DPB: Item Count = ', DPB.getCount); for i := 0 to DPB.getCount - 1 do begin write(OutFile,' ',DPB[i].getParamTypeName); if DPB[i].AsString <> '' then writeln(Outfile,' = ', DPB[i].AsString) else writeln(OutFile); end; writeln(OutFile); end; procedure TTestBase.PrintTPB(TPB: ITPB); var i: integer; begin writeln(OutFile,'TPB: Item Count = ', TPB.getCount); for i := 0 to TPB.getCount - 1 do begin write(OutFile,' ',TPB[i].getParamTypeName); if TPB[i].AsString <> '' then writeln(Outfile,' = ', TPB[i].AsString) else writeln(OutFile); end; writeln(OutFile); end; procedure TTestBase.PrintSPB(SPB: ISPB); var i: integer; begin writeln(OutFile,'SPB: Item Count = ', SPB.getCount); for i := 0 to SPB.getCount - 1 do begin write(OutFile,' ',SPB[i].getParamTypeName); if SPB[i].AsString <> '' then writeln(Outfile,' = ', SPB[i].AsString) else writeln(OutFile); end; writeln(OutFile); end; procedure TTestBase.PrintMetaData(meta: IMetaData); var i, j: integer; ar: IArrayMetaData; bm: IBlobMetaData; Bounds: TArrayBounds; begin writeln(OutFile,'Metadata'); for i := 0 to meta.GetCount - 1 do with meta[i] do begin writeln(OutFile,'SQLType =',GetSQLTypeName); writeln(OutFile,'sub type = ',getSubType); writeln(OutFile,'Table = ',getRelationName); writeln(OutFile,'Owner = ',getOwnerName); writeln(OutFile,'Column Name = ',getSQLName); writeln(OutFile,'Alias Name = ',getAliasName); writeln(OutFile,'Field Name = ',getName); writeln(OutFile,'Scale = ',getScale); writeln(OutFile,'Charset id = ',getCharSetID); if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null'); writeln(OutFile,'Size = ',GetSize); case getSQLType of SQL_ARRAY: begin writeln(OutFile,'Array Meta Data:'); ar := GetArrayMetaData; writeln(OutFile,'SQLType =',ar.GetSQLTypeName); writeln(OutFile,'Scale = ',ar.getScale); writeln(OutFile,'Charset id = ',ar.getCharSetID); writeln(OutFile,'Size = ',ar.GetSize); writeln(OutFile,'Table = ',ar.GetTableName); writeln(OutFile,'Column = ',ar.GetColumnName); writeln(OutFile,'Dimensions = ',ar.GetDimensions); write(OutFile,'Bounds: '); Bounds := ar.GetBounds; for j := 0 to Length(Bounds) - 1 do write(OutFile,'(',Bounds[j].LowerBound,':',Bounds[j].UpperBound,') '); writeln(OutFile); end; SQL_BLOB: begin writeln(OutFile); writeln(OutFile,'Blob Meta Data'); bm := GetBlobMetaData; writeln(OutFile,'SQL SubType =',bm.GetSubType); writeln(OutFile,'Table = ',bm.GetRelationName); writeln(OutFile,'Column = ',bm.GetColumnName); writeln(OutFile,'CharSetID = ',bm.GetCharSetID); writeln(OutFile,'Segment Size = ',bm.GetSegmentSize); writeln(OutFile); end; end; writeln(OutFile); end; end; procedure TTestBase.ParamInfo(SQLParams: ISQLParams); var i: integer; begin writeln(OutFile,'SQL Params'); for i := 0 to SQLParams.Count - 1 do with SQLParams[i] do begin writeln(OutFile,'SQLType =',GetSQLTypeName); writeln(OutFile,'sub type = ',getSubType); writeln(OutFile,'Field Name = ',getName); writeln(OutFile,'Scale = ',getScale); writeln(OutFile,'Charset id = ',getCharSetID); if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null'); writeln(OutFile,'Size = ',GetSize); if not IsNull then writeln(Outfile,'Value = ',getAsString); writeln(OutFile); end; end; function TTestBase.ReportResults(Statement: IStatement; ShowCursorName: boolean): IResultSet; begin Result := Statement.OpenCursor; try if ShowCursorName then writeln(Outfile,'Results for Cursor: ',Result.GetCursorName); while Result.FetchNext do ReportResult(Result); finally Result.Close; end; writeln(OutFile); end; procedure TTestBase.ReportResult(aValue: IResults); var i: integer; begin for i := 0 to aValue.getCount - 1 do WriteSQLData(aValue[i]); end; function TTestBase.StringToHex(octetString: string; MaxLineLength: integer ): string; function ToHex(aValue: byte): string; const HexChars: array [0..15] of char = '0123456789ABCDEF'; begin Result := HexChars[aValue shr 4] + HexChars[(aValue and $0F)]; end; var i, j: integer; begin i := 1; Result := ''; if MaxLineLength = 0 then while i <= Length(octetString) do begin Result := Result + ToHex(byte(octetString[i])); Inc(i); end else while i <= Length(octetString) do begin for j := 1 to MaxLineLength do begin if i > Length(octetString) then Exit else Result := Result + ToHex(byte(octetString[i])); inc(i); end; Result := Result + LineEnding; end; end; procedure TTestBase.WriteArray(ar: IArray); var Bounds: TArrayBounds; i,j: integer; begin write(OutFile,'Array: '); Bounds := ar.GetBounds; case ar.GetDimensions of 1: begin for i := Bounds[0].LowerBound to Bounds[0].UpperBound do write(OutFile,'(',i,': ',ar.GetAsVariant([i]),') '); end; 2: begin for i := Bounds[0].LowerBound to Bounds[0].UpperBound do for j := Bounds[1].LowerBound to Bounds[1].UpperBound do write(OutFile,'(',i,',',j,': ',ar.GetAsVariant([i,j]),') '); end; end; writeln(OutFile); writeln(OutFile); end; procedure TTestBase.WriteAffectedRows(Statement: IStatement); var SelectCount, InsertCount, UpdateCount, DeleteCount: integer; begin Statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount); writeln(OutFile,'Select Count = ', SelectCount,' InsertCount = ',InsertCount,' UpdateCount = ', UpdateCount, ' DeleteCount = ',DeleteCount); end; procedure TTestBase.WriteDBInfo(DBInfo: IDBInformation); var i, j: integer; bytes: TByteArray; ConType: integer; DBFileName: AnsiString; DBSiteName: AnsiString; Version: byte; VersionString: AnsiString; Users: TStringList; begin for i := 0 to DBInfo.GetCount - 1 do with DBInfo[i] do case getItemType of isc_info_db_read_only: if getAsInteger <> 0 then writeln(OutFile,'Database is Read Only') else writeln(OutFile,'Database is Read/Write'); isc_info_allocation: writeln(OutFile,'Pages =',getAsInteger); isc_info_base_level: begin bytes := getAsBytes; write(OutFile,'Base Level = '); WriteBytes(Bytes); end; isc_info_db_id: begin DecodeIDCluster(ConType,DBFileName,DBSiteName); writeln(OutFile,'Database ID = ', ConType,' FB = ', DBFileName, ' SN = ',DBSiteName); end; isc_info_implementation: begin bytes := getAsBytes; write(OutFile,'Implementation = '); WriteBytes(Bytes); end; isc_info_no_reserve: writeln(OutFile,'Reserved = ',getAsInteger); isc_info_ods_minor_version: writeln(OutFile,'ODS minor = ',getAsInteger); isc_info_ods_version: writeln(OutFile,'ODS major = ',getAsInteger); isc_info_page_size: writeln(OutFile,'Page Size = ',getAsInteger); isc_info_version: begin DecodeVersionString(Version,VersionString); writeln(OutFile,'Version = ',Version,': ',VersionString); end; isc_info_current_memory: writeln(OutFile,'Server Memory = ',getAsInteger); isc_info_forced_writes: writeln(OutFile,'Forced Writes = ',getAsInteger); isc_info_max_memory: writeln(OutFile,'Max Memory = ',getAsInteger); isc_info_num_buffers: writeln(OutFile,'Num Buffers = ',getAsInteger); isc_info_sweep_interval: writeln(OutFile,'Sweep Interval = ',getAsInteger); isc_info_user_names: begin Users := TStringList.Create; try write(OutFile,'Logged in Users: '); DecodeUserNames(Users); for j := 0 to Users.Count - 1 do write(OutFile,Users[j],','); finally Users.Free; end; writeln(OutFile); end; isc_info_fetches: writeln(OutFile,'Fetches = ',getAsInteger); isc_info_marks: writeln(OutFile,'Writes = ',getAsInteger); isc_info_reads: writeln(OutFile,'Reads = ',getAsInteger); isc_info_writes: writeln(OutFile,'Page Writes = ',getAsInteger); isc_info_backout_count: WriteOperationCounts('Record Version Removals',getOperationCounts); isc_info_delete_count: WriteOperationCounts('Deletes',getOperationCounts); isc_info_expunge_count: WriteOperationCounts('Expunge Count',getOperationCounts); isc_info_insert_count: WriteOperationCounts('Insert Count',getOperationCounts); isc_info_purge_count: WriteOperationCounts('Purge Count Countites',getOperationCounts); isc_info_read_idx_count: WriteOperationCounts('Indexed Reads Count',getOperationCounts); isc_info_read_seq_count: WriteOperationCounts('Sequential Table Scans',getOperationCounts); isc_info_update_count: WriteOperationCounts('Update Count',getOperationCounts); isc_info_db_SQL_Dialect: writeln(OutFile,'SQL Dialect = ',getAsInteger); isc_info_creation_date: writeln(OutFile,'Database Created: ',DateTimeToStr(getAsDateTime)); isc_info_active_tran_count: writeln(OutFile,'Active Transaction Count = ',getAsInteger); fb_info_page_contents: begin writeln('Database Page'); PrintHexString(getAsString); writeln; end; fb_info_pages_used: writeln(OutFile,'Pages Used = ',getAsInteger); fb_info_pages_free: writeln(OutFile,'Pages Free = ',getAsInteger); isc_info_truncated: writeln(OutFile,'Results Truncated'); else writeln(OutFile,'Unknown Response ',getItemType); end; end; procedure TTestBase.WriteBytes(Bytes: TByteArray); var i: integer; begin for i := 0 to length(Bytes) - 1 do write(OutFile,Bytes[i],','); writeln(OutFile); end; procedure TTestBase.WriteOperationCounts(Category: AnsiString; ops: TDBOperationCounts); var i: integer; begin writeln(OutFile,Category,' Operation Counts'); for i := 0 to Length(ops) - 1 do begin writeln(OutFile,'Table ID = ',ops[i].TableID); writeln(OutFile,'Count = ',ops[i].Count); end; writeln(OutFile); end; procedure TTestBase.WritePerfStats(stats: TPerfCounters); var LargeCompFormat: string; ThreeSigPlacesFormat: string; begin {$IF declared(DefaultFormatSettings)} with DefaultFormatSettings do {$ELSE} {$IF declared(FormatSettings)} with FormatSettings do {$IFEND} {$IFEND} begin LargeCompFormat := '#' + ThousandSeparator + '##0'; ThreeSigPlacesFormat := '#0' + DecimalSeparator + '000'; end; writeln(OutFile,'Current memory = ', FormatFloat(LargeCompFormat,stats[psCurrentMemory])); writeln(OutFile,'Delta memory = ', FormatFloat(LargeCompFormat,stats[psDeltaMemory])); writeln(OutFile,'Max memory = ', FormatFloat(LargeCompFormat,stats[psMaxMemory])); writeln(OutFile,'Elapsed time= ', FormatFloat(ThreeSigPlacesFormat,stats[psRealTime]/1000),' sec'); writeln(OutFile,'Cpu = ', FormatFloat(ThreeSigPlacesFormat,stats[psUserTime]/1000),' sec'); writeln(OutFile,'Buffers = ', FormatFloat('#0',stats[psBuffers])); writeln(OutFile,'Reads = ', FormatFloat('#0',stats[psReads])); writeln(OutFile,'Writes = ', FormatFloat('#0',stats[psWrites])); writeln(OutFile,'Fetches = ', FormatFloat('#0',stats[psFetches])); end; procedure TTestBase.WriteSQLData(aValue: ISQLData); var s: AnsiString; dt: TDateTime; dstOffset: SmallInt; aTimeZone: AnsiString; begin if aValue.IsNull then writeln(OutFile,aValue.Name,' = NULL') else case aValue.SQLType of SQL_ARRAY: begin write(OutFile, aValue.Name,' = '); if not aValue.IsNull then WriteArray(aValue.AsArray) else writeln(OutFile,'NULL'); end; SQL_FLOAT,SQL_DOUBLE, SQL_D_FLOAT: writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble)); SQL_INT64: if aValue.Scale <> 0 then writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble)) else writeln(OutFile,aValue.Name,' = ',aValue.AsString); SQL_BLOB: if aValue.IsNull then writeln(OutFile,aValue.Name,' = (null blob)') else if aValue.SQLSubType = 1 then begin s := aValue.AsString; if FHexStrings then begin write(OutFile,aValue.Name,' = '); PrintHexString(s); writeln(OutFile,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')'); end else begin writeln(OutFile,aValue.Name,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')'); writeln(OutFile); writeln(OutFile,s); end end else begin writeln(OutFile,aValue.Name,' = (blob), Length = ',aValue.AsBlob.GetBlobSize); if FShowBinaryBlob then PrintHexString(aValue.AsString); end; SQL_TEXT,SQL_VARYING: begin if aValue.GetCharSetID = 1 then s := aValue.AsString else s := TrimRight(aValue.AsString); if FHexStrings then begin write(OutFile,aValue.Name,' = '); PrintHexString(s); writeln(OutFile,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')'); end else if aValue.GetCharSetID > 0 then writeln(OutFile,aValue.Name,' = ',s,' (Charset Id = ',aValue.GetCharSetID, ' Codepage = ',StringCodePage(s),')') else writeln(OutFile,aValue.Name,' = ',s); end; SQL_TIMESTAMP: writeln(OutFile,aValue.Name,' = ',FBFormatDateTime('yyyy/mm/dd hh:nn:ss.zzzz',aValue.AsDateTime)); SQL_TYPE_DATE: writeln(OutFile,aValue.Name,' = ',FBFormatDateTime('yyyy/mm/dd',aValue.AsDate)); SQL_TYPE_TIME: writeln(OutFile,aValue.Name,' = ',FBFormatDateTime('hh:nn:ss.zzzz',aValue.AsTime)); SQL_TIMESTAMP_TZ, SQL_TIMESTAMP_TZ_EX: begin aValue.GetAsDateTime(dt,dstOffset,aTimeZone); writeln(OutFile,aValue.Name,' ='); writeln(OutFile,' AsString = ',aValue.GetAsString); writeln(OutFile,' Formatted = ',FBFormatDateTime('yyyy/mm/dd hh:nn:ss.zzzz',dt),' ',aTimeZone); writeln(OutFile,' TimeZoneID = ',aValue.GetStatement.GetAttachment.GetTimeZoneServices.TimeZoneName2TimeZoneID(aTimeZone)); writeln(OutFile,' Time Zone Name = ',aTimeZone); writeln(OutFile,' UTC Time = ',DateTimeToStr( aValue.GetAsUTCDateTime)); writeln(OutFile,' DST Offset = ',dstOffset); end; SQL_TIME_TZ, SQL_TIME_TZ_EX: begin aValue.GetAsDateTime(dt,dstOffset,aTimeZone); writeln(OutFile,aValue.Name,' ='); writeln(OutFile,' AsString = ',aValue.GetAsString); writeln(OutFile,' Formatted = ',FBFormatDateTime('hh:nn:ss.zzzz',dt),' ',aTimeZone); writeln(OutFile,' TimeZoneID = ',aValue.GetStatement.GetAttachment.GetTimeZoneServices.TimeZoneName2TimeZoneID(aTimeZone)); writeln(OutFile,' Time Zone Name = ',aTimeZone); writeln(OutFile,' UTC Time = ',TimeToStr( aValue.GetAsUTCDateTime)); writeln(OutFile,' DST Offset = ',dstOffset); end; else writeln(OutFile,aValue.Name,' = ',aValue.AsString); end; end; procedure TTestBase.CheckActivity(Attachment: IAttachment); begin writeln(OutFile,'Database Activity = ',Attachment.HasActivity) end; procedure TTestBase.CheckActivity(Transaction: ITransaction); begin writeln(OutFile,'Transaction Activity = ',Transaction.HasActivity) end; procedure TTestBase.InitTest; begin //Do nothing yet end; function TTestBase.SkipTest: boolean; begin Result := false; end; procedure TTestBase.ProcessResults; begin //Do nothing end; procedure TTestBase.SetFloatTemplate(tpl: Ansistring); begin FFloatTpl := tpl; end; { TTestApplication } class procedure TTestApplication.CreateTestList; begin if FTests = nil then begin FTests := TStringList.Create; FTests.Sorted := true; FTests.Duplicates := dupError; end; end; class procedure TTestApplication.DestroyTestList; var i: integer; TestID: Ansistring; begin if assigned(FTests) then begin for i := 0 to FTests.Count - 1 do if FTests.Objects[i] <> nil then try TestID := TTestBase(FTests.Objects[i]).TestID; FTests.Objects[i].Free; except on E: Exception do writeln('Error Freeing Test ',TestID,' Error message = ',E.Message); end; FreeAndNil(FTests); end; end; procedure TTestApplication.CleanUp; var DPB: IDPB; Attachment: IAttachment; begin DPB := FirebirdAPI.AllocateDPB; DPB.Add(isc_dpb_user_name).setAsString(GetUserName); DPB.Add(isc_dpb_password).setAsString(GetPassword); Attachment := FirebirdAPI.OpenDatabase(GetNewDatabaseName,DPB,false); if Attachment <> nil then Attachment.DropDatabase; Attachment := FirebirdAPI.OpenDatabase(GetSecondNewDatabaseName,DPB,false); if Attachment <> nil then Attachment.DropDatabase; end; function TTestApplication.GetFirebirdAPI: IFirebirdAPI; begin if FFirebirdAPI = nil then begin FFirebirdAPI := IB.FirebirdAPI; FFirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);; end; Result := FFirebirdAPI; end; function TTestApplication.GetIndexByTestID(aTestID: AnsiString): integer; begin try Result := FTests.IndexOf(aTestID); except raise Exception.CreateFmt('Invalid Test ID - %s',[aTestID]); end; if Result = -1 then raise Exception. CreateFmt('Invalid Test ID - %s',[aTestID]); end; constructor TTestApplication.Create(AOwner: TComponent); var i: integer; begin inherited Create(AOwner); TestApp := self; CreateTestList; FNewDatabaseName := GetTempDir + 'fbtestsuite.fdb'; FSecondNewDatabaseName := GetTempDir + 'fbtestsuite2.fdb'; FUserName := 'SYSDBA'; FPassword := 'masterkey'; FEmployeeDatabaseName := 'employee'; FBackupFileName := GetTempDir + 'testbackup.gbk'; FServer := 'localhost'; for i := 0 to FTests.Count - 1 do begin TTestBase(FTests.Objects[i]).SetOwner(self); // TTestBase(FTests.Objects[i]).CreateObjects(self); end; end; destructor TTestApplication.Destroy; begin DestroyTestList; TestApp := nil; inherited Destroy; end; function TTestApplication.GetUserName: AnsiString; begin Result := FUserName; end; function TTestApplication.GetPassword: AnsiString; begin Result := FPassword; end; function TTestApplication.GetEmployeeDatabaseName: AnsiString; begin if FirebirdAPI.GetClientMajor < 3 then Result := MakeConnectString(FServer, FEmployeeDatabaseName, TCP,FPortNo) else Result := MakeConnectString(FServer, FEmployeeDatabaseName, inet,FPortNo); end; function TTestApplication.GetNewDatabaseName: AnsiString; begin if FirebirdAPI.GetClientMajor < 3 then Result := MakeConnectString(FServer, FNewDatabaseName, TCP,FPortNo) else Result := MakeConnectString(FServer, FNewDatabaseName, inet,FPortNo); end; function TTestApplication.GetTempDatabaseName: AnsiString; begin Result := GetTempDir + 'fbtest.fbd'; end; function TTestApplication.GetSecondNewDatabaseName: AnsiString; begin if FirebirdAPI.GetClientMajor < 3 then Result := MakeConnectString(FServer, FSecondNewDatabaseName, TCP,FPortNo) else Result := MakeConnectString(FServer, FSecondNewDatabaseName, inet,FPortNo); end; function TTestApplication.GetBackupFileName: AnsiString; begin Result := FBackupFileName; end; procedure TTestApplication.RunAll; var i: integer; begin CleanUp; for i := 0 to FTests.Count - 1 do begin DoTest(i); if not Quiet then writeln(Outfile,'------------------------------------------------------'); Sleep(500); end; end; procedure TTestApplication.RunTest(TestID: AnsiString); begin CleanUp; DoTest(GetIndexByTestID(TestID)); end; procedure TTestApplication.SetClientLibraryPath(aLibName: string); var i: integer; begin FFirebirdAPI := LoadFBLibrary(aLibName).GetFirebirdAPI; FClientLibraryPath := aLibName; for i := 0 to FTests.Count - 1 do TTestBase(FTests.Objects[i]).ClientLibraryPathChanged; end; procedure TTestApplication.SetUserName(aValue: AnsiString); begin FUserName := aValue; end; procedure TTestApplication.SetPassword(aValue: AnsiString); begin FPassword := aValue; end; procedure TTestApplication.SetEmployeeDatabaseName(aValue: AnsiString); begin FEmployeeDatabaseName := aValue; end; procedure TTestApplication.SetNewDatabaseName(aValue: AnsiString); begin FNewDatabaseName := aValue; end; procedure TTestApplication.SetSecondNewDatabaseName(aValue: AnsiString); begin FSecondNewDatabaseName := aValue; end; procedure TTestApplication.SetBackupFileName(aValue: AnsiString); begin FBackupFileName := aValue; end; procedure TTestApplication.SetServerName(AValue: AnsiString); begin if FServer = AValue then Exit; FServer := AValue; end; procedure TTestApplication.SetPortNum(aValue: AnsiString); begin FPortNo := aValue; end; procedure TTestApplication.SetTestOption(aValue: AnsiString); begin FTestOption := AValue; end; {$IFDEF FPC} function TTestApplication.GetShortOptions: AnsiString; begin Result := 'htupensbolrSPXOq'; end; function TTestApplication.GetLongOptions: AnsiString; begin Result := 'help test user passwd employeedb newdbname secondnewdbname backupfile '+ 'outfile fbclientlibrary server stats port prompt TestOption quiet'; end; procedure TTestApplication.GetParams(var DoPrompt: boolean; var TestID: string); var ErrorMsg: String; begin // quick check parameters ErrorMsg := CheckOptions(GetShortOptions,GetLongOptions); if ErrorMsg <> '' then begin ShowException(Exception.Create(ErrorMsg)); Terminate; Exit; end; // parse parameters if HasOption('h', 'help') then begin WriteHelp; Terminate; Exit; end; if HasOption('t') then TestID := GetOptionValue('t'); if Length(TestID) = 1 then TestID := '0' + TestID; DoPrompt := HasOption('X','prompt'); if HasOption('u','user') then SetUserName(GetOptionValue('u')); if HasOption('p','passwd') then SetPassword(GetOptionValue('p')); if HasOption('e','employeedb') then SetEmployeeDatabaseName(GetOptionValue('e')); if HasOption('n','newdbname') then SetNewDatabaseName(GetOptionValue('n')); if HasOption('s','secondnewdbname') then SetSecondNewDatabaseName(GetOptionValue('s')); if HasOption('b','backupfile') then SetBackupFileName(GetOptionValue('b')); if HasOption('l','fbclientlibrary') then SetClientLibraryPath(GetOptionValue('l')); if HasOption('r','server') then SetServerName(GetOptionValue('r')); if HasOption('o','outfile') then begin system.Assign(outFile,GetOptionValue('o')); ReWrite(outFile); end; if HasOption('P','port') then SetPortNum(GetOptionValue('P')); ShowStatistics := HasOption('S','stats'); if HasOption('O','TestOption') then SetTestOption(GetOptionValue('O')); FQuiet := HasOption('q','quiet') end; {$ENDIF} {$IFDEF DCC} procedure TTestApplication.GetParams(var DoPrompt: boolean; var TestID: string); function GetCmdLineValue(const Switch: string; var aValue: string): boolean; var i: integer; begin aValue := ''; Result := FindCmdLineSwitch(Switch,false); if Result then begin for i := 0 to ParamCount do if (ParamStr(i) = '-' + Switch) and (i <= ParamCount) then begin aValue := ParamStr(i+1); exit; end; Result := false; end; end; var aValue: string; begin // parse parameters if FindCmdLineSwitch('h') or FindCmdLineSwitch('help') then begin WriteHelp; Exit; end; if GetCmdLineValue('t',aValue) then TestID := aValue; DoPrompt := GetCmdLineValue('X',aValue); if GetCmdLineValue('u',aValue) or GetCmdLineValue('user',aValue) then SetUserName(aValue); if GetCmdLineValue('p',aValue) or GetCmdLineValue('passwd',aValue) then SetPassword(aValue); if GetCmdLineValue('e',aValue) or GetCmdLineValue('employeedb',aValue) then SetEmployeeDatabaseName(aValue); if GetCmdLineValue('n',aValue) or GetCmdLineValue('newdbname',aValue) then SetNewDatabaseName(aValue); if GetCmdLineValue('s',aValue) or GetCmdLineValue('secondnewdbname',aValue) then SetSecondNewDatabaseName(aValue); if GetCmdLineValue('b',aValue) or GetCmdLineValue('backupfile',aValue) then SetBackupFileName(aValue); if GetCmdLineValue('r',aValue) or GetCmdLineValue('server',aValue) then SetServerName(aValue); if GetCmdLineValue('P',aValue) or GetCmdLineValue('port',aValue) then SetPortNum(aValue); if GetCmdLineValue('l',aValue) or GetCmdLineValue('fbclientlibrary',aValue) then SetClientLibraryPath(aValue); if GetCmdLineValue('o',aValue) or GetCmdLineValue('outfile',aValue) then begin system.Assign(outFile,aValue); ReWrite(outFile); end; ShowStatistics := FindCmdLineSwitch('S',false) or FindCmdLineSwitch('stats'); if GetCmdLineValue('O',aValue) or GetCmdLineValue('TestOption',aValue) then SetTestOption(aValue); FQuiet := FindCmdLineSwitch('q',false) or FindCmdLineSwitch('quiet'); end; {$ENDIF} procedure TTestApplication.DoRun; var DoPrompt: boolean; TestID: string; MasterProvider: IFBIMasterProvider; begin {$IFDEF FPC} OutFile := stdout; {$ELSE} AssignFile(OutFile,''); ReWrite(outFile); {$ENDIF} GetParams(DoPrompt,TestID); if length(TestID) = 1 then TestID := '0' + TestID; {$IF declared(SetTextCodePage)} {Ensure consistent UTF-8 output} SetTextCodePage(OutFile,cp_utf8); {$IFEND} {$IF declared(SetConsoleOutputCP)} SetConsoleOutputCP(cp_utf8); {$IFEND} {Ensure consistent date reporting across platforms} SetFormatSettings; if not Quiet then begin writeln(OutFile,Title); writeln(OutFile,Copyright); writeln(OutFile); writeln(OutFile,'Starting Tests'); writeln(OutFile,'Client API Version = ',FirebirdAPI.GetImplementationVersion); writeln(OutFile,'Firebird Environment Variable = ',sysutils.GetEnvironmentVariable('FIREBIRD')); if FirebirdAPI.HasMasterIntf and (FirebirdAPI.QueryInterface(IFBIMasterProvider,MasterProvider) = S_OK) then with MasterProvider.GetIMasterIntf.getConfigManager do begin writeln(OutFile,'Firebird Bin Directory = ', getDirectory(DIR_BIN)); writeln(OutFile,'Firebird Conf Directory = ', getDirectory(DIR_CONF)); end; writeln(OutFile,'Firebird Client Library Path = ',FirebirdAPI.GetFBLibrary.GetLibraryFilePath); end; try if TestID = '' then RunAll else RunTest(TestID); CleanUp; except on E: Exception do begin writeln('Exception: ',E.Message); writeln(OutFile,'Exception: ',E.Message); end; end; writeln(OutFile,'Test Suite Ends'); Flush(OutFile); {$IFDEF WINDOWS} if DoPrompt then begin write('Press Entry to continue'); readln; {when running from IDE and console window closes before you can view results} end; {$ENDIF} // stop program loop Terminate; end; procedure TTestApplication.DoTest(index: integer); begin if FTests.Objects[index] = nil then Exit; try with TTestBase(FTests.Objects[index]) do if SkipTest then writeln(OutFile,' Skipping ' + TestID) else begin if not Quiet then writeln(OutFile,'Running ' + TestTitle); if not ChildProcess then writeln(ErrOutput,'Running ' + TestTitle); try CreateObjects(self); InitTest; RunTest('UTF8',3); ProcessResults; except on E:ESkipException do writeln(OutFile,'Skipping Test: ' + E.Message); on E:Exception do begin writeln(OutFile,'Test Completed with Error: ' + E.Message); Exit; end; end; if not Quiet then begin writeln(OutFile); writeln(OutFile); end; end; finally FTests.Objects[index].Free; FTests.Objects[index] := nil; DestroyComponents; end; end; procedure TTestApplication.SetFormatSettings; begin {$IF declared(DefaultFormatSettings)} with DefaultFormatSettings do {$ELSE} {$IF declared(FormatSettings)} with FormatSettings do {$IFEND}{$IFEND} begin ShortDateFormat := 'dd/m/yyyy'; LongTimeFormat := 'HH:MM:SS'; DateSeparator := '/'; end; end; procedure TTestApplication.WriteHelp; begin { add your help code here } writeln(OutFile,'Usage: ', ExeName, ' -h'); end; {$IFNDEF FPC} function TCustomApplication.Exename: string; begin Result := ParamStr(0); end; procedure TCustomApplication.Run; begin try DoRun; except on E: Exception do writeln(OutFile,E.Message); end; end; procedure TCustomApplication.Terminate; begin end; {$ENDIF} end.