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{$IFDEF FPC}, Streamex{$ENDIF};

  {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;

  {TReadTextFile is a select procedure that reads lines from a text file and
   returns each line as successive rows.

   create or alter procedure MyReadText (
        path varchar(200) not null /*relative to udr directory */
        ) returns (
       text varchar(100) not null
   )
   external name 'fbudrtests!read_txt'
   engine udr;
}

  TReadTextFile  = class(TFBUDRSelectProcedure)
    private
      FTextFile: TStreamReader;
    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;

procedure TReadTextFile.open(context: IFBUDRExternalContext;
                 ProcMetadata: IFBUDRProcMetadata;
                 InputParams: IFBUDRInputParams);
var aFileName: AnsiString;
    {$IFDEF FPC}F: TFileStream;{$ENDIF}

begin
  context.WriteToLog('Read Text called in directory '+ GetCurrentDir);
  aFileName := InputParams.ByName('path').AsString;
  if not FileExists(aFileName) then
    raise Exception.CreateFmt('Unable to find file "%s"',[aFileName]);
  context.WriteToLog('Reading from ' + aFileName);
  {$IFDEF FPC}
  F := TFileStream.Create(aFileName,fmOpenRead);
  FTextFile := TStreamReader.Create(F,8192,true);
  {$ELSE}
  FTextFile := TStreamReader.Create(aFileName, TEncoding.ANSI);
  {$ENDIF}
end;

function TReadTextFile.fetch(OutputData: IFBUDROutputData): boolean;
begin
  Result := not FTextFile.{$IFDEF FPC}EOF{$ELSE}EndOfStream{$ENDIF};
  if Result then
    OutputData.ByName('text').AsString := FTextFile.ReadLine;
end;

procedure TReadTextFile.close;
begin
  if FTextFile <> nil then
    FTextFile.Free;
  FTextFile := nil;
end;

Initialization
  FBRegisterUDRProcedure('select_proc',TMySelectProcedure);
  FBRegisterUDRProcedure('read_txt',TReadTextFile);

end.

Revision:	373
Committed:	Thu Jan 6 14:14:57 2022 UTC (2 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	5569 byte(s)
Log Message:	Fixes Merged
#	Content
1	(*
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{$IFDEF FPC}, Streamex{$ENDIF};
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	{TReadTextFile is a select procedure that reads lines from a text file and
74	returns each line as successive rows.
75
76	create or alter procedure MyReadText (
77	path varchar(200) not null /relative to udr directory /
78	) returns (
79	text varchar(100) not null
80	)
81	external name 'fbudrtests!read_txt'
82	engine udr;
83	}
84
85	TReadTextFile = class(TFBUDRSelectProcedure)
86	private
87	FTextFile: TStreamReader;
88	public
89	procedure open(context: IFBUDRExternalContext;
90	ProcMetadata: IFBUDRProcMetadata;
91	InputParams: IFBUDRInputParams); override;
92	function fetch(OutputData: IFBUDROutputData): boolean; override;
93	procedure close; override;
94	end;
95
96	implementation
97
98	{ TMySelectProcedure }
99
100	{open is called first and opens the cursor. The IResultset returned is saved
101	as a private property of the class, and the accumulator is initialized to zero.}
102
103	procedure TMySelectProcedure.open(context: IFBUDRExternalContext;
104	ProcMetadata: IFBUDRProcMetadata; InputParams: IFBUDRInputParams);
105	begin
106	with context do
107	FResults := GetAttachment.OpenCursor(GetTransaction,'Select Full_Name,Salary from EMPLOYEE order by EMP_NO');
108	FAccSalary := 0;
109	end;
110
111	{fetch is called to return each row in the OutputData. The function returns
112	false when at EOF.}
113
114	function TMySelectProcedure.fetch(OutputData: IFBUDROutputData): boolean;
115	begin
116	Result := (FResults <> nil) and FResults.FetchNext;
117	if Result then
118	begin
119	FAccSalary := FAccSalary + FResults.ByName('Salary').AsCurrency;
120	OutputData.ByName('FullName').AsString := FResults.ByName('Full_Name').AsString;
121	OutputData.ByName('Salary').AsCurrency := FResults.ByName('Salary').AsCurrency;
122	OutputData.ByName('AccSalary').AsCurrency := FAccSalary;
123	end;
124	end;
125
126	{close is called after fetch returned EOF. Here is is used to explicitly close
127	the cursor. Although this will be closed automatically when the class is
128	freed, or open called again.}
129
130	procedure TMySelectProcedure.close;
131	begin
132	FResults := nil;
133	end;
134
135	procedure TReadTextFile.open(context: IFBUDRExternalContext;
136	ProcMetadata: IFBUDRProcMetadata;
137	InputParams: IFBUDRInputParams);
138	var aFileName: AnsiString;
139	{$IFDEF FPC}F: TFileStream;{$ENDIF}
140
141	begin
142	context.WriteToLog('Read Text called in directory '+ GetCurrentDir);
143	aFileName := InputParams.ByName('path').AsString;
144	if not FileExists(aFileName) then
145	raise Exception.CreateFmt('Unable to find file "%s"',[aFileName]);
146	context.WriteToLog('Reading from ' + aFileName);
147	{$IFDEF FPC}
148	F := TFileStream.Create(aFileName,fmOpenRead);
149	FTextFile := TStreamReader.Create(F,8192,true);
150	{$ELSE}
151	FTextFile := TStreamReader.Create(aFileName, TEncoding.ANSI);
152	{$ENDIF}
153	end;
154
155	function TReadTextFile.fetch(OutputData: IFBUDROutputData): boolean;
156	begin
157	Result := not FTextFile.{$IFDEF FPC}EOF{$ELSE}EndOfStream{$ENDIF};
158	if Result then
159	OutputData.ByName('text').AsString := FTextFile.ReadLine;
160	end;
161
162	procedure TReadTextFile.close;
163	begin
164	if FTextFile <> nil then
165	FTextFile.Free;
166	FTextFile := nil;
167	end;
168
169	Initialization
170	FBRegisterUDRProcedure('select_proc',TMySelectProcedure);
171	FBRegisterUDRProcedure('read_txt',TReadTextFile);
172
173	end.
174