testsuite/udrlib/udr_test03.pas

(*
 *  Firebird UDR Support (fbudrtested). 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 udr_test03;

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

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

interface

uses
  Classes, SysUtils, IB, FBUDRController, FBUDRIntf;

  {This unit provides the implementation of selected number of UDR Select
   procedures used to test out various aspects of the TFBUDRSelectProcedure class.
   Note that each class is registered with the FBUDRController at initialization time.}

type
  {TMySelectProcedure implements a simple select procedure to return the
   list of employee salaries plus a line by line accumulator. The employee
   database is assumed.

   create or alter procedure MySelectProc ()
    returns (FullName VarChar(36), Salary Numeric(10,2), AccSalary Numeric(10,2) )
    external name 'fbudrtests!select_proc'
    engine udr;
   }

  TMySelectProcedure  = class(TFBUDRSelectProcedure)
  private
    FAccSalary: currency;
    FResults: IResultset;
  public
    procedure open(context: IFBUDRExternalContext;
                     ProcMetadata: IFBUDRProcMetadata;
                     InputParams: IFBUDRInputParams); override;
    function fetch(OutputData: IFBUDROutputData): boolean; override;
    procedure close; override;
  end;

implementation

{ TMySelectProcedure }

{open is called first and opens the cursor. The IResultset returned is saved
 as a private property of the class, and the accumulator is initialized to zero.}

procedure TMySelectProcedure.open(context: IFBUDRExternalContext;
  ProcMetadata: IFBUDRProcMetadata; InputParams: IFBUDRInputParams);
begin
  with context do
   FResults := GetAttachment.OpenCursor(GetTransaction,'Select Full_Name,Salary from EMPLOYEE order by EMP_NO');
  FAccSalary := 0;
end;

{fetch is called to return each row in the OutputData. The function returns
 false when at EOF.}

function TMySelectProcedure.fetch(OutputData: IFBUDROutputData): boolean;
begin
  Result := (FResults <> nil) and FResults.FetchNext;
  if Result then
  begin
    FAccSalary := FAccSalary + FResults.ByName('Salary').AsCurrency;
    OutputData.ByName('FullName').AsString := FResults.ByName('Full_Name').AsString;
    OutputData.ByName('Salary').AsCurrency := FResults.ByName('Salary').AsCurrency;
    OutputData.ByName('AccSalary').AsCurrency := FAccSalary;
  end;
end;

{close is called after fetch returned EOF. Here is is used to explicitly close
 the cursor. Although this will be closed automatically when the class is
 freed, or open called again.}

procedure TMySelectProcedure.close;
begin
  FResults := nil;
end;

Initialization
  FBRegisterUDRProcedure('select_proc',TMySelectProcedure);


end.

Revision:	371
Committed:	Wed Jan 5 15:21:22 2022 UTC (2 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	3689 byte(s)
Log Message:	Beta Release 0.1
#	User	Rev	Content
1	tony	371	(*
2			* Firebird UDR Support (fbudrtested). 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 udr_test03;
30
31			{$IFDEF MSWINDOWS}
32			{$DEFINE WINDOWS}
33			{$ENDIF}
34
35			{$IFDEF FPC}
36			{$mode delphi}
37			{$codepage UTF8}
38			{$interfaces COM}
39			{$ENDIF}
40
41			interface
42
43			uses
44			Classes, SysUtils, IB, FBUDRController, FBUDRIntf;
45
46			{This unit provides the implementation of selected number of UDR Select
47			procedures used to test out various aspects of the TFBUDRSelectProcedure class.
48			Note that each class is registered with the FBUDRController at initialization time.}
49
50			type
51			{TMySelectProcedure implements a simple select procedure to return the
52			list of employee salaries plus a line by line accumulator. The employee
53			database is assumed.
54
55			create or alter procedure MySelectProc ()
56			returns (FullName VarChar(36), Salary Numeric(10,2), AccSalary Numeric(10,2) )
57			external name 'fbudrtests!select_proc'
58			engine udr;
59			}
60
61			TMySelectProcedure = class(TFBUDRSelectProcedure)
62			private
63			FAccSalary: currency;
64			FResults: IResultset;
65			public
66			procedure open(context: IFBUDRExternalContext;
67			ProcMetadata: IFBUDRProcMetadata;
68			InputParams: IFBUDRInputParams); override;
69			function fetch(OutputData: IFBUDROutputData): boolean; override;
70			procedure close; override;
71			end;
72
73			implementation
74
75			{ TMySelectProcedure }
76
77			{open is called first and opens the cursor. The IResultset returned is saved
78			as a private property of the class, and the accumulator is initialized to zero.}
79
80			procedure TMySelectProcedure.open(context: IFBUDRExternalContext;
81			ProcMetadata: IFBUDRProcMetadata; InputParams: IFBUDRInputParams);
82			begin
83			with context do
84			FResults := GetAttachment.OpenCursor(GetTransaction,'Select Full_Name,Salary from EMPLOYEE order by EMP_NO');
85			FAccSalary := 0;
86			end;
87
88			{fetch is called to return each row in the OutputData. The function returns
89			false when at EOF.}
90
91			function TMySelectProcedure.fetch(OutputData: IFBUDROutputData): boolean;
92			begin
93			Result := (FResults <> nil) and FResults.FetchNext;
94			if Result then
95			begin
96			FAccSalary := FAccSalary + FResults.ByName('Salary').AsCurrency;
97			OutputData.ByName('FullName').AsString := FResults.ByName('Full_Name').AsString;
98			OutputData.ByName('Salary').AsCurrency := FResults.ByName('Salary').AsCurrency;
99			OutputData.ByName('AccSalary').AsCurrency := FAccSalary;
100			end;
101			end;
102
103			{close is called after fetch returned EOF. Here is is used to explicitly close
104			the cursor. Although this will be closed automatically when the class is
105			freed, or open called again.}
106
107			procedure TMySelectProcedure.close;
108			begin
109			FResults := nil;
110			end;
111
112			Initialization
113			FBRegisterUDRProcedure('select_proc',TMySelectProcedure);
114
115
116			end.
117