udr/testbed/FBUdrPlugin.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 FBUdrPlugin;

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

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

interface

uses
  Classes, SysUtils, Firebird, IB, FBUDRIntf, FBUDRController, FB30Statement;

type
  TFBUdrPluginEmulator = class;

  { TEmulatedExternalContext }

  TEmulatedExternalContext = class(Firebird.IExternalContextImpl)
  private
    FAttachmentIntf: Firebird.IAttachment;
    FStatement: IStatement;
    FTransaction: ITransaction;
    FUserNameBuffer: Ansistring;
    FClientCharSet: AnsiString;
    FDatabaseName: AnsiString;
  public
    constructor Create(aStatement: IStatement);
    destructor Destroy; override;
    property Transaction: ITransaction read FTransaction write FTransaction;
  public
    {IExternalContext}
    function getMaster(): Firebird.IMaster; override;
    function getEngine(status: Firebird.IStatus): Firebird.IExternalEngine; override;
    function getAttachment(status: Firebird.IStatus): Firebird.IAttachment; override;
    function getTransaction(status: Firebird.IStatus): Firebird.ITransaction; override;
    function getUserName(): PAnsiChar; override;
    function getDatabaseName(): PAnsiChar; override;
    function getClientCharSet(): PAnsiChar; override;
    function obtainInfoCode(): Integer; override;
    function getInfo(code: Integer): Pointer; override;
    function setInfo(code: Integer; value: Pointer): Pointer; override;
  end;

  { TEmulatedRoutineMetadata }

  TEmulatedRoutineMetadata = class(IRoutineMetadataImpl)
  private
    FManager: TFBUdrPluginEmulator;
    FName: AnsiString;
    FPackageName: AnsiString;
    FStatement: IStatement;
    FEntryPoint: AnsiString;
    FTableName: AnsiString;
    FTriggerType: cardinal;
    FInputMetadata: firebird.IMessageMetadata;
    FOutputMetadata: firebird.IMessageMetadata;
    FTriggerMetadata: firebird.IMessageMetadata;
  public
    constructor Create(aManager: TFBUdrPluginEmulator; aName, aPackageName, aEntryPoint: AnsiString; aStatement: IStatement);
    destructor Destroy; override;
    procedure SetTriggerInfo(aTableName: AnsiString; aTriggerType: cardinal);
  public
    {IRoutineMetadata}
    function getPackage(status: Firebird.IStatus): PAnsiChar; override;
    function getName(status: Firebird.IStatus): PAnsiChar; override;
    function getEntryPoint(status: Firebird.IStatus): PAnsiChar; override;
    function getBody(status: Firebird.IStatus): PAnsiChar; override;
    function getInputMetadata(status: Firebird.IStatus): IMessageMetadata; override;
    function getOutputMetadata(status: Firebird.IStatus): IMessageMetadata; override;
    function getTriggerMetadata(status: Firebird.IStatus): IMessageMetadata; override;
    function getTriggerTable(status: Firebird.IStatus): PAnsiChar; override;
    function getTriggerType(status: Firebird.IStatus): Cardinal; override;
  end;

  { TExternalWrapper }

  TExternalWrapper = class
  protected
    FManager: TFBUdrPluginEmulator;
    FName: AnsiString;
    FPreparedStatement: IStatement;
    FContext: TEmulatedExternalContext;
    FRoutineMetadata: TEmulatedRoutineMetadata;
    FStatus: Firebird.IStatus;
    FInputParams: ISQLParams;
    procedure CheckStatus;
    procedure ChangeResultsCharset(FromID, toID: integer);
    procedure Setup;
    procedure DoSetup(status: Firebird.IStatus;
                      context: Firebird.IExternalContext;
                      metadata: Firebird.IRoutineMetadata;
                      inBuilder: Firebird.IMetadataBuilder;
                      outBuilder: Firebird.IMetadataBuilder); virtual; abstract;
  public
    constructor Create(aManager: TFBUdrPluginEmulator; aName, aPackageName, aEntryPoint: AnsiString;
                                 preparedStmt: IStatement);
    destructor Destroy; override;
  end;

  { TExternalFunctionWrapper }

  TExternalFunctionWrapper = class(TExternalWrapper)
  private
    FFunctionFactory: TFBUDRFunctionFactory;
  protected
    procedure DoSetup(status: Firebird.IStatus;
                      context: Firebird.IExternalContext;
                      metadata: Firebird.IRoutineMetadata;
                      inBuilder: Firebird.IMetadataBuilder;
                      outBuilder: Firebird.IMetadataBuilder); override;
  public
    constructor Create(aManager: TFBUdrPluginEmulator;aName, aPackageName, aEntryPoint: AnsiString;
       aFunctionFactory: TFBUDRFunctionFactory;
       preparedStmt: IStatement);
    function Execute(aTransaction: ITransaction): ISQLData;
    property InputParams: ISQLParams read FInputParams;
  end;

  {IProcedureResults is a cut down version of IResultsSet}

  IProcedureResults = interface
    ['{1b851373-a7c2-493e-b457-6a19980e0f5f}']
    function getCount: integer;
    function ByName(Idx: AnsiString): ISQLData;
    function getSQLData(index: integer): ISQLData;
    function FetchNext: boolean; {fetch next record}
    function IsEof: boolean;
    property Data[index: integer]: ISQLData read getSQLData; default;
    property Count: integer read getCount;
  end;

  { TExternalProcedureWrapper }

  TExternalProcedureWrapper = class(TExternalWrapper)
  private
    FProcedureFactory: TFBUDRProcedureFactory;
  protected
    procedure DoSetup(status: Firebird.IStatus;
                      context: Firebird.IExternalContext;
                      metadata: Firebird.IRoutineMetadata;
                      inBuilder: Firebird.IMetadataBuilder;
                      outBuilder: Firebird.IMetadataBuilder); override;
  public
    constructor Create(aManager: TFBUdrPluginEmulator; aName, aPackageName, aEntryPoint: AnsiString;
       aProcedureFactory: TFBUDRProcedureFactory;
       preparedStmt: IStatement);
    function Execute(aTransaction: ITransaction): IProcedureResults;
    property InputParams: ISQLParams read FInputParams;
  end;

  { TFBTriggerSQLDA }

  TFBTriggerSQLDA = class(TIBXINPUTSQLDA)
  private
    FAttachment: IAttachment;
  protected
    function GetAttachment: IAttachment; override;
    function CanChangeMetaData: boolean; override;
  public
    {created with the input messge metadata and a pointer to the inMsg buffer}
    constructor Create(att: IAttachment; aMetadata: Firebird.IMessageMetaData);
    procedure Finalise;
  end;

  { TExternalTriggerWrapper }

  TExternalTriggerWrapper = class(TExternalWrapper)
  private
    FTriggerFactory: TFBUDRTriggerFactory;
    FTriggerOldSQLDA: TFBTriggerSQLDA;
    FTriggerNewSQLDA: TFBTriggerSQLDA;
    FOldValues: IFBUDROutputData;
    FNewValues: IFBUDROutputData;
  protected
    procedure DoSetup(status: Firebird.IStatus;
                      context: Firebird.IExternalContext;
                      metadata: Firebird.IRoutineMetadata;
                      inBuilder: Firebird.IMetadataBuilder;
                      outBuilder: Firebird.IMetadataBuilder); override;
  public
    constructor Create(aManager: TFBUdrPluginEmulator; aName,  aTableName, aEntryPoint: AnsiString;
       aTriggerType: cardinal;
       aTriggerFactory: TFBUDRTriggerFactory;
       preparedStmt: IStatement);
    destructor Destroy; override;
    procedure Execute(aTransaction: ITransaction; action: cardinal);
    property OldValues: IFBUDROutputData read FOldValues;
    property NewValues: IFBUDROutputData read FNewValues;
  end;

  { TFBUdrPluginEmulator }

  TFBUdrPluginEmulator = class(Firebird.IUdrPluginImpl)
  private
    FModuleName: AnsiString;
    FTheirUnloadFlag: booleanPtr;
    FMyUnloadFlag: boolean;
    FStatus: Firebird.IStatus;
    FAttachment: IAttachment;
    FFunctionFactories: TStringList;
    FProcedureFactories: TStringList;
    FTriggerFactories: TStringList;
    procedure CheckStatus;
    procedure FreeList(var list: TStringList);
    function CreateSelectFunctionSQL(aFunctionName: AnsiString): AnsiString;
    function CreateExecProcedureSQL(aProcName: AnsiString): AnsiString;
    procedure SetAttachment(AValue: IAttachment);
  public
    {IUdrPluginImpl}
    function getMaster(): IMaster; override;
    procedure registerFunction(status: Firebird.IStatus; name: PAnsiChar; factory: Firebird.IUdrFunctionFactory); override;
    procedure registerProcedure(status: Firebird.IStatus; name: PAnsiChar; factory: Firebird.IUdrProcedureFactory); override;
    procedure registerTrigger(status: Firebird.IStatus; name: PAnsiChar; factory: Firebird.IUdrTriggerFactory); override;
  public
    constructor Create(aModuleName: AnsiString);
    destructor Destroy; override;
    function makeFunction(aFunctionName, aPackageName,
      aEntryPoint: AnsiString): TExternalFunctionWrapper;
    function makeProcedure(aProcName, aPackageName, aEntryPoint: AnsiString): TExternalProcedureWrapper;
    function makeTrigger(aName, aEntryPoint, datasetName: AnsiString; aTriggerType: cardinal
      ): TExternalTriggerWrapper;
    property Attachment: IAttachment read FAttachment write SetAttachment;
    property ModuleName: AnsiString read FModuleName;
  end;

implementation

uses FBClientLib, IBUtils, FB30Attachment, FB30Transaction,
     FBSQLData, FBUDRUtils;

resourcestring
  SNoMasterInterface = 'A Master Interface is required - legacy API not supported';
  SNoAttachment = 'An attachment must be provided before a statement can be prepared';

type
  { TProcedureResults }

  TProcedureResults = class(TInterfacedObject,IProcedureResults)
  private
    FExternalResultSet: Firebird.IExternalResultSet;
    FResults: IResults;
    FIsEof: boolean;
    FManager: TFBUdrPluginEmulator;
  public
    constructor Create(aManager: TFBUdrPluginEmulator;
      aExternalResultSet: Firebird.IExternalResultSet;
  aSQLRecord: TIBXOUTPUTSQLDA);
    destructor Destroy; override;
  public
    {IProcedureResults}
    function getCount: integer;
    function ByName(Idx: AnsiString): ISQLData;
    function getSQLData(index: integer): ISQLData;
    function FetchNext: boolean; {fetch next record}
    function IsEof: boolean;
  end;

{ TFBTriggerSQLDA }

function TFBTriggerSQLDA.GetAttachment: IAttachment;
begin
  Result := FAttachment;
end;

function TFBTriggerSQLDA.CanChangeMetaData: boolean;
begin
  Result := false;
end;

constructor TFBTriggerSQLDA.Create(att: IAttachment;
  aMetadata: Firebird.IMessageMetaData);
begin
  inherited Create(FirebirdAPI);
  FAttachment := att;
  Bind(aMetaData);
end;

procedure TFBTriggerSQLDA.Finalise;
begin
  PackBuffer;
end;

{ TExternalTriggerWrapper }

procedure TExternalTriggerWrapper.DoSetup(status: Firebird.IStatus;
  context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
  inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
begin
  FTriggerFactory.setup(status,context,metadata,outBuilder);
end;

constructor TExternalTriggerWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
  aTableName, aEntryPoint: AnsiString; aTriggerType: cardinal;
  aTriggerFactory: TFBUDRTriggerFactory; preparedStmt: IStatement);
begin
  inherited Create(aManager,aName,'',aEntryPoint, preparedStmt);
  FTriggerFactory := aTriggerFactory;
  FRoutineMetadata.SetTriggerInfo(aTableName,aTriggerType);
  FTriggerOldSQLDA := TFBTriggerSQLDA.Create(FManager.Attachment,(preparedStmt as TFB30Statement).SQLRecord.GetMetaData);
  FTriggerNewSQLDA := TFBTriggerSQLDA.Create(FManager.Attachment,(preparedStmt as TFB30Statement).SQLRecord.GetMetaData);
  FOldValues := TFBUDROutputParams.Create(FTriggerOldSQLDA);
  FOldValues.Clear;
  FNewValues := TFBUDROutputParams.Create(FTriggerNewSQLDA);
  FNewValues.Clear;
end;

destructor TExternalTriggerWrapper.Destroy;
begin
  FOldValues := nil;
  FNewValues := nil;
  if FTriggerOldSQLDA <> nil then
    FTriggerOldSQLDA.Free;
  if FTriggerNewSQLDA <> nil then
    FTriggerNewSQLDA.Free;
  inherited Destroy;
end;

procedure TExternalTriggerWrapper.Execute(aTransaction: ITransaction;
  action: cardinal);
var aTriggerInstance: Firebird.IExternalTrigger;
    Buffer: array [0..512] of AnsiChar;
begin
  (FContext as TEmulatedExternalContext).Transaction := aTransaction;
  try
    Setup;
    aTriggerInstance := FTriggerFactory.newItem(FStatus,FContext,FRoutineMetadata);
    try
    Buffer[0] := #0;
    aTriggerInstance.getCharSet(FStatus,FContext,@Buffer,sizeof(Buffer)); {The UDR engine does this thus so do we}
    CheckStatus;
    FTriggerOldSQLDA.Finalise;
    FTriggerNewSQLDA.Finalise;
    aTriggerInstance.execute(FStatus,FContext,action,
                             FTriggerOldSQLDA.MessageBuffer,
                             FTriggerNewSQLDA.MessageBuffer
                             );
    finally
      aTriggerInstance.dispose;
    end;
  finally
    (FContext as TEmulatedExternalContext).Transaction := nil;
  end;
end;

{ TExternalProcedureWrapper }

procedure TExternalProcedureWrapper.DoSetup(status: Firebird.IStatus;
  context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
  inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
begin
  FProcedureFactory.setup(status,context,metadata,inBuilder,outBuilder);
end;

constructor TExternalProcedureWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
  aPackageName, aEntryPoint: AnsiString;
  aProcedureFactory: TFBUDRProcedureFactory; preparedStmt: IStatement);
begin
  inherited Create(aManager,aName, aPackageName, aEntryPoint, preparedStmt);
  FProcedureFactory := aProcedureFactory;
end;

function TExternalProcedureWrapper.Execute(aTransaction: ITransaction
  ): IProcedureResults;
var aProcedureInstance: Firebird.IExternalProcedure;
    Buffer: array [0..512] of AnsiChar;
    ResultsSet: IExternalResultSet;
    OutputData: IResults;
begin
  Result := nil;
  (FContext as TEmulatedExternalContext).Transaction := aTransaction;
  try
    Setup;
    aProcedureInstance := FProcedureFactory.newItem(FStatus,FContext,FRoutineMetadata);
    try
      Buffer[0] := #0;
      aProcedureInstance.getCharSet(FStatus,FContext,@Buffer,sizeof(Buffer));
      CheckStatus;
      ResultsSet := aProcedureInstance.open(FStatus,FContext,
                        (FPreparedStatement as TFB30Statement).SQLParams.MessageBuffer,
                        (FPreparedStatement as TFB30Statement).SQLRecord.MessageBuffer);
      CheckStatus;
      if ResultsSet <> nil then
        Result := TProcedureResults.Create(FManager,ResultsSet,(FPreparedStatement as TFB30Statement).SQLRecord);
    finally
      aProcedureInstance.dispose;
    end;
  finally
    (FContext as TEmulatedExternalContext).Transaction := nil;
  end;
end;

{ TProcedureResults }

constructor TProcedureResults.Create(aManager: TFBUdrPluginEmulator;
  aExternalResultSet: Firebird.IExternalResultSet; aSQLRecord: TIBXOUTPUTSQLDA);
begin
  inherited Create;
  FManager := aManager;
  FExternalResultSet := aExternalResultSet;
  FResults := TResults.Create(aSQLRecord);
end;

destructor TProcedureResults.Destroy;
begin
  if FExternalResultSet <> nil then
    FExternalResultSet.dispose;
  inherited Destroy;
end;

function TProcedureResults.getCount: integer;
begin
  Result := FResults.Count;
end;

function TProcedureResults.ByName(Idx: AnsiString): ISQLData;
begin
  Result := FResults.ByName(Idx);
end;

function TProcedureResults.getSQLData(index: integer): ISQLData;
begin
  Result := FResults.getSQLData(index);
end;

function TProcedureResults.FetchNext: boolean;
begin
  Result := FExternalResultSet.fetch(FManager.FStatus);
  FManager.CheckStatus;
  FIsEof := not Result;
end;

function TProcedureResults.IsEof: boolean;
begin
  Result := FIsEOF;
end;

{ TExternalWrapper }

procedure TExternalWrapper.CheckStatus;
var buffer: array [0..4096] of AnsiChar;
begin
  with FStatus do
    if (getState and STATE_ERRORS) <> 0 then
    begin
      FManager.getMaster.getUtilInterface.formatStatus(@buffer,sizeof(buffer),FStatus);
      raise Exception.Create(strpas(PAnsiChar(@buffer)));
    end;
end;

procedure TExternalWrapper.ChangeResultsCharset(FromID, toID: integer);
var i: integer;
begin
  with (FPreparedStatement as TFB30Statement) do
   for i := 0 to SQLRecord.Count - 1 do
     if SQLRecord.Column[i].CharSetID = FromID then
        SQLRecord.Column[i].CharSetID := ToID;
end;

procedure TExternalWrapper.Setup;
var inBuilder: Firebird.IMetadataBuilder;
    outBuilder: Firebird.IMetadataBuilder;
    inMetadata: Firebird.IMessageMetadata;
    outMetadata: Firebird.IMessageMetadata;
begin
  inMetadata := FRoutineMetadata.getInputMetadata(FStatus);
  CheckStatus;
  if inMetadata <> nil then
  try
    inBuilder := inMetadata.getBuilder(FStatus);
    CheckStatus;
  finally
    inMetadata.release;
  end
  else
    inBuilder := nil;

  outMetadata := FRoutineMetadata.getOutputMetadata(FStatus);
  CheckStatus;
  if outMetadata <> nil then
  try
    outBuilder := outMetadata.getBuilder(FStatus);
    CheckStatus;
  finally
    outMetadata.release;
  end
  else
    outBuilder := nil;
  DoSetup(FStatus,FContext,FRoutineMetadata,inBuilder,outBuilder);
  CheckStatus;
end;

constructor TExternalWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
  aPackageName, aEntryPoint: AnsiString; preparedStmt: IStatement);
begin
  inherited Create;
  FManager := aManager;
  FName := aName;
  FPreparedStatement := preparedStmt;
  FContext := TEmulatedExternalContext.Create(FPreparedStatement);
  FRoutineMetadata := TEmulatedRoutineMetadata.Create(aManager,aName,aPackageName,aEntryPoint,FPreparedStatement);
  FStatus := FContext.getMaster.getStatus;
  FInputParams := FPreparedStatement.SQLParams;
end;

destructor TExternalWrapper.Destroy;
begin
  if FContext <> nil then
    FContext.Free;
  if FRoutineMetadata <> nil then
    FRoutineMetadata.Free;
  if FStatus <> nil then
    FStatus.dispose;
  inherited Destroy;
end;

{ TEmulatedRoutineMetadata }

constructor TEmulatedRoutineMetadata.Create(aManager: TFBUdrPluginEmulator; aName,
  aPackageName, aEntryPoint: AnsiString; aStatement: IStatement);
begin
  inherited Create;
  FManager := aManager;
  FName := aName;
  FPackageName := aPackageName;
  FEntryPoint := aEntryPoint;
  FStatement := aStatement;
end;

destructor TEmulatedRoutineMetadata.Destroy;
begin
  if FInputMetadata <> nil then
    FInputMetadata.release;
  if FOutputMetadata <> nil then
    FOutputMetadata.release;
  if FTriggerMetadata <> nil then
    FTriggerMetadata.release;
  inherited Destroy;
end;

procedure TEmulatedRoutineMetadata.SetTriggerInfo(aTableName: AnsiString;
  aTriggerType: cardinal);
begin
  FTableName := aTableName;
  FTriggerType := aTriggerType;
end;

function TEmulatedRoutineMetadata.getPackage(status: Firebird.IStatus
  ): PAnsiChar;
begin
  Result := PAnsiChar(FPackageName);
end;

function TEmulatedRoutineMetadata.getName(status: Firebird.IStatus): PAnsiChar;
begin
  Result := PAnsiChar(FName);
end;

function TEmulatedRoutineMetadata.getEntryPoint(status: Firebird.IStatus
  ): PAnsiChar;
begin
  Result := PAnsiChar(FEntryPoint);
end;

function TEmulatedRoutineMetadata.getBody(status: Firebird.IStatus): PAnsiChar;
begin
  Result := nil;
end;

function TEmulatedRoutineMetadata.getInputMetadata(status: Firebird.IStatus
  ): IMessageMetadata;
begin
  if (FTriggerType = 0) and (FInputMetadata = nil) then
    FInputMetadata := (FStatement as TFB30Statement).SQLParams.GetMetaData ;
  Result := FInputMetadata;
  if Result <> nil then
    Result.addRef();
end;

function TEmulatedRoutineMetadata.getOutputMetadata(status: Firebird.IStatus
  ): IMessageMetadata;
begin
  if (FTriggerType = 0) and (FOutputMetadata = nil) then
    FOutputMetadata := (FStatement as TFB30Statement).SQLRecord.GetMetaData;
  Result := FOutputMetadata;
  if Result <> nil then
    Result.addRef();
end;

function TEmulatedRoutineMetadata.getTriggerMetadata(status: Firebird.IStatus
  ): IMessageMetadata;
begin
  if (FTriggerType <> 0) and (FTriggerMetadata = nil) then
    FTriggerMetadata := (FStatement as TFB30Statement).SQLRecord.GetMetaData;
  Result := FTriggerMetadata;
  if Result <> nil then
    Result.addRef();
end;

function TEmulatedRoutineMetadata.getTriggerTable(status: Firebird.IStatus
  ): PAnsiChar;
begin
  Result := PAnsiChar(FTableName);
end;

function TEmulatedRoutineMetadata.getTriggerType(status: Firebird.IStatus
  ): Cardinal;
begin
  Result := FTriggerType;
end;

{ TExternalFunctionWrapper }

constructor TExternalFunctionWrapper.Create(aManager: TFBUdrPluginEmulator; aName,
  aPackageName, aEntryPoint: AnsiString;
  aFunctionFactory: TFBUDRFunctionFactory; preparedStmt: IStatement);
begin
  inherited Create(aManager,aName, aPackageName, aEntryPoint, preparedStmt);
  FFunctionFactory := aFunctionFactory;
end;

function TExternalFunctionWrapper.Execute(aTransaction: ITransaction): ISQLData;
var aFunctionInstance: Firebird.IExternalFunction;
    Buffer: array [0..512] of AnsiChar;
    CodePage: TSystemCodePage;
    OutputData: IResults;
begin
  (FContext as TEmulatedExternalContext).Transaction := aTransaction;
  try
    Setup;
    aFunctionInstance := FFunctionFactory.newItem(FStatus,FContext,FRoutineMetadata);
    try
      Buffer[0] := #0;
      aFunctionInstance.getCharSet(FStatus,FContext,@Buffer,sizeof(Buffer));
      CheckStatus;
      aFunctionInstance.execute(FStatus,FContext,
                        (FPreparedStatement as TFB30Statement).SQLParams.MessageBuffer,
                        (FPreparedStatement as TFB30Statement).SQLRecord.MessageBuffer);
      CheckStatus;
      OutputData := TResults.Create( (FPreparedStatement as TFB30Statement).SQLRecord);
      Result := OutputData[0];
    finally
      aFunctionInstance.dispose;
    end;
  finally
    (FContext as TEmulatedExternalContext).Transaction := nil;
  end;
end;

procedure TExternalFunctionWrapper.DoSetup(status: Firebird.IStatus;
  context: Firebird.IExternalContext; metadata: Firebird.IRoutineMetadata;
  inBuilder: Firebird.IMetadataBuilder; outBuilder: Firebird.IMetadataBuilder);
begin
  FFunctionFactory.setup(status,context,metadata,inBuilder,outBuilder);
end;

{ TEmulatedExternalContext }

constructor TEmulatedExternalContext.Create(aStatement: IStatement);
begin
  inherited Create;
  FStatement := aStatement;
  FAttachmentIntf := (FStatement.GetAttachment as TFB30Attachment).AttachmentIntf;
  FAttachmentIntf.addRef;
end;

destructor TEmulatedExternalContext.Destroy;
begin
  if FAttachmentIntf <> nil then
    FAttachmentIntf.release;
  inherited Destroy;
end;

function TEmulatedExternalContext.getMaster(): Firebird.IMaster;
var MasterProvider: IFBIMasterProvider;
begin
  if FirebirdAPI.HasMasterIntf and (FirebirdAPI.QueryInterface(IFBIMasterProvider,MasterProvider) = S_OK) then
    Result := MasterProvider.GetIMasterIntf
  else
    Result := nil;
end;

function TEmulatedExternalContext.getEngine(status: Firebird.IStatus
  ): Firebird.IExternalEngine;
begin
  Result := nil;
end;

function TEmulatedExternalContext.getAttachment(status: Firebird.IStatus
  ): Firebird.IAttachment;
begin
  Result := FAttachmentIntf;
end;

function TEmulatedExternalContext.getTransaction(status: Firebird.IStatus
  ): Firebird.ITransaction;
begin
  Result := (FTransaction as TFB30Transaction).TransactionIntf;
end;

function TEmulatedExternalContext.getUserName(): PAnsiChar;
var DPB: IDPB;
    DPBItem: IDPBItem;
begin
  Result := '';
  DPB := FStatement.GetAttachment.getDPB;
  DPBItem := DPB.Find(isc_dpb_user_name);
  if DPBItem <> nil then
  begin
    FUserNameBuffer := DPBItem.AsString;
    Result := PAnsiChar(FUserNameBuffer);
  end;
end;

function TEmulatedExternalContext.getDatabaseName(): PAnsiChar;
var ServerName: AnsiString;
    Protocol: TProtocolAll;
    PortNo: AnsiString;
begin
  Result := '';
  if ParseConnectString(FStatement.getAttachment.GetConnectString,
      ServerName,FDatabaseName,Protocol,PortNo) then
        Result := PAnsiChar(FDatabaseName);
end;

function TEmulatedExternalContext.getClientCharSet(): PAnsiChar;
var DPB: IDPB;
    DPBItem: IDPBItem;
begin
  Result := '';
  DPB := FStatement.GetAttachment.getDPB;
  DPBItem := DPB.Find(isc_dpb_lc_ctype);
  if DPBItem <> nil then
  begin
    FClientCharSet := DPBItem.AsString;
    Result := PAnsiChar(FClientCharSet);
  end;
end;

function TEmulatedExternalContext.obtainInfoCode(): Integer;
begin
  Result := 0;
end;

function TEmulatedExternalContext.getInfo(code: Integer): Pointer;
begin
  Result := nil;
end;

function TEmulatedExternalContext.setInfo(code: Integer; value: Pointer
  ): Pointer;
begin
  Result := nil;
end;

{ TFBUdrPluginEmulator }

function TFBUdrPluginEmulator.getMaster(): IMaster;
var MasterProvider: IFBIMasterProvider;
begin
  if FirebirdAPI.HasMasterIntf and (FirebirdAPI.QueryInterface(IFBIMasterProvider,MasterProvider) = S_OK) then
    Result := MasterProvider.GetIMasterIntf
  else
    Result := nil;
end;

procedure TFBUdrPluginEmulator.registerFunction(status: Firebird.IStatus;
  name: PAnsiChar; factory: Firebird.IUdrFunctionFactory);
begin
  FFunctionFactories.AddObject(strpas(name),factory);
end;

procedure TFBUdrPluginEmulator.registerProcedure(status: Firebird.IStatus;
  name: PAnsiChar; factory: Firebird.IUdrProcedureFactory);
begin
  FProcedureFactories.AddObject(strpas(name),factory);
end;

procedure TFBUdrPluginEmulator.registerTrigger(status: Firebird.IStatus;
  name: PAnsiChar; factory: Firebird.IUdrTriggerFactory);
begin
  FTriggerFactories.AddObject(strpas(name),factory);
end;

constructor TFBUdrPluginEmulator.Create(aModuleName: AnsiString);
begin
  inherited Create;
  FModuleName := aModuleName;
  FStatus := GetMaster.getStatus;
  FFunctionFactories := TStringList.Create;
  FProcedureFactories := TStringList.Create;
  FTriggerFactories := TStringList.Create;
  FTheirUnloadFlag := firebird_udr_plugin(FStatus,@FMyUnloadFlag,self);
  CheckStatus;
end;

destructor TFBUdrPluginEmulator.Destroy;
begin
  FreeList(FFunctionFactories);
  FreeList(FProcedureFactories);
  FreeList(FTriggerFactories);
  if FStatus <> nil then
    FStatus.dispose();
  inherited Destroy;
end;

procedure TFBUdrPluginEmulator.CheckStatus;
var buffer: array [0..4096] of AnsiChar;
begin
  with FStatus do
    if (getState and STATE_ERRORS) <> 0 then
    begin
      getMaster.getUtilInterface.formatStatus(@buffer,sizeof(buffer),FStatus);
      raise Exception.Create(strpas(PAnsiChar(@buffer)));
    end;
end;

procedure TFBUdrPluginEmulator.FreeList(var list: TStringList);
var i: integer;
    obj: TObject;
begin
  if List = nil then Exit;

  for i := 0 to List.Count - 1 do
  begin
    obj := List.Objects[i];
    if obj <> nil then
    begin
      if obj is TFBUDRFunctionFactory then
       TFBUDRFunctionFactory(obj).dispose
      else
      if obj is TFBUDRProcedureFactory then
        TFBUDRProcedureFactory(obj).dispose
      else
      if obj is TFBUDRTriggerFactory then
        TFBUDRTriggerFactory(obj).dispose;
    end;
  end;
  FreeAndNil(List);
end;

function TFBUdrPluginEmulator.CreateSelectFunctionSQL(aFunctionName: AnsiString
  ): AnsiString;
const
  FunctionArgsSQL =
    'SELECT * FROM RDB$FUNCTION_ARGUMENTS RFA JOIN RDB$FIELDS FLD ' +
    'ON RFA.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME '+
    'WHERE RDB$FUNCTION_NAME = ? ' +
    'ORDER BY RDB$ARGUMENT_POSITION';
var args: IResultset;
    arglist: AnsiString;
    separator: AnsiString;
begin
  if not FAttachment.HasFunction(aFunctionName) then
    aFunctionName := SafeAnsiUpperCase(aFunctionName);
  args := FAttachment.OpenCursorAtStart(FunctionArgsSQL,[aFunctionName]);
  arglist := '';
  separator := ':';
  while not args.IsEof do
  begin
    if args.ByName('RDB$ARGUMENT_POSITION').AsInteger > 0 then
    begin
      arglist := arglist + separator + Trim(args.ByName('RDB$ARGUMENT_NAME').AsString);
      separator := ', :';
    end;
    args.FetchNext;
  end;
  Result := 'Select ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aFunctionName) + '(' + arglist + ') From RDB$DATABASE';
end;

function TFBUdrPluginEmulator.CreateExecProcedureSQL(aProcName: AnsiString): AnsiString;
const
  sGetProcArgsSQL =
    'SELECT * ' +
    ' FROM RDB$PROCEDURE_PARAMETERS PRM JOIN RDB$FIELDS FLD ON ' +
    ' PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +
    'WHERE ' +
    '    PRM.RDB$PROCEDURE_NAME = ? AND ' +
    '    PRM.RDB$PARAMETER_TYPE = 0 ' +
    'ORDER BY PRM.RDB$PARAMETER_NUMBER';

  sGetProcType = 'Select RDB$PROCEDURE_TYPE FROM RDB$PROCEDURES ' +
                 'Where Trim(RDB$PROCEDURE_NAME) = ?';

var args: IResultset;
    arglist: AnsiString;
    separator: AnsiString;
    ProcType: integer;
begin
  if not FAttachment.HasProcedure(aProcName) then
    aProcName := SafeAnsiUpperCase(aProcName);
  args := FAttachment.OpenCursorAtStart(sGetProcArgsSQL,[aProcName]);
  arglist := '';
  separator := ':';
  while not args.IsEof do
  begin
    arglist := arglist + separator + Trim(args.ByName('RDB$PARAMETER_NAME').AsString);
    separator := ', :';
    args.FetchNext;
  end;
  ProcType := FAttachment.OpenCursorAtStart(sGetProcType,[aProcName])[0].AsInteger;
  case ProcType of
  1:
    if arglist <> '' then
      Result := 'Select * From ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName) + '(' + arglist + ')'
    else
      Result := 'Select * From ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName);
  2:
    if arglist <> '' then
      Result := 'Execute Procedure ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName) + '(' + arglist + ')'
    else
      Result := 'Execute Procedure ' + QuoteIdentifierIfNeeded(FAttachment.GetSQLDialect,aProcName);
  else
    raise Exception.CreateFmt('Unknown Procedure Type %d for %s',[ProcType,aProcName]);

  end;
end;

procedure TFBUdrPluginEmulator.SetAttachment(AValue: IAttachment);
begin
  if FAttachment = AValue then Exit;
  if (AValue = nil) or (AValue.getFirebirdAPI = nil) or not AValue.getFirebirdAPI.HasMasterIntf then
    raise Exception.Create(SNoMasterInterface);
  FAttachment := AValue;
end;

function TFBUdrPluginEmulator.makeFunction(aFunctionName, aPackageName,
  aEntryPoint: AnsiString): TExternalFunctionWrapper;
var index: integer;
    aTransaction: ITransaction;
    aModuleName,aRoutineName,aInfo: AnsiString;
begin
  Result := nil;
  if FAttachment = nil then
    raise Exception.Create(SNoAttachment);
  TFBUDRRoutineMetadata.ParseEntryPoint(aEntryPoint,aModuleName,aRoutineName,aInfo);
  index := FFunctionFactories.IndexOf(aRoutineName);
  if (index <> -1) and (FFunctionFactories.Objects[index] <> nil) then
  begin
    aTransaction := FAttachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taRollback);
    Result := TExternalFunctionWrapper.Create(self,aFunctionName, aPackageName, aEntryPoint,
                   FFunctionFactories.Objects[index] as TFBUDRFunctionFactory,
                   FAttachment.PrepareWithNamedParameters(aTransaction,
                   CreateSelectFunctionSQL(aFunctionName),
                   true));
  end;
end;

function TFBUdrPluginEmulator.makeProcedure(aProcName, aPackageName,
  aEntryPoint: AnsiString): TExternalProcedureWrapper;
var index: integer;
    aTransaction: ITransaction;
    aModuleName,aRoutineName,aInfo: AnsiString;
begin
  Result := nil;
  if FAttachment = nil then
    raise Exception.Create(SNoAttachment);
  TFBUDRRoutineMetadata.ParseEntryPoint(aEntryPoint,aModuleName,aRoutineName,aInfo);
  index := FProcedureFactories.IndexOf(aRoutineName);
  if (index <> -1) and (FProcedureFactories.Objects[index] <> nil) then
  begin
    aTransaction := FAttachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taRollback);
    Result := TExternalProcedureWrapper.Create(self,aProcName, aPackageName, aEntryPoint,
                   FProcedureFactories.Objects[index] as TFBUDRProcedureFactory,
                   FAttachment.PrepareWithNamedParameters(aTransaction,
                   CreateExecProcedureSQL(aProcName),true));
  end;
end;

function TFBUdrPluginEmulator.makeTrigger(aName, aEntryPoint,
  datasetName: AnsiString; aTriggerType: cardinal): TExternalTriggerWrapper;
var index: integer;
    aTransaction: ITransaction;
    sql: AnsiString;
    aModuleName,aRoutineName,aInfo: AnsiString;
begin
  Result := nil;
  sql := 'Select * from ' + datasetName;
  if FAttachment = nil then
    raise Exception.Create(SNoAttachment);
  TFBUDRRoutineMetadata.ParseEntryPoint(aEntryPoint,aModuleName,aRoutineName,aInfo);
  index := FTriggerFactories.IndexOf(aRoutineName);
  if (index <> -1) and (FTriggerFactories.Objects[index] <> nil) then
  begin
    aTransaction := FAttachment.StartTransaction([isc_tpb_read,isc_tpb_nowait,isc_tpb_concurrency],taRollback);
    Result := TExternalTriggerWrapper.Create(self,aName, datasetName, aEntryPoint, aTriggerType,
                   FTriggerFactories.Objects[index] as TFBUDRTriggerFactory,
                   FAttachment.PrepareWithNamedParameters(aTransaction,sql,true));
  end;
end;

end.

Revision:	421
Committed:	Sat Oct 21 14:22:28 2023 UTC (13 months, 4 weeks ago) by tony
Content type:	text/x-pascal
File size:	33676 byte(s)
Log Message:	Release 2.6.3 Merged