ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/fbintf/testsuite/testApp/TestApplication.pas

Comparing ibx/trunk/fbintf/testsuite/testApp/TestApplication.pas (file contents):
Revision 334 by tony, Fri Feb 26 16:43:23 2021 UTC vs.
Revision 380 by tony, Mon Jan 10 10:13:17 2022 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	+	{$if declared(TJnlEntry) }
85	+	procedure HandleOnJnlEntry(JnlEntry: TJnlEntry);
86	+	{$endif}
87		protected
88		FHexStrings: boolean;
89	+	FShowBinaryBlob: boolean;
90		procedure DumpBCD(bcd: tBCD);
91		procedure ClientLibraryPathChanged; virtual;
92		procedure CreateObjects(Application: TTestApplication); virtual;
#	Line 93 | Line 99 | type
99		procedure PrintSPB(SPB: ISPB);
100		procedure PrintMetaData(meta: IMetaData);
101		procedure ParamInfo(SQLParams: ISQLParams);
102	<	function ReportResults(Statement: IStatement): IResultSet;
102	>	{$if declared(TJnlEntry) }
103	>	procedure PrintJournalFile(aFileName: AnsiString);
104	>	procedure PrintJournalTable(Attachment: IAttachment);
105	>	{$ifend}
106	>	function ReportResults(Statement: IStatement; ShowCursorName: boolean=false): IResultSet;
107		procedure ReportResult(aValue: IResults);
108		function StringToHex(octetString: string; MaxLineLength: integer=0): string;
109	+	procedure WriteAttachmentInfo(Attachment: IAttachment);
110		procedure WriteArray(ar: IArray);
111		procedure WriteAffectedRows(Statement: IStatement);
112		procedure WriteDBInfo(DBInfo: IDBInformation);
113	+	procedure WriteTRInfo(TrInfo: ITrInformation);
114		procedure WriteBytes(Bytes: TByteArray);
115		procedure WriteOperationCounts(Category: AnsiString; ops: TDBOperationCounts);
116		procedure WritePerfStats(stats: TPerfCounters);
#	Line 108 | Line 120 | type
120		procedure InitTest; virtual;
121		function SkipTest: boolean; virtual;
122		procedure ProcessResults; virtual;
123	+	procedure SetFloatTemplate(tpl: Ansistring);
124		public
125		constructor Create(aOwner: TTestApplication);  virtual;
126		function ChildProcess: boolean; virtual;
#	Line 173 | Line 186 | type
186		function GetPassword: AnsiString;
187		function GetEmployeeDatabaseName: AnsiString;
188		function GetNewDatabaseName: AnsiString;
189	+	function GetTempDatabaseName: AnsiString;
190		function GetSecondNewDatabaseName: AnsiString;
191		function GetBackupFileName: AnsiString;
192		procedure RunAll;
#	Line 186 | Line 200 | type
200		property Quiet: boolean read FQuiet;
201		end;
202
203	+	{ TMsgHash }
204	+
205	+	TMsgHash = class
206	+	private
207	+	FFinalised: boolean;
208	+	protected
209	+	procedure CheckNotFinalised;
210	+	public
211	+	procedure AddText(aText: AnsiString); virtual; abstract;
212	+	procedure Finalise; virtual;
213	+	function SameHash(otherHash: TMsgHash): boolean;
214	+	function Digest: AnsiString; virtual; abstract;
215	+	class function CreateMsgHash: TMsgHash;
216	+	property Finalised: boolean read FFinalised;
217	+	end;
218	+
219		ESkipException = class(Exception);
220
221		var
#	Line 197 | Line 227 | procedure RegisterTest(aTest: TTest);
227
228		implementation
229
230	+	{$IFNDEF MSWINDOWS}
231	+	uses MD5;
232	+	{$ENDIF}
233	+
234		{$IFDEF MSWINDOWS}
235	<	uses windows;
235	>	uses {$IFDEF FPC}MD5,{$ENDIF} windows;
236
237		function GetTempDir: AnsiString;
238		var
#	Line 219 | Line 253 | begin
253		//    test.CreateObjects(TestApp);
254		end;
255
256	+	{$IFDEF FPC}
257	+	type
258	+
259	+	{ TMD5MsgHash }
260	+
261	+	TMD5MsgHash = class(TMsgHash)
262	+	private
263	+	FMD5Context: TMDContext;
264	+	FDigest: TMDDigest;
265	+	public
266	+	constructor Create;
267	+	procedure AddText(aText: AnsiString); override;
268	+	procedure Finalise; override;
269	+	function Digest: AnsiString; override;
270	+	end;
271	+
272	+	{$DEFINE MSG_HASH_AVAILABLE}
273	+
274	+	{ TMD5MsgHash }
275	+
276	+	constructor TMD5MsgHash.Create;
277	+	begin
278	+	inherited Create;
279	+	MDInit(FMD5Context,MD_VERSION_5);
280	+	end;
281	+
282	+	procedure TMD5MsgHash.AddText(aText: AnsiString);
283	+	begin
284	+	CheckNotFinalised;
285	+	MDUpdate(FMD5Context,PAnsiChar(aText)^,Length(aText));
286	+	end;
287	+
288	+	procedure TMD5MsgHash.Finalise;
289	+	begin
290	+	CheckNotFinalised;
291	+	MDFinal(FMD5Context,FDigest);
292	+	inherited Finalise;
293	+	end;
294	+
295	+	function TMD5MsgHash.Digest: AnsiString;
296	+	begin
297	+	if not FFinalised then
298	+	Finalise;
299	+	Result :=  MD5Print(FDigest);
300	+	end;
301	+
302	+	class function TMsgHash.CreateMsgHash: TMsgHash;
303	+	begin
304	+	Result := TMD5MsgHash.Create;
305	+	end;
306	+	{$ENDIF}
307	+
308	+	{$IFNDEF MSG_HASH_AVAILABLE}
309	+	type
310	+
311	+	{ TSimpleMsgHash }
312	+
313	+	TSimpleMsgHash = class(TMsgHash)
314	+	private
315	+	FDigest: Int64;
316	+	Finalised: boolean;
317	+	public
318	+	procedure AddText(aText: AnsiString); override;
319	+	function Digest: AnsiString; override;
320	+	end;
321	+
322	+	{ TSimpleMsgHash }
323	+
324	+	procedure TSimpleMsgHash.AddText(aText: AnsiString);
325	+	const
326	+	modulus = high(Int64) div 100;
327	+	var i: integer;
328	+	begin
329	+	CheckNotFinalised;
330	+	for i := 1 to length(aText) do
331	+	FDigest := (FDigest * 7 + ord(aText[i])) mod modulus;
332	+	end;
333	+
334	+	function TSimpleMsgHash.Digest: AnsiString;
335	+	begin
336	+	if not Finalised then
337	+	Finalise;
338	+	Result := IntToStr(FDigest);
339	+	end;
340	+
341	+	class function TMsgHash.CreateMsgHash: TMsgHash;
342	+	begin
343	+	Result := TSimpleMsgHash.Create;
344	+	end;
345	+
346	+	{$ENDIF}
347	+
348	+	procedure TMsgHash.CheckNotFinalised;
349	+	begin
350	+	if FFinalised then
351	+	raise Exception.Create('Digest has been finalised');
352	+	end;
353	+
354	+	procedure TMsgHash.Finalise;
355	+	begin
356	+	FFinalised := true;
357	+	end;
358	+
359	+	function TMsgHash.SameHash(otherHash: TMsgHash): boolean;
360	+	begin
361	+	Result := Digest = OtherHash.Digest;
362	+	end;
363	+
364		{ TTestBase }
365
366		constructor TTestBase.Create(aOwner: TTestApplication);
367		begin
368		inherited Create;
369		FOwner := aOwner;
370	+	FFloatTpl := '#,###.00';
371		end;
372
373		function TTestBase.ChildProcess: boolean;
#	Line 247 | Line 390 | begin
390		FOwner := AOwner;
391		end;
392
393	+	{$if declared(TJnlEntry)}
394	+	procedure TTestBase.HandleOnJnlEntry(JnlEntry: TJnlEntry);
395	+	begin
396	+	with JnlEntry do
397	+	begin
398	+	{$IFNDEF FPC}
399	+	writeln(OutFile,'Journal Entry = ',ord(JnlEntryType),'(', TJournalProcessor.JnlEntryText(JnlEntryType),')');
400	+	{$ELSE}
401	+	writeln(OutFile,'Journal Entry = ',JnlEntryType,'(', TJournalProcessor.JnlEntryText(JnlEntryType),')');
402	+	{$ENDIF}
403	+	writeln(OutFIle,'Timestamp = ',FBFormatDateTime('yyyy/mm/dd hh:nn:ss.zzzz',Timestamp));
404	+	writeln(OutFile,'Session ID = ',SessionID);
405	+	writeln(OutFile,'Transaction ID = ',TransactionID);
406	+	case JnlEntry.JnlEntryType of
407	+	jeTransStart:
408	+	begin
409	+	writeln(OutFile,'Transaction Name = "',TransactionName,'"');
410	+	PrintTPB(TPB);
411	+	{$IFNDEF FPC}
412	+	writeln(OutFile,'Default Completion = ',ord(DefaultCompletion));
413	+	{$ELSE}
414	+	writeln(OutFile,'Default Completion = ',DefaultCompletion);
415	+	{$ENDIF}
416	+	end;
417	+
418	+	jeQuery:
419	+	begin
420	+	writeln(OutFile,'Query = ',QueryText);
421	+	end;
422	+
423	+	jeTransCommitRet,
424	+	jeTransRollbackRet:
425	+	writeln(Outfile,'Old TransactionID = ',OldTransactionID);
426	+	end;
427	+	end;
428	+	writeln(OutFile);
429	+	end;
430	+	{$ifend}
431	+
432		procedure TTestBase.DumpBCD(bcd: tBCD);
433		var i,l: integer;
434		begin
#	Line 420 | Line 602 | begin
602		writeln(OutFile,'Charset id = ',getCharSetID);
603		if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
604		writeln(OutFile,'Size = ',GetSize);
605	+	if not IsNull then
606	+	writeln(Outfile,'Value = ',getAsString);
607		writeln(OutFile);
608		end;
609		end;
610
611	<	function TTestBase.ReportResults(Statement: IStatement): IResultSet;
611	>	{$if declared(TJnlEntry) }
612	>	procedure TTestBase.PrintJournalFile(aFileName: AnsiString);
613	>	begin
614	>	writeln(OutFile,'Journal Entries');
615	>	with TJournalProcessor.Create do
616	>	try
617	>	Execute(aFileName,FirebirdAPI,HandleOnJnlEntry);
618	>	finally
619	>	Free
620	>	end;
621	>	end;
622	>
623	>	procedure TTestBase.PrintJournalTable(Attachment: IAttachment);
624	>	var Results: IResultSet;
625	>	begin
626	>	writeln(OutFile,'Journal Table');
627	>	Results := Attachment.OpenCursorAtStart('Select * From IBX$JOURNALS');
628	>	while not Results.IsEof do
629	>	begin
630	>	ReportResult(Results);
631	>	Results.Fetchnext;
632	>	end;
633	>	end;
634	>	{$ifend}
635	>
636	>	function TTestBase.ReportResults(Statement: IStatement; ShowCursorName: boolean): IResultSet;
637		begin
638		Result := Statement.OpenCursor;
639		try
640	+	if ShowCursorName then
641	+	writeln(Outfile,'Results for Cursor: ',Result.GetCursorName);
642		while Result.FetchNext do
643		ReportResult(Result);
644		finally
#	Line 479 | Line 690 | begin
690		end;
691		end;
692
693	+	procedure TTestBase.WriteAttachmentInfo(Attachment: IAttachment);
694	+	begin
695	+	writeln(outfile,'DB Connect String = ',Attachment.GetConnectString);
696	+	writeln(outfile,'DB Charset ID = ',Attachment.GetDefaultCharSetID);
697	+	writeln(outfile,'DB SQL Dialect = ',Attachment.GetSQLDialect);
698	+	writeln(outfile,'DB Remote Protocol = ', Attachment.GetRemoteProtocol);
699	+	writeln(outfile,'DB ODS Major Version = ',Attachment.GetODSMajorVersion);
700	+	writeln(outfile,'DB ODS Minor Version = ',Attachment.GetODSMinorVersion);
701	+	writeln(outfile,'User Authentication Method = ',Attachment.GetAuthenticationMethod);
702	+	writeln(outfile,'Firebird Library Path = ',Attachment.getFirebirdAPI.GetFBLibrary.GetLibraryFilePath);
703	+	writeln(outfile,'DB Client Implementation Version = ',Attachment.getFirebirdAPI.GetImplementationVersion);
704	+	end;
705	+
706		procedure TTestBase.WriteArray(ar: IArray);
707		var Bounds: TArrayBounds;
708		i,j: integer;
#	Line 632 | Line 856 | begin
856		end;
857		end;
858
859	+	procedure TTestBase.WriteTRInfo(TrInfo: ITrInformation);
860	+	var IsolationType, RecVersion: byte;
861	+	i: integer;
862	+	access: integer;
863	+	begin
864	+	for i := 0 to TrInfo.GetCount - 1 do
865	+	with TrInfo[i] do
866	+	case getItemType of
867	+	isc_info_tra_id:
868	+	writeln(OutFile,'Transaction ID = ',getAsInteger);
869	+	isc_info_tra_oldest_interesting:
870	+	writeln(OutFile,'Oldest Interesting = ',getAsInteger);
871	+	isc_info_tra_oldest_active:
872	+	writeln(OutFile,'Oldest Action = ',getAsInteger);
873	+	isc_info_tra_oldest_snapshot:
874	+	writeln(OutFile,'Oldest Snapshot = ',getAsInteger);
875	+	fb_info_tra_snapshot_number:
876	+	writeln(OutFile,'Oldest Snapshot Number = ',getAsInteger);
877	+	isc_info_tra_lock_timeout:
878	+	writeln(OutFile,'Lock Timeout = ',getAsInteger);
879	+	isc_info_tra_isolation:
880	+	begin
881	+	DecodeTraIsolation(IsolationType, RecVersion);
882	+	write(OutFile,'Isolation Type = ');
883	+	case IsolationType of
884	+	isc_info_tra_consistency:
885	+	write(OutFile,'isc_info_tra_consistency');
886	+	isc_info_tra_concurrency:
887	+	write(OutFile,'isc_info_tra_concurrency');
888	+	isc_info_tra_read_committed:
889	+	begin
890	+	write(OutFile,'isc_info_tra_read_committed, Options =');
891	+	case RecVersion of
892	+	isc_info_tra_no_rec_version:
893	+	write(OutFile,'isc_info_tra_no_rec_version');
894	+	isc_info_tra_rec_version:
895	+	write(OutFile,'isc_info_tra_rec_version');
896	+	isc_info_tra_read_consistency:
897	+	write(OutFile,'isc_info_tra_read_consistency');
898	+	end;
899	+	end;
900	+	end;
901	+	writeln(OutFile);
902	+	end;
903	+	isc_info_tra_access:
904	+	begin
905	+	write(OutFile,'Transaction Access = ');
906	+	access :=  getAsInteger;
907	+	case access of
908	+	isc_info_tra_readonly:
909	+	writeln(OutFile,'isc_info_tra_readonly');
910	+	isc_info_tra_readwrite:
911	+	writeln(OutFile,'isc_info_tra_readwrite');
912	+	end;
913	+	end;
914	+	fb_info_tra_dbpath:
915	+	writeln(OutFile,'Transaction Database Path = ',getAsString);
916	+	end;
917	+
918	+	end;
919	+
920		procedure TTestBase.WriteBytes(Bytes: TByteArray);
921		var i: integer;
922		begin
#	Line 699 | Line 984 | begin
984		end;
985		SQL_FLOAT,SQL_DOUBLE,
986		SQL_D_FLOAT:
987	<	writeln(OutFile, aValue.Name,' = ',FormatFloat('#,##0.00',aValue.AsFloat));
987	>	writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble));
988
989		SQL_INT64:
990		if aValue.Scale <> 0 then
991	<	writeln(OutFile, aValue.Name,' = ',FormatFloat('#,##0.00',aValue.AsFloat))
991	>	writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble))
992		else
993		writeln(OutFile,aValue.Name,' = ',aValue.AsString);
994
#	Line 728 | Line 1013 | begin
1013		end
1014		end
1015		else
1016	+	begin
1017		writeln(OutFile,aValue.Name,' = (blob), Length = ',aValue.AsBlob.GetBlobSize);
1018	+	if FShowBinaryBlob then
1019	+	PrintHexString(aValue.AsString);
1020	+	end;
1021
1022		SQL_TEXT,SQL_VARYING:
1023		begin
#	Line 810 | Line 1099 | begin
1099		//Do nothing
1100		end;
1101
1102	+	procedure TTestBase.SetFloatTemplate(tpl: Ansistring);
1103	+	begin
1104	+	FFloatTpl := tpl;
1105	+	end;
1106	+
1107		{ TTestApplication }
1108
1109		class procedure TTestApplication.CreateTestList;
#	Line 858 | Line 1152 | end;
1152		function TTestApplication.GetFirebirdAPI: IFirebirdAPI;
1153		begin
1154		if FFirebirdAPI = nil then
1155	+	begin
1156		FFirebirdAPI := IB.FirebirdAPI;
1157	+	FFirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);;
1158	+	end;
1159		Result := FFirebirdAPI;
1160		end;
1161
#	Line 926 | Line 1223 | begin
1223		Result := MakeConnectString(FServer,  FNewDatabaseName, inet,FPortNo);
1224		end;
1225
1226	+	function TTestApplication.GetTempDatabaseName: AnsiString;
1227	+	begin
1228	+	Result := GetTempDir + 'fbtest.fbd';
1229	+	end;
1230	+
1231		function TTestApplication.GetSecondNewDatabaseName: AnsiString;
1232		begin
1233		if FirebirdAPI.GetClientMajor < 3 then
#	Line 948 | Line 1250 | begin
1250		DoTest(i);
1251		if not Quiet then
1252		writeln(Outfile,'------------------------------------------------------');
1253	+	Sleep(500);
1254		end;
1255		end;
1256
#	Line 1219 | Line 1522 | begin
1522		RunAll
1523		else
1524		RunTest(TestID);
1525	+	CleanUp;
1526		except on E: Exception do
1527		begin
1528		writeln('Exception: ',E.Message);

Comparing ibx/trunk/fbintf/testsuite/testApp/TestApplication.pas (property svn:eol-style):
Revision 334 by tony, Fri Feb 26 16:43:23 2021 UTC vs.
Revision 380 by tony, Mon Jan 10 10:13:17 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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