fbintf/testsuite/Test20.pas

(*
 *  Firebird Interface (fbintf) Test suite. This program is used to
 *  test the Firebird Pascal Interface and provide a semi-automated
 *  pass/fail check for each test.
 *
 *  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) 2020 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)

unit Test20;

{$IFDEF MSWINDOWS}
{$DEFINE WINDOWS}
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$codepage UTF8}
{$ENDIF}

{ $DEFINE USELOCALDATABASE} //Remote fails - see https://github.com/FirebirdSQL/firebird/issues/6900

{Test 20: stress test IBatch interface}

interface

uses
  Classes, SysUtils, TestApplication, FBTestApp, IB {$IFDEF WINDOWS},Windows{$ENDIF};

type

  { TTest20 }

  TTest20 = class(TFBTestBase)
  private
    procedure DoTest(Attachment: IAttachment);
    procedure WriteBatchCompletion(bc: IBatchCompletion);
  public
    function TestTitle: AnsiString; override;
    procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
  end;


implementation

uses IBUtils;

const
   sqlCreateTable = 'Create Table LotsOfData ('+
    'RowID integer not null,'+
    'theDate TimeStamp,'+
    'MyText VarChar(1024),'+
    'Primary Key (RowID)'+
  ');';

{ TTest20 }

procedure TTest20.WriteBatchCompletion(bc: IBatchCompletion);
var updated: integer;
begin
if bc <> nil then
  with bc do
  begin
    writeln(OutFile,'Batch Completion Info');
    writeln(OutFile,'Total rows processed = ',getTotalProcessed);
    updated := getUpdated;
    writeln(Outfile,'Updated Rows = ',updated);
    if updated > 0 then
    {$IFDEF FPC}
      writeln(Outfile,'Row ',updated,' State = ',getState(updated-1),' Msg = ',getStatusMessage(updated-1));
    {$ELSE}
      writeln(Outfile,'Row ',updated,' State = ',ord(getState(updated-1)),' Msg = ',getStatusMessage(updated-1));
    {$ENDIF}
  end;
end;

const
   RecordCount = 100000;
   RowLimit    = 50000;

procedure TTest20.DoTest(Attachment: IAttachment);
var Transaction: ITransaction;
    Statement: IStatement;
    i: integer;
    rows: integer;
    BC: IBatchCompletion;
    InMsgHash, OutMsgHash: TMsgHash;
    HashString: AnsiString;
    Results: IResultSet;
begin
  Attachment.getFirebirdAPI.getStatus.SetIBDataBaseErrorMessages([ShowSQLCode,
                                   ShowIBMessage,
                                   ShowSQLMessage]);
  Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
  Statement := Attachment.Prepare(Transaction,'insert into LotsOfData values(?, current_timestamp, ?)');
  InMsgHash := TMsgHash.CreateMsgHash;
  rows := 0;
  Statement.SetBatchRowLimit(RowLimit);
  try
    for i := 1 to RecordCount do
    begin
       Statement.SQLParams[0].AsInteger := i;
       HashString := Format('asdbfkwfwf83274kjdfj0usd0uj329j9rfh38fvhuhsijf9u28rf4329jf-j9rghvvsw89rgf8yh%d', [i * 2]);
       Statement.SQLParams[1].AsString := HashString;
       InMsgHash.AddText(HashString);
       Inc(rows);
       if rows mod 10000 = 0 then
         writeln(Outfile,rows,' rows added');
       try
         Statement.AddToBatch;
       except
         on E: EIBBatchBufferOverflow do
           begin
             writeln(outfile,'Batch Execute');
             BC := Statement.ExecuteBatch;
             writeln(Outfile,'Intermediate Apply Batch on row ', i);
             WriteBatchCompletion(BC);
             Statement.AddToBatch;
           end
         else
           begin
             writeln(Outfile,'Exception raised on row ',i);
             raise;
           end;
       end;
    end;
    writeln(outfile,'Batch Execute');
    BC := Statement.ExecuteBatch;
    WriteBatchCompletion(BC);
    rows :=  Attachment.OpenCursorAtStart(Transaction,'Select count(*) From LOTSOFData')[0].AsInteger;
    writeln(Outfile,'Rows in Dataset = ',rows);
    InMsgHash.Finalise;
    writeln(Outfile,' Message Hash = ',InMsgHash.Digest);
    if rows <> RecordCount then
      writeln(Outfile,'Test Fails - expecting ',RecordCount,' rows - found ',rows);
    {Now check the table checksum}
    OutMsgHash := TMsgHash.CreateMsgHash;
    Results := Attachment.OpenCursor(Transaction,'Select MyText From LotsOfData Order by RowID');
    try
      while Results.FetchNext do
        OutMsgHash.AddText(Results[0].AsString);
      OutMsgHash.Finalise;
      writeln(Outfile,' Message Hash = ',OutMsgHash.Digest);
      if OutMsgHash.SameHash(InMsgHash) then
        writeln(Outfile,'Test Completed Successfully')
      else
        writeln(Outfile,'Test Failed - MD5 checksum error');
    finally
      OutMsgHash.Free;
    end;
  finally
    InMsgHash.Free;
  end;
end;


function TTest20.TestTitle: AnsiString;
begin
   Result := 'Test 20: Stress Test IBatch interface';
end;

procedure TTest20.RunTest(CharSet: AnsiString; SQLDialect: integer);
var DPB: IDPB;
    Attachment: IAttachment;
    VerStrings: TStringList;
begin
  DPB := FirebirdAPI.AllocateDPB;
  DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
  DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
  DPB.Add(isc_dpb_lc_ctype).setAsString('UTF8');
  DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
  {$IFDEF USELOCALDATABASE}
  Attachment := FirebirdAPI.CreateDatabase(Owner.GetTempDatabaseName,DPB);
  {$ELSE}
  Attachment := FirebirdAPI.CreateDatabase(Owner.GetNewDatabaseName,DPB);
  {$ENDIF}
  VerStrings := TStringList.Create;
  try
    Attachment.getFBVersion(VerStrings);
    writeln(OutFile,' FBVersion = ',VerStrings[0]);
  finally
    VerStrings.Free;
  end;

  try
    if (FirebirdAPI.GetClientMajor < 4) or (Attachment.GetODSMajorVersion < 13) then
      writeln(OutFile,'Skipping test for Firebird 4 and later')
    else
    begin
      Attachment.ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable);
      try
        DoTest(Attachment);
      except on E:Exception do
        begin
          writeln(OutFile,'Exception writing data batch');
          writeln(Outfile,E.Message);
          raise;
        end;
      end;
    end;
  finally
    Attachment.DropDatabase;
  end;
end;

initialization
  RegisterTest(TTest20);
end.

Revision:	351
Committed:	Wed Oct 20 15:04:35 2021 UTC (3 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	6763 byte(s)
Log Message:	Add Missing testsuite files
#	User	Rev	Content
1	tony	351	(*
2			* Firebird Interface (fbintf) Test suite. This program is used to
3			* test the Firebird Pascal Interface and provide a semi-automated
4			* pass/fail check for each test.
5			*
6			* The contents of this file are subject to the Initial Developer's
7			* Public License Version 1.0 (the "License"); you may not use this
8			* file except in compliance with the License. You may obtain a copy
9			* of the License here:
10			*
11			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
12			*
13			* Software distributed under the License is distributed on an "AS
14			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
15			* implied. See the License for the specific language governing rights
16			* and limitations under the License.
17			*
18			* The Initial Developer of the Original Code is Tony Whyman.
19			*
20			* The Original Code is (C) 2020 Tony Whyman, MWA Software
21			* (http://www.mwasoftware.co.uk).
22			*
23			* All Rights Reserved.
24			*
25			* Contributor(s): ______________________________________.
26			*
27			*)
28
29			unit Test20;
30
31			{$IFDEF MSWINDOWS}
32			{$DEFINE WINDOWS}
33			{$ENDIF}
34
35			{$IFDEF FPC}
36			{$mode delphi}
37			{$codepage UTF8}
38			{$ENDIF}
39
40			{ $DEFINE USELOCALDATABASE} //Remote fails - see https://github.com/FirebirdSQL/firebird/issues/6900
41
42			{Test 20: stress test IBatch interface}
43
44			interface
45
46			uses
47			Classes, SysUtils, TestApplication, FBTestApp, IB {$IFDEF WINDOWS},Windows{$ENDIF};
48
49			type
50
51			{ TTest20 }
52
53			TTest20 = class(TFBTestBase)
54			private
55			procedure DoTest(Attachment: IAttachment);
56			procedure WriteBatchCompletion(bc: IBatchCompletion);
57			public
58			function TestTitle: AnsiString; override;
59			procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
60			end;
61
62
63			implementation
64
65			uses IBUtils;
66
67			const
68			sqlCreateTable = 'Create Table LotsOfData ('+
69			'RowID integer not null,'+
70			'theDate TimeStamp,'+
71			'MyText VarChar(1024),'+
72			'Primary Key (RowID)'+
73			');';
74
75			{ TTest20 }
76
77			procedure TTest20.WriteBatchCompletion(bc: IBatchCompletion);
78			var updated: integer;
79			begin
80			if bc <> nil then
81			with bc do
82			begin
83			writeln(OutFile,'Batch Completion Info');
84			writeln(OutFile,'Total rows processed = ',getTotalProcessed);
85			updated := getUpdated;
86			writeln(Outfile,'Updated Rows = ',updated);
87			if updated > 0 then
88			{$IFDEF FPC}
89			writeln(Outfile,'Row ',updated,' State = ',getState(updated-1),' Msg = ',getStatusMessage(updated-1));
90			{$ELSE}
91			writeln(Outfile,'Row ',updated,' State = ',ord(getState(updated-1)),' Msg = ',getStatusMessage(updated-1));
92			{$ENDIF}
93			end;
94			end;
95
96			const
97			RecordCount = 100000;
98			RowLimit = 50000;
99
100			procedure TTest20.DoTest(Attachment: IAttachment);
101			var Transaction: ITransaction;
102			Statement: IStatement;
103			i: integer;
104			rows: integer;
105			BC: IBatchCompletion;
106			InMsgHash, OutMsgHash: TMsgHash;
107			HashString: AnsiString;
108			Results: IResultSet;
109			begin
110			Attachment.getFirebirdAPI.getStatus.SetIBDataBaseErrorMessages([ShowSQLCode,
111			ShowIBMessage,
112			ShowSQLMessage]);
113			Transaction := Attachment.StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
114			Statement := Attachment.Prepare(Transaction,'insert into LotsOfData values(?, current_timestamp, ?)');
115			InMsgHash := TMsgHash.CreateMsgHash;
116			rows := 0;
117			Statement.SetBatchRowLimit(RowLimit);
118			try
119			for i := 1 to RecordCount do
120			begin
121			Statement.SQLParams[0].AsInteger := i;
122			HashString := Format('asdbfkwfwf83274kjdfj0usd0uj329j9rfh38fvhuhsijf9u28rf4329jf-j9rghvvsw89rgf8yh%d', [i * 2]);
123			Statement.SQLParams[1].AsString := HashString;
124			InMsgHash.AddText(HashString);
125			Inc(rows);
126			if rows mod 10000 = 0 then
127			writeln(Outfile,rows,' rows added');
128			try
129			Statement.AddToBatch;
130			except
131			on E: EIBBatchBufferOverflow do
132			begin
133			writeln(outfile,'Batch Execute');
134			BC := Statement.ExecuteBatch;
135			writeln(Outfile,'Intermediate Apply Batch on row ', i);
136			WriteBatchCompletion(BC);
137			Statement.AddToBatch;
138			end
139			else
140			begin
141			writeln(Outfile,'Exception raised on row ',i);
142			raise;
143			end;
144			end;
145			end;
146			writeln(outfile,'Batch Execute');
147			BC := Statement.ExecuteBatch;
148			WriteBatchCompletion(BC);
149			rows := Attachment.OpenCursorAtStart(Transaction,'Select count(*) From LOTSOFData')[0].AsInteger;
150			writeln(Outfile,'Rows in Dataset = ',rows);
151			InMsgHash.Finalise;
152			writeln(Outfile,' Message Hash = ',InMsgHash.Digest);
153			if rows <> RecordCount then
154			writeln(Outfile,'Test Fails - expecting ',RecordCount,' rows - found ',rows);
155			{Now check the table checksum}
156			OutMsgHash := TMsgHash.CreateMsgHash;
157			Results := Attachment.OpenCursor(Transaction,'Select MyText From LotsOfData Order by RowID');
158			try
159			while Results.FetchNext do
160			OutMsgHash.AddText(Results[0].AsString);
161			OutMsgHash.Finalise;
162			writeln(Outfile,' Message Hash = ',OutMsgHash.Digest);
163			if OutMsgHash.SameHash(InMsgHash) then
164			writeln(Outfile,'Test Completed Successfully')
165			else
166			writeln(Outfile,'Test Failed - MD5 checksum error');
167			finally
168			OutMsgHash.Free;
169			end;
170			finally
171			InMsgHash.Free;
172			end;
173			end;
174
175
176			function TTest20.TestTitle: AnsiString;
177			begin
178			Result := 'Test 20: Stress Test IBatch interface';
179			end;
180
181			procedure TTest20.RunTest(CharSet: AnsiString; SQLDialect: integer);
182			var DPB: IDPB;
183			Attachment: IAttachment;
184			VerStrings: TStringList;
185			begin
186			DPB := FirebirdAPI.AllocateDPB;
187			DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
188			DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
189			DPB.Add(isc_dpb_lc_ctype).setAsString('UTF8');
190			DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
191			{$IFDEF USELOCALDATABASE}
192			Attachment := FirebirdAPI.CreateDatabase(Owner.GetTempDatabaseName,DPB);
193			{$ELSE}
194			Attachment := FirebirdAPI.CreateDatabase(Owner.GetNewDatabaseName,DPB);
195			{$ENDIF}
196			VerStrings := TStringList.Create;
197			try
198			Attachment.getFBVersion(VerStrings);
199			writeln(OutFile,' FBVersion = ',VerStrings[0]);
200			finally
201			VerStrings.Free;
202			end;
203
204			try
205			if (FirebirdAPI.GetClientMajor < 4) or (Attachment.GetODSMajorVersion < 13) then
206			writeln(OutFile,'Skipping test for Firebird 4 and later')
207			else
208			begin
209			Attachment.ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable);
210			try
211			DoTest(Attachment);
212			except on E:Exception do
213			begin
214			writeln(OutFile,'Exception writing data batch');
215			writeln(Outfile,E.Message);
216			raise;
217			end;
218			end;
219			end;
220			finally
221			Attachment.DropDatabase;
222			end;
223			end;
224
225			initialization
226			RegisterTest(TTest20);
227			end.
228