testsuite/clienttestbed/Test02.pas

(*
 *  Firebird UDR Support (fbudrtestbed). The fbudr components provide a set of
 *  Pascal language bindings for the Firebird API in support of server
 *  side User Defined Routines (UDRs). The fbudr package is an extension
 *  to the Firebird Pascal API.
 *
 *  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) 2021 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit Test02;

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

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

 {Execute Procedure Tests}

interface

uses
  Classes, SysUtils, TestApplication, FBUDRTestApp, IB, FBUdrPlugin;

type

  {Test 02 is used to perform client side testing (UDR engine emulation) for the
   UDR Execute Procedure declared in udr_test02.pas.}

  { TTest02 }

  TTest02 = class(TFBUDRTestBase)
  private
    procedure DoQuery(Attachment: IAttachment);
    procedure DoErrorProcs(Attachment: IAttachment);
  protected
    function GetTestID: AnsiString; override;
    function GetTestTitle: AnsiString; override;
  public
    procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
  end;


implementation

{ TTest02 }

{This procedure is called to return the salary and full name of employee 24}

procedure TTest02.DoQuery(Attachment: IAttachment);
var MyTestProc: TExternalProcedureWrapper;
    Transaction: ITransaction;
    Results: IProcedureResults;
begin
  UDRPlugin.Attachment := Attachment;
  MyTestProc := UDRPlugin.makeProcedure('MYTESTPROC','','fbudrtests!test_proc');
  try
    writeln(OutFile,'Salary and Name of Employee 24');
    MyTestProc.InputParams[0].AsInteger := 24;
    ParamInfo(MyTestProc.InputParams);
    Transaction := Attachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
    Results := MyTestProc.Execute(Transaction);
    if Results.FetchNext then
    begin
      writeln(OutFile,'Salary = ',Results[0].AsString);
      writeln(OutFile,Results[1].AsString);
    end;
    writeln(OutFile);
  finally
    MyTestProc.Free;
  end;
end;

procedure TTest02.DoErrorProcs(Attachment: IAttachment);
var i: integer;
    ErrorProc: TExternalProcedureWrapper;
    Transaction: ITransaction;
    Results: IProcedureResults;
begin
  UDRPlugin.Attachment := Attachment;
  for i := 0 to 2 do
  begin
    writeln(OutFile,'Error Proc ',i);
    ErrorProc := UDRPlugin.makeProcedure('MYERRORPROC','','fbudrtests!error_proc');
    try
      ErrorProc.InputParams[0].AsInteger := i;
      Transaction := Attachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
      try
        Results := ErrorProc.Execute(Transaction);
      except on E:Exception do
        writeln(OutFile,'Error Proc ',i,' returns with: ',E.Message);
      end;
    finally
      ErrorProc.Free;
    end;
  end;
end;

function TTest02.GetTestID: AnsiString;
begin
  Result := '02';
end;

function TTest02.GetTestTitle: AnsiString;
begin
  Result := 'Execute Procedure Tests';
end;

const
  DDL: array [0..1] of Ansistring = ('create or alter procedure MyTestProc ('+
                                     'EMP_NO SMALLINT '+
                                     ') returns (Salary Numeric(10,2), FullName VarChar(36)) as begin end',
                                     'Create or Alter procedure MyErrorProc ('+
                                       'ErrorCase Smallint) as begin end'
                                     );

  CleanUpDDL: array [0..1] of Ansistring = ('Drop procedure MyTestProc',
                                            'Drop procedure MyErrorProc'
                                            );
  {The test is run using the employee database. Note that a dummy version of the
   UDR Execute procedure must be declared in the database in order to generate the input
   and output parameter metadata. These are always (re-)defined when the test is
   started and removed at the end.
   }


procedure TTest02.RunTest(CharSet: AnsiString; SQLDialect: integer);
var Attachment: IAttachment;
    DPB: IDPB;
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(CharSet);
  DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
  Attachment := FirebirdAPI.OpenDatabase(Owner.GetEmployeeDatabaseName,DPB);
  try
    if Attachment.HasProcedure('MYTESTPROC') then
      ApplyDDL(Attachment,CleanUpDDL);
    ApplyDDL(Attachment,DDL);
    DoQuery(Attachment);
    DoErrorProcs(Attachment);
  finally
    ApplyDDL(Attachment,CleanUpDDL);
    Attachment.Disconnect;
  end;
end;

initialization
  RegisterTest(TTest02);

end.

Revision:	392
Committed:	Wed Feb 9 16:17:50 2022 UTC (2 years, 2 months ago) by tony
Content type:	text/x-pascal
File size:	5340 byte(s)
Log Message:	cloneAttachment and GetServiceManager added
#	Content
1	(*
2	* Firebird UDR Support (fbudrtestbed). The fbudr components provide a set of
3	* Pascal language bindings for the Firebird API in support of server
4	* side User Defined Routines (UDRs). The fbudr package is an extension
5	* to the Firebird Pascal API.
6	*
7	* The contents of this file are subject to the Initial Developer's
8	* Public License Version 1.0 (the "License"); you may not use this
9	* file except in compliance with the License. You may obtain a copy
10	* of the License here:
11	*
12	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
13	*
14	* Software distributed under the License is distributed on an "AS
15	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
16	* implied. See the License for the specific language governing rights
17	* and limitations under the License.
18	*
19	* The Initial Developer of the Original Code is Tony Whyman.
20	*
21	* The Original Code is (C) 2021 Tony Whyman, MWA Software
22	* (http://www.mwasoftware.co.uk).
23	*
24	* All Rights Reserved.
25	*
26	* Contributor(s): ______________________________________.
27	*
28	*)
29	unit Test02;
30
31	{$IFDEF MSWINDOWS}
32	{$DEFINE WINDOWS}
33	{$ENDIF}
34
35	{$IFDEF FPC}
36	{$mode delphi}
37	{$codepage utf8}
38	{$ENDIF}
39
40	{Execute Procedure Tests}
41
42	interface
43
44	uses
45	Classes, SysUtils, TestApplication, FBUDRTestApp, IB, FBUdrPlugin;
46
47	type
48
49	{Test 02 is used to perform client side testing (UDR engine emulation) for the
50	UDR Execute Procedure declared in udr_test02.pas.}
51
52	{ TTest02 }
53
54	TTest02 = class(TFBUDRTestBase)
55	private
56	procedure DoQuery(Attachment: IAttachment);
57	procedure DoErrorProcs(Attachment: IAttachment);
58	protected
59	function GetTestID: AnsiString; override;
60	function GetTestTitle: AnsiString; override;
61	public
62	procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override;
63	end;
64
65
66	implementation
67
68	{ TTest02 }
69
70	{This procedure is called to return the salary and full name of employee 24}
71
72	procedure TTest02.DoQuery(Attachment: IAttachment);
73	var MyTestProc: TExternalProcedureWrapper;
74	Transaction: ITransaction;
75	Results: IProcedureResults;
76	begin
77	UDRPlugin.Attachment := Attachment;
78	MyTestProc := UDRPlugin.makeProcedure('MYTESTPROC','','fbudrtests!test_proc');
79	try
80	writeln(OutFile,'Salary and Name of Employee 24');
81	MyTestProc.InputParams[0].AsInteger := 24;
82	ParamInfo(MyTestProc.InputParams);
83	Transaction := Attachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
84	Results := MyTestProc.Execute(Transaction);
85	if Results.FetchNext then
86	begin
87	writeln(OutFile,'Salary = ',Results[0].AsString);
88	writeln(OutFile,Results[1].AsString);
89	end;
90	writeln(OutFile);
91	finally
92	MyTestProc.Free;
93	end;
94	end;
95
96	procedure TTest02.DoErrorProcs(Attachment: IAttachment);
97	var i: integer;
98	ErrorProc: TExternalProcedureWrapper;
99	Transaction: ITransaction;
100	Results: IProcedureResults;
101	begin
102	UDRPlugin.Attachment := Attachment;
103	for i := 0 to 2 do
104	begin
105	writeln(OutFile,'Error Proc ',i);
106	ErrorProc := UDRPlugin.makeProcedure('MYERRORPROC','','fbudrtests!error_proc');
107	try
108	ErrorProc.InputParams[0].AsInteger := i;
109	Transaction := Attachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
110	try
111	Results := ErrorProc.Execute(Transaction);
112	except on E:Exception do
113	writeln(OutFile,'Error Proc ',i,' returns with: ',E.Message);
114	end;
115	finally
116	ErrorProc.Free;
117	end;
118	end;
119	end;
120
121	function TTest02.GetTestID: AnsiString;
122	begin
123	Result := '02';
124	end;
125
126	function TTest02.GetTestTitle: AnsiString;
127	begin
128	Result := 'Execute Procedure Tests';
129	end;
130
131	const
132	DDL: array [0..1] of Ansistring = ('create or alter procedure MyTestProc ('+
133	'EMP_NO SMALLINT '+
134	') returns (Salary Numeric(10,2), FullName VarChar(36)) as begin end',
135	'Create or Alter procedure MyErrorProc ('+
136	'ErrorCase Smallint) as begin end'
137	);
138
139	CleanUpDDL: array [0..1] of Ansistring = ('Drop procedure MyTestProc',
140	'Drop procedure MyErrorProc'
141	);
142	{The test is run using the employee database. Note that a dummy version of the
143	UDR Execute procedure must be declared in the database in order to generate the input
144	and output parameter metadata. These are always (re-)defined when the test is
145	started and removed at the end.
146	}
147
148
149	procedure TTest02.RunTest(CharSet: AnsiString; SQLDialect: integer);
150	var Attachment: IAttachment;
151	DPB: IDPB;
152	begin
153	DPB := FirebirdAPI.AllocateDPB;
154	DPB.Add(isc_dpb_user_name).setAsString(Owner.GetUserName);
155	DPB.Add(isc_dpb_password).setAsString(Owner.GetPassword);
156	DPB.Add(isc_dpb_lc_ctype).setAsString(CharSet);
157	DPB.Add(isc_dpb_set_db_SQL_dialect).setAsByte(SQLDialect);
158	Attachment := FirebirdAPI.OpenDatabase(Owner.GetEmployeeDatabaseName,DPB);
159	try
160	if Attachment.HasProcedure('MYTESTPROC') then
161	ApplyDDL(Attachment,CleanUpDDL);
162	ApplyDDL(Attachment,DDL);
163	DoQuery(Attachment);
164	DoErrorProcs(Attachment);
165	finally
166	ApplyDDL(Attachment,CleanUpDDL);
167	Attachment.Disconnect;
168	end;
169	end;
170
171	initialization
172	RegisterTest(TTest02);
173
174	end.
175