Написание UDR Firebird на Pascal

cloop FirebirdInterface.idl pascal Firebird.pas Firebird --uses SysUtils \
  --interfaceFile Pascal.interface.pas \
  --implementationFile Pascal.implementation.pas \
  --exceptionClass FbException --prefix I \
  --functionsFile fb_get_master_interface.pas

{CREATE [OR ALTER] | RECREATE} FUNCTION funcname [(<inparam> [, <inparam> ...])]
RETURNS <type> [COLLATE collation] [DETERMINISTIC]
EXTERNAL NAME <extname> ENGINE <engine>
[AS <extbody>]


<inparam> ::= <param_decl> [{= | DEFAULT} <value>]

<value> ::=  {literal | NULL | context_var}

<param_decl> ::= paramname <type> [NOT NULL] [COLLATE collation]

<extname> ::= '<module name>!<routine name>[!<misc info>]'

<type> ::= <datatype> | [TYPE OF] domain | TYPE OF COLUMN rel.col

<datatype> ::=
    {SMALLINT | INT[EGER] | BIGINT}
  | BOOLEAN
  | {FLOAT | DOUBLE PRECISION}
  | {DATE | TIME | TIMESTAMP}
  | {DECIMAL | NUMERIC} [(precision [, scale])]
  | {CHAR | CHARACTER | CHARACTER VARYING | VARCHAR} [(size)]
    [CHARACTER SET charset]
  | {NCHAR | NATIONAL CHARACTER | NATIONAL CHAR} [VARYING] [(size)]
  | BLOB [SUB_TYPE {subtype_num | subtype_name}]
    [SEGMENT SIZE seglen] [CHARACTER SET charset]
  | BLOB [(seglen [, subtype_num])]

ALTER FUNCTION funcname [(<inparam> [, <inparam> ...])]
RETURNS <type> [COLLATE collation] [DETERMINISTIC]
EXTERNAL NAME <extname> ENGINE <engine>
[AS <extbody>]

<extname> ::= '<module name>!<routine name>[!<misc info>]'

DROP FUNCTION funcname

create function sum_args (
    n1 integer,
    n2 integer,
    n3 integer
)
returns integer
external name 'udrcpp_example!sum_args'
engine udr;

create or alter function regex_replace (
  regex varchar(60),
  str varchar(60),
  replacement varchar(60)
)
returns varchar(60)
external name 'org.firebirdsql.fbjava.examples.fbjava_example.FbRegex.replace(
      String, String, String)'
engine java;

{CREATE [OR ALTER] | RECREATE} PROCEDURE procname [(<inparam> [, <inparam> ...])]
RETURNS (<outparam> [, <outparam> ...])
EXTERNAL NAME <extname> ENGINE <engine>
[AS <extbody>]

<inparam> ::= <param_decl> [{= | DEFAULT} <value>]

<outparam>  ::=  <param_decl>

<value> ::=  {literal | NULL | context_var}

<param_decl> ::= paramname <type> [NOT NULL] [COLLATE collation]

<extname> ::= '<module name>!<routine name>[!<misc info>]'

<type> ::= <datatype> | [TYPE OF] domain | TYPE OF COLUMN rel.col

<datatype> ::=
    {SMALLINT | INT[EGER] | BIGINT}
  | BOOLEAN
  | {FLOAT | DOUBLE PRECISION}
  | {DATE | TIME | TIMESTAMP}
  | {DECIMAL | NUMERIC} [(precision [, scale])]
  | {CHAR | CHARACTER | CHARACTER VARYING | VARCHAR} [(size)]
    [CHARACTER SET charset]
  | {NCHAR | NATIONAL CHARACTER | NATIONAL CHAR} [VARYING] [(size)]
  | BLOB [SUB_TYPE {subtype_num | subtype_name}]
    [SEGMENT SIZE seglen] [CHARACTER SET charset]
  | BLOB [(seglen [, subtype_num])]

ALTER PROCEDURE procname [(<inparam> [, <inparam> ...])]
RETURNS (<outparam> [, <outparam> ...])
EXTERNAL NAME <extname> ENGINE <engine>
[AS <extbody>]

DROP PROCEDURE procname

create procedure gen_rows_pascal (
    start_n integer not null,
    end_n integer not null
)
returns (
    result integer not null
)
external name 'pascaludr!gen_rows'
engine udr;

create or alter procedure write_log (
  message varchar(100)
)
external name 'pascaludr!write_log'
engine udr;

create or alter procedure employee_pgsql (
  -- Firebird 3.0.0 has a bug with external procedures without parameters
  dummy integer = 1
)
returns (
  id type of column employee.id,
  name type of column employee.name
)
external name 'org.firebirdsql.fbjava.examples.fbjava_example.FbJdbc
    .executeQuery()!jdbc:postgresql:employee|postgres|postgres'
engine java
as 'select * from employee';

{CREATE [OR ALTER] | RECREATE} PACKAGE package_name
AS
BEGIN
  [<package_item> ...]
END

{CREATE | RECREATE} PACKAGE BODY package_name
AS
BEGIN
  [<package_item> ...]
  [<package_body_item> ...]
END

<package_item> ::=
    <function_decl>;
  | <procedure_decl>;

<function_decl> ::=
  FUNCTION func_name [(<in_params>)]
  RETURNS <type> [COLLATE collation]
  [DETERMINISTIC]

<procedure_decl> ::=
  PROCEDURE proc_name [(<in_params>)]
  [RETURNS (<out_params>)]

<package_body_item> ::=
    <function_impl>
  | <procedure_impl>

<function_impl> ::=
  FUNCTION func_name [(<in_impl_params>)]
  RETURNS <type> [COLLATE collation]
  [DETERMINISTIC]
  <routine body>

<procedure_impl> ::=
  PROCEDURE proc_name [(<in_impl_params>)]
  [RETURNS (<out_params>)]
  <routine body>

<routine body> ::= <sql routine body> | <external body reference>

<sql routine body> ::=
  AS
    [<declarations>]
  BEGIN
    [<PSQL_statements>]
  END

<declarations> ::= <declare_item> [<declare_item> ...]

<declare_item> ::=
    <declare_var>;
  | <declare_cursor>;
  | <subroutine declaration>;
  | <subroutine implimentation>

<subroutine declaration> ::= <subfunc_decl> | <subproc_decl>

<subroutine implimentation> ::= <subfunc_impl> | <subproc_impl>

<external body reference> ::=
  EXTERNAL NAME <extname> ENGINE <engine> [AS <extbody>]

<extname> ::= '<module name>!<routine name>[!<misc info>]'

SET TERM ^;

CREATE OR ALTER PACKAGE REGEXP
AS
BEGIN
  PROCEDURE preg_match(
      APattern VARCHAR(8192), ASubject VARCHAR(8192))
    RETURNS (Matches VARCHAR(8192));

  FUNCTION preg_is_match(
      APattern VARCHAR(8192), ASubject VARCHAR(8192))
    RETURNS BOOLEAN;

  FUNCTION preg_replace(
      APattern VARCHAR(8192),
      AReplacement VARCHAR(8192),
      ASubject VARCHAR(8192))
    RETURNS VARCHAR(8192);

  PROCEDURE preg_split(
      APattern VARCHAR(8192),
      ASubject VARCHAR(8192))
    RETURNS (Lines VARCHAR(8192));

  FUNCTION preg_quote(
      AStr VARCHAR(8192),
      ADelimiter CHAR(10) DEFAULT NULL)
    RETURNS VARCHAR(8192);
END^

RECREATE PACKAGE BODY REGEXP
AS
BEGIN
  PROCEDURE preg_match(
      APattern VARCHAR(8192),
      ASubject VARCHAR(8192))
    RETURNS (Matches VARCHAR(8192))
    EXTERNAL NAME 'PCRE!preg_match' ENGINE UDR;

  FUNCTION preg_is_match(
      APattern VARCHAR(8192),
      ASubject VARCHAR(8192))
    RETURNS BOOLEAN
  AS
  BEGIN
    RETURN EXISTS(
      SELECT * FROM preg_match(:APattern, :ASubject));
  END

  FUNCTION preg_replace(
      APattern VARCHAR(8192),
      AReplacement VARCHAR(8192),
      ASubject VARCHAR(8192))
    RETURNS VARCHAR(8192)
    EXTERNAL NAME 'PCRE!preg_replace' ENGINE UDR;

  PROCEDURE preg_split(
      APattern VARCHAR(8192),
      ASubject VARCHAR(8192))
    RETURNS (Lines VARCHAR(8192))
    EXTERNAL NAME 'PCRE!preg_split' ENGINE UDR;

  FUNCTION preg_quote(
      AStr VARCHAR(8192),
      ADelimiter CHAR(10))
    RETURNS VARCHAR(8192)
    EXTERNAL NAME 'PCRE!preg_quote' ENGINE UDR;
END^

SET TERM ;^

{CREATE [OR ALTER] | RECREATE} TRIGGER trigname
{
    <relation_trigger_legacy>
  | <relation_trigger_sql2003>
  | <database_trigger>
  | <ddl_trigger>
}
<external-body>

<external-body> ::=
  EXTERNAL NAME <extname> ENGINE <engine>
  [AS <extbody>]

<relation_trigger_legacy> ::=
  FOR {tablename | viewname}
  [ACTIVE | INACTIVE]
  {BEFORE | AFTER} <mutation_list>
  [POSITION number]

<relation_trigger_sql2003> ::=
  [ACTIVE | INACTIVE]
  {BEFORE | AFTER} <mutation_list>
  [POSITION number]
  ON {tablename | viewname}

<database_trigger> ::=
  [ACTIVE | INACTIVE]
  ON db_event
  [POSITION number]

<ddl_trigger> ::=
  [ACTIVE | INACTIVE]
  {BEFORE | AFTER} <ddl_events>
  [POSITION number]

<mutation_list> ::= <mutation> [OR <mutation> [OR <mutation>]]

<mutation> ::= INSERT | UPDATE | DELETE

<db_event> ::=
    CONNECT
  | DISCONNECT
  | TRANSACTION START
  | TRANSACTION COMMIT
  | TRANSACTION ROLLBACK


<ddl_events> ::=
    ANY DDL STATEMENT
  | <ddl_event_item> [{OR <ddl_event_item>} ...]

<ddl_event_item> ::=
    CREATE TABLE | ALTER TABLE | DROP TABLE
  | CREATE PROCEDURE | ALTER PROCEDURE | DROP PROCEDURE
  | CREATE FUNCTION | ALTER FUNCTION | DROP FUNCTION
  | CREATE TRIGGER | ALTER TRIGGER | DROP TRIGGER
  | CREATE EXCEPTION | ALTER EXCEPTION | DROP EXCEPTION
  | CREATE VIEW | ALTER VIEW | DROP VIEW
  | CREATE DOMAIN | ALTER DOMAIN | DROP DOMAIN
  | CREATE ROLE | ALTER ROLE | DROP ROLE
  | CREATE SEQUENCE | ALTER SEQUENCE | DROP SEQUENCE
  | CREATE USER | ALTER USER | DROP USER
  | CREATE INDEX | ALTER INDEX | DROP INDEX
  | CREATE COLLATION | DROP COLLATION
  | ALTER CHARACTER SET
  | CREATE PACKAGE | ALTER PACKAGE | DROP PACKAGE
  | CREATE PACKAGE BODY | DROP PACKAGE BODY
  | CREATE MAPPING | ALTER MAPPING | DROP MAPPING

ALTER TRIGGER trigname {
[ACTIVE | INACTIVE]
[
    {BEFORE | AFTER} {<mutation_list> | <ddl_events>}
  | ON db_event
]
[POSITION number]
[<external-body>]

<external-body> ::=
  EXTERNAL NAME <extname> ENGINE <engine>
  [AS <extbody>]

<extname> ::= '<module name>!<routine name>[!<misc info>]'

<mutation_list> ::= <mutation> [OR <mutation> [OR <mutation>]]

<mutation> ::= { INSERT | UPDATE | DELETE }

DROP TRIGGER trigname

create database 'c:\temp\slave.fdb';

create table persons (
    id integer not null,
    name varchar(60) not null,
    address varchar(60),
    info blob sub_type text
);

commit;

create database 'c:\temp\master.fdb';

create table persons (
    id integer not null,
    name varchar(60) not null,
    address varchar(60),
    info blob sub_type text
);

create table replicate_config (
    name varchar(31) not null,
    data_source varchar(255) not null
);

insert into replicate_config (name, data_source)
   values ('ds1', 'c:\temp\slave.fdb');

create trigger persons_replicate
after insert on persons
external name 'udrcpp_example!replicate!ds1'
engine udr;

unit UdrInit;

{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses
  Firebird;

// точка входа для External Engine модуля UDR
function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;

implementation

uses
  SumArgsFunc;

var
  myUnloadFlag: Boolean;
  theirUnloadFlag: BooleanPtr;

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем наши функции
  AUdrPlugin.registerFunction(AStatus, 'sum_args',
    TSumArgsFunctionFactory.Create());
  // регистрируем наши процедуры
  //AUdrPlugin.registerProcedure(AStatus, 'sum_args_proc',
  //  TSumArgsProcedureFactory.Create());
  //AUdrPlugin.registerProcedure(AStatus, 'gen_rows', TGenRowsFactory.Create());
  // регистрируем наши триггеры
  //AUdrPlugin.registerTrigger(AStatus, 'test_trigger',
  //  TMyTriggerFactory.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

initialization

myUnloadFlag := false;

finalization

if ((theirUnloadFlag <> nil) and not myUnloadFlag) then
  theirUnloadFlag^ := true;

end.

unit SumArgsFunc;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses
  Firebird;

{ *********************************************************
    create function sum_args (
      n1 integer,
      n2 integer,
      n3 integer
    ) returns integer
    external name 'myudr!sum_args'
    engine udr;
 ********************************************************* }

type
  // структура на которое будет отображено входное сообщение
  TSumArgsInMsg = record
    n1: Integer;
    n1Null: WordBool;
    n2: Integer;
    n2Null: WordBool;
    n3: Integer;
    n3Null: WordBool;
  end;
  PSumArgsInMsg = ^TSumArgsInMsg;

  // структура на которое будет отображено выходное сообщение
  TSumArgsOutMsg = record
    result: Integer;
    resultNull: WordBool;
  end;
  PSumArgsOutMsg = ^TSumArgsOutMsg;

  // Фабрика для создания экземпляра внешней функции TSumArgsFunction
  TSumArgsFunctionFactory = class(IUdrFunctionFactoryImpl)
    // Вызывается при уничтожении фабрики
    procedure dispose(); override;

    { Выполняется каждый раз при загрузке внешней функции в кеш метаданных.
      Используется для изменения формата входного и выходного сообщения.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AMetadata Метаданные внешней функции)
      @param(AInBuilder Построитель сообщения для входных метаданных)
      @param(AOutBuilder Построитель сообщения для выходных метаданных)
    }
    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    { Создание нового экземпляра внешней функции TSumArgsFunction

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AMetadata Метаданные внешней функции)
      @returns(Экземпляр внешней функции)
    }
    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalFunction; override;
  end;

  // Внешняя функция TSumArgsFunction.
  TSumArgsFunction = class(IExternalFunctionImpl)
    // Вызывается при уничтожении экземпляра функции
    procedure dispose(); override;

    { Этот метод вызывается непосредственно перед execute и сообщает
      ядру наш запрошенный набор символов для обмена данными внутри
      этого метода. Во время этого вызова контекст использует набор символов,
      полученный из ExternalEngine::getCharSet.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AName Имя набора символов)
      @param(AName Длина имени набора символов)
    }
    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;
      AName: PAnsiChar; ANameSize: Cardinal); override;

    { Выполнение внешней функции

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AInMsg Указатель на входное сообщение)
      @param(AOutMsg Указатель на выходное сообщение)
    }
    procedure execute(AStatus: IStatus; AContext: IExternalContext;
      AInMsg: Pointer; AOutMsg: Pointer); override;
  end;

implementation

{ TSumArgsFunctionFactory }

procedure TSumArgsFunctionFactory.dispose;
begin
  Destroy;
end;

function TSumArgsFunctionFactory.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
begin
  Result := TSumArgsFunction.Create();
end;

procedure TSumArgsFunctionFactory.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;

{ TSumArgsFunction }

procedure TSumArgsFunction.dispose;
begin
  Destroy;
end;

procedure TSumArgsFunction.execute(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer);
var
  xInput: PSumArgsInMsg;
  xOutput: PSumArgsOutMsg;
begin
  // преобразовываем указатели на вход и выход к типизированным
  xInput := PSumArgsInMsg(AInMsg);
  xOutput := PSumArgsOutMsg(AOutMsg);
  // по умолчанию выходной аргумент = NULL, а поэтому выставляем ему nullFlag
  xOutput^.resultNull := True;
  // если один из аргументов NULL значит и результат NULL
  // в противном случае считаем сумму аргументов
  with xInput^ do
  begin
    if not (n1Null or n2Null or n3Null) then
    begin
      xOutput^.result := n1 + n2 + n3;
      // раз есть результат, то сбрасываем NULL флаг
      xOutput^.resultNull := False;
    end;
  end;
end;

procedure TSumArgsFunction.getCharSet(AStatus: IStatus;
  AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal);
begin
end;

end.

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем наши функции
  AUdrPlugin.registerFunction(AStatus, 'sum_args',
    TSumArgsFunctionFactory.Create());
  // регистрируем наши процедуры
  AUdrPlugin.registerProcedure(AStatus, 'sum_args_proc',
    TSumArgsProcedureFactory.Create());
  //AUdrPlugin.registerProcedure(AStatus, 'gen_rows', TGenRowsFactory.Create());
  // регистрируем наши триггеры
  //AUdrPlugin.registerTrigger(AStatus, 'test_trigger',
  //  TMyTriggerFactory.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

unit SumArgsProc;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses
  Firebird;

  { **********************************************************

    create procedure sp_sum_args (
      n1 integer,
      n2 integer,
      n3 integer
    ) returns (result integer)
    external name 'myudr!sum_args_proc'
    engine udr;

    ********************************************************* }
type
  // структура на которое будет отображено входное сообщение
  TSumArgsInMsg = record
    n1: Integer;
    n1Null: WordBool;
    n2: Integer;
    n2Null: WordBool;
    n3: Integer;
    n3Null: WordBool;
  end;
  PSumArgsInMsg = ^TSumArgsInMsg;

  // структура на которое будет отображено выходное сообщение
  TSumArgsOutMsg = record
    result: Integer;
    resultNull: WordBool;
  end;
  PSumArgsOutMsg = ^TSumArgsOutMsg;

  // Фабрика для создания экземпляра внешней процедуры TSumArgsProcedure
  TSumArgsProcedureFactory = class(IUdrProcedureFactoryImpl)
    // Вызывается при уничтожении фабрики
    procedure dispose(); override;

    { Выполняется каждый раз при загрузке внешней процедуры в кеш метаданных
      Используется для изменения формата входного и выходного сообщения.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней процедуры)
      @param(AMetadata Метаданные внешней процедуры)
      @param(AInBuilder Построитель сообщения для входных метаданных)
      @param(AOutBuilder Построитель сообщения для выходных метаданных)
    }
    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    { Создание нового экземпляра внешней процедуры TSumArgsProcedure

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней процедуры)
      @param(AMetadata Метаданные внешней процедуры)
      @returns(Экземпляр внешней процедуры)
    }
    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalProcedure; override;
  end;

  TSumArgsProcedure = class(IExternalProcedureImpl)
  public
    // Вызывается при уничтожении экземпляра процедуры
    procedure dispose(); override;

    { Этот метод вызывается непосредственно перед open и сообщает
      ядру наш запрошенный набор символов для обмена данными внутри
      этого метода. Во время этого вызова контекст использует набор символов,
      полученный из ExternalEngine::getCharSet.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AName Имя набора символов)
      @param(AName Длина имени набора символов)
    }
    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;
      AName: PAnsiChar; ANameSize: Cardinal); override;

    { Выполнение внешней процедуры

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AInMsg Указатель на входное сообщение)
      @param(AOutMsg Указатель на выходное сообщение)
      @returns(Набор данных для селективной процедуры или
               nil для процедур выполнения)
    }
    function open(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer;
      AOutMsg: Pointer): IExternalResultSet; override;
  end;

implementation

{ TSumArgsProcedureFactory }

procedure TSumArgsProcedureFactory.dispose;
begin
  Destroy;
end;

function TSumArgsProcedureFactory.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure;
begin
  Result := TSumArgsProcedure.create;
end;

procedure TSumArgsProcedureFactory.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder,
  AOutBuilder: IMetadataBuilder);
begin

end;

{ TSumArgsProcedure }

procedure TSumArgsProcedure.dispose;
begin
  Destroy;
end;

procedure TSumArgsProcedure.getCharSet(AStatus: IStatus;
  AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal);
begin

end;

function TSumArgsProcedure.open(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer): IExternalResultSet;
var
  xInput: PSumArgsInMsg;
  xOutput: PSumArgsOutMsg;
begin
  // Набор данных для выполняемых процедур возращать не надо
  Result := nil;
  // преобразовываем указатели на вход и выход к типизированным
  xInput := PSumArgsInMsg(AInMsg);
  xOutput := PSumArgsOutMsg(AOutMsg);
  // по умолчанию выходной аргумент = NULL, а поэтому выставляем ему nullFlag
  xOutput^.resultNull := True;
  // если один из аргументов NULL значит и результат NULL
  // в противном случае считаем сумму аргументов
  with xInput^ do
  begin
    if not (n1Null or n2Null or n3Null) then
    begin
      xOutput^.result := n1 + n2 + n3;
      // раз есть результат, то сбрасываем NULL флаг
      xOutput^.resultNull := False;
    end;
  end;
end;

end.

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем наши функции
  AUdrPlugin.registerFunction(AStatus, 'sum_args',
    TSumArgsFunctionFactory.Create());
  // регистрируем наши процедуры
  AUdrPlugin.registerProcedure(AStatus, 'sum_args_proc',
    TSumArgsProcedureFactory.Create());
  AUdrPlugin.registerProcedure(AStatus, 'gen_rows', TGenRowsFactory.Create());
  // регистрируем наши триггеры
  //AUdrPlugin.registerTrigger(AStatus, 'test_trigger',
  //  TMyTriggerFactory.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

unit GenRowsProc;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses
  Firebird, SysUtils;

type
  { **********************************************************

    create procedure gen_rows (
      start  integer,
      finish integer
    ) returns (n integer)
    external name 'myudr!gen_rows'
    engine udr;

    ********************************************************* }

  TInput = record
    start: Integer;
    startNull: WordBool;
    finish: Integer;
    finishNull: WordBool;
  end;
  PInput = ^TInput;

  TOutput = record
    n: Integer;
    nNull: WordBool;
  end;
  POutput = ^TOutput;

  // Фабрика для создания экземпляра внешней процедуры TGenRowsProcedure
  TGenRowsFactory = class(IUdrProcedureFactoryImpl)
    // Вызывается при уничтожении фабрики
    procedure dispose(); override;

    { Выполняется каждый раз при загрузке внешней функции в кеш метаданных.
      Используется для изменения формата входного и выходного сообщения.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AMetadata Метаданные внешней функции)
      @param(AInBuilder Построитель сообщения для входных метаданных)
      @param(AOutBuilder Построитель сообщения для выходных метаданных)
    }
    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    { Создание нового экземпляра внешней процедуры TGenRowsProcedure

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AMetadata Метаданные внешней функции)
      @returns(Экземпляр внешней функции)
    }
    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalProcedure; override;
  end;

  // Внешняя процедура TGenRowsProcedure.
  TGenRowsProcedure = class(IExternalProcedureImpl)
  public
    // Вызывается при уничтожении экземпляра процедуры
    procedure dispose(); override;

    { Этот метод вызывается непосредственно перед open и сообщает
      ядру наш запрошенный набор символов для обмена данными внутри
      этого метода. Во время этого вызова контекст использует набор символов,
      полученный из ExternalEngine::getCharSet.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AName Имя набора символов)
      @param(AName Длина имени набора символов)
    }
    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;
      AName: PAnsiChar; ANameSize: Cardinal); override;

    { Выполнение внешней процедуры

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AInMsg Указатель на входное сообщение)
      @param(AOutMsg Указатель на выходное сообщение)
      @returns(Набор данных для селективной процедуры или
               nil для процедур выполнения)
    }
    function open(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer;
      AOutMsg: Pointer): IExternalResultSet; override;
  end;

  // Выходной набор данных для процедуры TGenRowsProcedure
  TGenRowsResultSet = class(IExternalResultSetImpl)
    Input: PInput;
    Output: POutput;

    // Вызывается при уничтожении экземпляра набора данных
    procedure dispose(); override;

    { Извлечение очередной записи из набора данных.
      В некотором роде аналог SUSPEND. В этом методе должна
      подготавливаться очередная запись из набора данных.

      @param(AStatus Статус вектор)
      @returns(True если в наборе данных есть запись для извлечения,
               False если записи закончились)
    }
    function fetch(AStatus: IStatus): Boolean; override;
  end;

implementation

{ TGenRowsFactory }

procedure TGenRowsFactory.dispose;
begin
  Destroy;
end;

function TGenRowsFactory.newItem(AStatus: IStatus; AContext: IExternalContext;
  AMetadata: IRoutineMetadata): IExternalProcedure;
begin
  Result := TGenRowsProcedure.create;
end;

procedure TGenRowsFactory.setup(AStatus: IStatus; AContext: IExternalContext;
  AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;

{ TGenRowsProcedure }

procedure TGenRowsProcedure.dispose;
begin
  Destroy;
end;

procedure TGenRowsProcedure.getCharSet(AStatus: IStatus;
  AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal);
begin

end;

function TGenRowsProcedure.open(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer): IExternalResultSet;
begin
  Result := TGenRowsResultSet.create;
  with TGenRowsResultSet(Result) do
  begin
    Input := AInMsg;
    Output := AOutMsg;
  end;

  // если один из входных аргументов NULL ничего не возвращаем
  if PInput(AInMsg).startNull or PInput(AInMsg).finishNull then
  begin
    POutput(AOutMsg).nNull := True;
        // намеренно ставим выходной результат таким, чтобы
        // метод TGenRowsResultSet.fetch вернул false
    Output.n := Input.finish;
    exit;
  end;
  // проверки
  if PInput(AInMsg).start > PInput(AInMsg).finish then
    raise Exception.Create('First parameter greater then second parameter.');

  with TGenRowsResultSet(Result) do
  begin
    // начальное значение
    Output.nNull := False;
    Output.n := Input.start - 1;
  end;
end;

{ TGenRowsResultSet }

procedure TGenRowsResultSet.dispose;
begin
  Destroy;
end;

// Если возвращает True то извлекается очередная запись из набора данных.
// Если возвращает False то записи в наборе данных закончились
// новые значения в выходном векторе вычисляются каждый раз
// при вызове этого метода
function TGenRowsResultSet.fetch(AStatus: IStatus): Boolean;
begin
  Inc(Output.n);
  Result := (Output.n <= Input.finish);
end;

end.

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем наши функции
  AUdrPlugin.registerFunction(AStatus, 'sum_args',
    TSumArgsFunctionFactory.Create());
  // регистрируем наши процедуры
  AUdrPlugin.registerProcedure(AStatus, 'sum_args_proc',
    TSumArgsProcedureFactory.Create());
  AUdrPlugin.registerProcedure(AStatus, 'gen_rows', TGenRowsFactory.Create());
  // регистрируем наши триггеры
  AUdrPlugin.registerTrigger(AStatus, 'test_trigger',
    TMyTriggerFactory.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

unit TestTrigger;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses
  Firebird, SysUtils;

type
  { **********************************************************
    create table test (
      id int generated by default as identity,
      a int,
      b int,
      name varchar(100),
      constraint pk_test primary key(id)
    );

    create or alter trigger tr_test_biu for test
    active before insert or update position 0
    external name 'myudr!test_trigger'
    engine udr;
  }

  // структура для отображения сообщений NEW.* и OLD.*
  // должна соответствовать набору полей таблицы test
  TFieldsMessage = record
    Id: Integer;
    IdNull: WordBool;
    A: Integer;
    ANull: WordBool;
    B: Integer;
    BNull: WordBool;
    Name: record
      Length: Word;
      Value: array [0 .. 399] of AnsiChar;
    end;
    NameNull: WordBool;
  end;

  PFieldsMessage = ^TFieldsMessage;

  // Фабрика для создания экземпляра внешнего триггера TMyTrigger
  TMyTriggerFactory = class(IUdrTriggerFactoryImpl)
    // Вызывается при уничтожении фабрики
    procedure dispose(); override;

    { Выполняется каждый раз при загрузке внешнего триггера в кеш метаданных.
      Используется для изменения формата сообщений для полей.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешнего триггера)
      @param(AMetadata Метаданные внешнего триггера)
      @param(AFieldsBuilder Построитель сообщения для полей таблицы)
    }
    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); override;

    { Создание нового экземпляра внешнего триггера TMyTrigger

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешнего триггера)
      @param(AMetadata Метаданные внешнего триггера)
      @returns(Экземпляр внешнего триггера)
    }
    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalTrigger; override;
  end;

  TMyTrigger = class(IExternalTriggerImpl)
    // Вызывается при уничтожении триггера
    procedure dispose(); override;

    { Этот метод вызывается непосредственно перед execute и сообщает
      ядру наш запрошенный набор символов для обмена данными внутри
      этого метода. Во время этого вызова контекст использует набор символов,
      полученный из ExternalEngine::getCharSet.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешнего триггера)
      @param(AName Имя набора символов)
      @param(AName Длина имени набора символов)
    }
    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;

      AName: PAnsiChar; ANameSize: Cardinal); override;

    { выполнение триггера TMyTrigger

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешнего триггера)
      @param(AAction Действие (текущее событие) триггера)
      @param(AOldMsg Сообщение для старых значение полей :OLD.*)
      @param(ANewMsg Сообщение для новых значение полей :NEW.*)
    }
    procedure execute(AStatus: IStatus; AContext: IExternalContext;
      AAction: Cardinal; AOldMsg: Pointer; ANewMsg: Pointer); override;
  end;

implementation

{ TMyTriggerFactory }

procedure TMyTriggerFactory.dispose;
begin
  Destroy;
end;

function TMyTriggerFactory.newItem(AStatus: IStatus; AContext: IExternalContext;
  AMetadata: IRoutineMetadata): IExternalTrigger;
begin
  Result := TMyTrigger.create;
end;

procedure TMyTriggerFactory.setup(AStatus: IStatus; AContext: IExternalContext;
  AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder);
begin

end;

{ TMyTrigger }

procedure TMyTrigger.dispose;
begin
  Destroy;
end;

procedure TMyTrigger.execute(AStatus: IStatus; AContext: IExternalContext;
  AAction: Cardinal; AOldMsg, ANewMsg: Pointer);
var
  xOld, xNew: PFieldsMessage;
begin
  // xOld := PFieldsMessage(AOldMsg);
  xNew := PFieldsMessage(ANewMsg);
  case AAction of
    IExternalTrigger.ACTION_INSERT:
      begin
        if xNew.BNull and not xNew.ANull then
        begin
          xNew.B := xNew.A + 1;
          xNew.BNull := False;
        end;
      end;

    IExternalTrigger.ACTION_UPDATE:
      begin
        if xNew.BNull and not xNew.ANull then
        begin
          xNew.B := xNew.A + 1;
          xNew.BNull := False;
        end;
      end;

    IExternalTrigger.ACTION_DELETE:
      begin

      end;
  end;
end;

procedure TMyTrigger.getCharSet(AStatus: IStatus; AContext: IExternalContext;
  AName: PAnsiChar; ANameSize: Cardinal);
begin

end;

end.

...
  if (:new.B IS NULL) THEN
    :new.B = :new.A + 1;
...

TMyStruct = record
  <var_1>: <type_1>;
  <nullIndicator_1>: WordBool;
  <var_2>: <type_1>;
  <nullIndicator_2>: WordBool;
  ...
  <var_N>: <type_1>;
  <nullIndicator_N>: WordBool;
end;
PMyStruct = ^TMyStruct;

function SUM_ARGS(A SMALLINT, B INTEGER) RETURNS BIGINT
....

TInput = record
  A: Smallint;
  ANull: WordBool;
  B: Integer;
  BNull: WordBool;
end;
PInput = ^TInput;

TOutput = record
  Value: Int64;
  Null: WordBool;
end;
POutput = ^TOutput;

function SUM_ARGS(A NUMERIC(4, 2), B NUMERIC(9, 3)) RETURNS NUMERIC(18, 6)
....

TInput = record
  A: Smallint;
  ANull: WordBool;
  B: Integer;
  BNull: WordBool;
end;
PInput = ^TInput;

TOutput = record
  Value: Int64;
  Null: WordBool;
end;
POutput = ^TOutput;

procedure SOME_PROC(A CHAR(3) CHARACTER SET WIN1251, B VARCHAR(10) CHARACTER SET UTF8)
....

TInput = record
  A: array[0..2] of AnsiChar;
  ANull: WordBool;
  B: record
    Length: Smallint;
    Value: array[0..39] of AnsiChar;
  end;
  BNull: WordBool;
end;
PInput = ^TInput;

function TSumArgsFunctionFactory.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
begin
  // создаём экземпляр внешней функции
  Result := TSumArgsFunction.Create();
end;

  // Внешняя функция TSumArgsFunction.
  TSumArgsFunction = class(IExternalFunctionImpl)
  private
    FMetadata: IRoutineMetadata;
  public
    property Metadata: IRoutineMetadata read FMetadata write FMetadata;
  public
  ...
  end;

function TSumArgsFunctionFactory.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
begin
  Result := TSumArgsFunction.Create();
  with Result as TSumArgsFunction do
  begin
    Metadata := AMetadata;
  end;
end;

SET TERM ^ ;

CREATE OR ALTER PACKAGE MYUDR2
AS
begin
  function SqrSmallint(AInput SMALLINT) RETURNS INTEGER;
  function SqrInteger(AInput INTEGER) RETURNS BIGINT;
  function SqrBigint(AInput BIGINT) RETURNS BIGINT;
  function SqrFloat(AInput FLOAT) RETURNS DOUBLE PRECISION;
  function SqrDouble(AInput DOUBLE PRECISION) RETURNS DOUBLE PRECISION;
end^

RECREATE PACKAGE BODY MYUDR2
AS
begin
  function SqrSmallint(AInput SMALLINT) RETURNS INTEGER
  external name 'myudr2!sqrt_func'
  engine udr;

  function SqrInteger(AInput INTEGER) RETURNS BIGINT
  external name 'myudr2!sqrt_func'
  engine udr;

  function SqrBigint(AInput BIGINT) RETURNS BIGINT
  external name 'myudr2!sqrt_func'
  engine udr;

  function SqrFloat(AInput FLOAT) RETURNS DOUBLE PRECISION
  external name 'myudr2!sqrt_func'
  engine udr;

  function SqrDouble(AInput DOUBLE PRECISION) RETURNS DOUBLE PRECISION
  external name 'myudr2!sqrt_func'
  engine udr;

end
^

SET TERM ; ^

select
  myudr2.SqrSmallint(1) as n1,
  myudr2.SqrInteger(2) as n2,
  myudr2.SqrBigint(3) as n3,
  myudr2.SqrFloat(3.1) as n4,
  myudr2.SqrDouble(3.2) as n5
from rdb$database

.......................
type
  // структура на которое будет отображено входное сообщение
  TSqrInMsg<T> = record
    n1: T;
    n1Null: WordBool;
  end;

  // структура на которое будет отображено выходное сообщение
  TSqrOutMsg<T> = record
    result: T;
    resultNull: WordBool;
  end;

  // Фабрика для создания экземпляра внешней функции TSqrFunction
  TSqrFunctionFactory = class(IUdrFunctionFactoryImpl)
    // Вызывается при уничтожении фабрики
    procedure dispose(); override;

    { Выполняется каждый раз при загрузке внешней функции в кеш метаданных.
      Используется для изменения формата входного и выходного сообщения.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AMetadata Метаданные внешней функции)
      @param(AInBuilder Построитель сообщения для входных метаданных)
      @param(AOutBuilder Построитель сообщения для выходных метаданных)
    }
    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    { Создание нового экземпляра внешней функции TSqrFunction

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AMetadata Метаданные внешней функции)
      @returns(Экземпляр внешней функции)
    }
    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalFunction; override;
  end;


  // Внешняя функция TSqrFunction.
  TSqrFunction<TIn, TOut> = class(IExternalFunctionImpl)
  private
    function sqrExec(AIn: TIn): TOut; virtual; abstract;
  public
    type
      TInput = TSqrInMsg<TIn>;
      TOutput = TSqrOutMsg<TOut>;
      PInput = ^TInput;
      POutput = ^TOutput;
    // Вызывается при уничтожении экземпляра функции
    procedure dispose(); override;

    { Этот метод вызывается непосредственно перед execute и сообщает
      ядру наш запрошенный набор символов для обмена данными внутри
      этого метода. Во время этого вызова контекст использует набор символов,
      полученный из ExternalEngine::getCharSet.

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AName Имя набора символов)
      @param(AName Длина имени набора символов)
    }
    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;
      AName: PAnsiChar; ANameSize: Cardinal); override;

    { Выполнение внешней функции

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AInMsg Указатель на входное сообщение)
      @param(AOutMsg Указатель на выходное сообщение)
    }
    procedure execute(AStatus: IStatus; AContext: IExternalContext;
      AInMsg: Pointer; AOutMsg: Pointer); override;
  end;

  TSqrExecSmallint = class(TSqrFunction<Smallint, Integer>)
  public
    function sqrExec(AIn: Smallint): Integer; override;
  end;

  TSqrExecInteger = class(TSqrFunction<Integer, Int64>)
  public
    function sqrExec(AIn: Integer): Int64; override;
  end;

  TSqrExecInt64 = class(TSqrFunction<Int64, Int64>)
  public
    function sqrExec(AIn: Int64): Int64; override;
  end;

  TSqrExecFloat = class(TSqrFunction<Single, Double>)
  public
    function sqrExec(AIn: Single): Double; override;
  end;

  TSqrExecDouble = class(TSqrFunction<Double, Double>)
  public
    function sqrExec(AIn: Double): Double; override;
  end;

implementation

uses
  SysUtils, FbTypes, System.TypInfo;

{ TSqrFunctionFactory }

procedure TSqrFunctionFactory.dispose;
begin
  Destroy;
end;

function TSqrFunctionFactory.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
var
  xInputMetadata: IMessageMetadata;
  xInputType: TFBType;
begin
  // получаем тип входного аргумента
  xInputMetadata := AMetadata.getInputMetadata(AStatus);
  xInputType := TFBType(xInputMetadata.getType(AStatus, 0));
  xInputMetadata.release;
  // создаём экземпляр функции в зависимости от типа
  case xInputType of
    SQL_SHORT:
      result := TSqrExecSmallint.Create();

    SQL_LONG:
      result := TSqrExecInteger.Create();
    SQL_INT64:
      result := TSqrExecInt64.Create();

    SQL_FLOAT:
      result := TSqrExecFloat.Create();
    SQL_DOUBLE, SQL_D_FLOAT:
      result := TSqrExecDouble.Create();
  else
    result := TSqrExecInt64.Create();
  end;

end;

procedure TSqrFunctionFactory.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;

{ TSqrFunction }

procedure TSqrFunction<TIn, TOut>.dispose;
begin
  Destroy;
end;

procedure TSqrFunction<TIn, TOut>.execute(AStatus: IStatus;
  AContext: IExternalContext; AInMsg, AOutMsg: Pointer);
var
  xInput: PInput;
  xOutput: POutput;
begin
  xInput := PInput(AInMsg);
  xOutput := POutput(AOutMsg);
  xOutput.resultNull := True;
  if (not xInput.n1Null) then
  begin
    xOutput.resultNull := False;
    xOutput.result := Self.sqrExec(xInput.n1);
  end;
end;

procedure TSqrFunction<TIn, TOut>.getCharSet(AStatus: IStatus;
  AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal);
begin
end;


{ TSqrtExecSmallint }

function TSqrExecSmallint.sqrExec(AIn: Smallint): Integer;
begin
  Result := AIn * AIn;
end;

{ TSqrExecInteger }

function TSqrExecInteger.sqrExec(AIn: Integer): Int64;
begin
  Result := AIn * AIn;
end;

{ TSqrExecInt64 }

function TSqrExecInt64.sqrExec(AIn: Int64): Int64;
begin
  Result := AIn * AIn;
end;

{ TSqrExecFloat }

function TSqrExecFloat.sqrExec(AIn: Single): Double;
begin
  Result := AIn * AIn;
end;

{ TSqrExecDouble }

function TSqrExecDouble.sqrExec(AIn: Double): Double;
begin
  Result := AIn * AIn;
end;

.................

type
  // структура на которое будет отображено входное сообщение
  TSumArgsInMsg = record
    n1: Integer;
    n1Null: WordBool;
    n2: Integer;
    n2Null: WordBool;
    n3: Integer;
    n3Null: WordBool;
  end;

  PSumArgsInMsg = ^TSumArgsInMsg;

  // структура на которое будет отображено выходное сообщение
  TSumArgsOutMsg = record
    result: Integer;
    resultNull: WordBool;
  end;

  PSumArgsOutMsg = ^TSumArgsOutMsg;

{ TSumArgsFunctionFactory }

procedure TSumArgsFunctionFactory.dispose;
begin
  Destroy;
end;

function TSumArgsFunctionFactory.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
begin
  Result := TSumArgsFunction.Create();
end;

procedure TSumArgsFunctionFactory.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin
  // строим сообщение для входных параметров
  AInBuilder.setType(AStatus, 0, Cardinal(SQL_LONG));
  AInBuilder.setLength(AStatus, 0, sizeof(Int32));
  AInBuilder.setType(AStatus, 1, Cardinal(SQL_LONG));
  AInBuilder.setLength(AStatus, 1, sizeof(Int32));
  AInBuilder.setType(AStatus, 2, Cardinal(SQL_LONG));
  AInBuilder.setLength(AStatus, 2, sizeof(Int32));
  // строим сообщение для выходных параметров
  AOutBuilder.setType(AStatus, 0, Cardinal(SQL_LONG));
  AOutBuilder.setLength(AStatus, 0, sizeof(Int32));
end;

procedure TSumArgsFunction.execute(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer);
var
  xInput: PSumArgsInMsg;
  xOutput: PSumArgsOutMsg;
begin
  // преобразовываем указатели на вход и выход к типизированным
  xInput := PSumArgsInMsg(AInMsg);
  xOutput := PSumArgsOutMsg(AOutMsg);
  // по умолчанию выходной аргемент = NULL, а потому выставляем ему nullFlag
  xOutput^.resultNull := True;
  // если один из аргументов NULL значит и резултат NULL
  // в противном случае считаем сумму аргументов
  with xInput^ do
  begin
    if not(n1Null or n2Null or n3Null) then
    begin
      xOutput^.result := n1 + n2 + n3;
      // раз есть результат, то сбрасываем NULL флаг
      xOutput^.resultNull := False;
    end;
  end;
end;

CREATE OR ALTER FUNCTION FN_SUM_ARGS (
    N1 VARCHAR(15),
    N2 VARCHAR(15),
    N3 VARCHAR(15))
RETURNS VARCHAR(15)
EXTERNAL NAME 'MyUdrSetup!sum_args'
ENGINE UDR;

select FN_SUM_ARGS('15', '21', '35') from rdb$database

unit UdrFactories;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses SysUtils, Firebird;

type

  // Простая фабрика внешних функций
  TFunctionSimpleFactory<T: IExternalFunctionImpl, constructor> = class
    (IUdrFunctionFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalFunction; override;
  end;

  // Простая фабрика внешних процедур
  TProcedureSimpleFactory<T: IExternalProcedureImpl, constructor> = class
    (IUdrProcedureFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalProcedure; override;
  end;

  // Простая фабрика внешних триггеров
  TTriggerSimpleFactory<T: IExternalTriggerImpl, constructor> = class
    (IUdrTriggerFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalTrigger; override;
  end;

implementation

{ TProcedureSimpleFactory<T> }

procedure TProcedureSimpleFactory<T>.dispose;
begin
  Destroy;
end;

function TProcedureSimpleFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure;
begin
  Result := T.Create;
end;

procedure TProcedureSimpleFactory<T>.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;


{ TFunctionFactory<T> }

procedure TFunctionSimpleFactory<T>.dispose;
begin
  Destroy;
end;

function TFunctionSimpleFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
begin
  Result := T.Create;
end;

procedure TFunctionSimpleFactory<T>.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;

{ TTriggerSimpleFactory<T> }

procedure TTriggerSimpleFactory<T>.dispose;
begin
  Destroy;
end;

function TTriggerSimpleFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalTrigger;
begin
  Result := T.Create;
end;

procedure TTriggerSimpleFactory<T>.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AFieldsBuilder: IMetadataBuilder);
begin

end;

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем нашу функцию
  AUdrPlugin.registerFunction(AStatus, 'sum_args',
    TFunctionSimpleFactory<TSumArgsFunction>.Create());
  // регистрируем нашу процедуру
  AUdrPlugin.registerProcedure(AStatus, 'gen_rows',
    TProcedureSimpleFactory<TGenRowsProcedure>.Create());
  // регистрируем наш триггер
  AUdrPlugin.registerTrigger(AStatus, 'test_trigger',
    TTriggerSimpleFactory<TMyTrigger>.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

unit UdrFactories;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses SysUtils, Firebird;

type
...

  // Внешняя функция с метаданными
  TExternalFunction = class(IExternalFunctionImpl)
    Metadata: IRoutineMetadata;
  end;

  // Внешняя процедура с метаданными
  TExternalProcedure = class(IExternalProcedureImpl)
    Metadata: IRoutineMetadata;
  end;

  // Внешний триггер с метаданными
  TExternalTrigger = class(IExternalTriggerImpl)
    Metadata: IRoutineMetadata;
  end;

unit UdrFactories;

{$IFDEF FPC}
{$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses SysUtils, Firebird;

type
...

  // Фабрика внешних функций с метаданными
  TFunctionFactory<T: TExternalFunction, constructor> = class
    (IUdrFunctionFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalFunction; override;
  end;

  // Фабрика внешних процедур с метаданными
  TProcedureFactory<T: TExternalProcedure, constructor> = class
    (IUdrProcedureFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalProcedure; override;
  end;

  // Фабрика внешних триггеров с метаданными
  TTriggerFactory<T: TExternalTrigger, constructor> = class
    (IUdrTriggerFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalTrigger; override;
  end;

implementation
...

{ TFunctionFactory<T> }

procedure TFunctionFactory<T>.dispose;
begin
  Destroy;
end;

function TFunctionFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction;
begin
  Result := T.Create;
  (Result as T).Metadata := AMetadata;
end;

procedure TFunctionFactory<T>.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;

{ TProcedureFactory<T> }

procedure TProcedureFactory<T>.dispose;
begin
  Destroy;
end;

function TProcedureFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure;
begin
  Result := T.Create;
  (Result as T).Metadata := AMetadata;
end;

procedure TProcedureFactory<T>.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata;
  AInBuilder, AOutBuilder: IMetadataBuilder);
begin

end;

{ TTriggerFactory<T> }

procedure TTriggerFactory<T>.dispose;
begin
  Destroy;
end;

function TTriggerFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalTrigger;
begin
  Result := T.Create;
  (Result as T).Metadata := AMetadata;
end;

procedure TTriggerFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext;
  AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder);
begin

end;

create procedure split (
    txt blob sub_type text character set utf8,
    delimiter char(1) character set utf8 = ','
)
returns (
    id integer
)
external name 'myudr!split'
engine udr;

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем нашу процедуру
  AUdrPlugin.registerProcedure(AStatus, 'split', TProcedureSimpleFactory<TSplitProcedure>.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

...
interface

uses SysUtils, Firebird;

type

  TProcedureSimpleFactory<T: IExternalProcedureImpl, constructor> =
  class(IUdrProcedureFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalProcedure; override;
  end;

...

implementation

{ TProcedureSimpleFactory<T> }

procedure TProcedureSimpleFactory<T>.dispose;
begin
  Destroy;
end;

function TProcedureSimpleFactory<T>.newItem(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure;
begin
  Result := T.Create;
end;

procedure TProcedureSimpleFactory<T>.setup(AStatus: IStatus;
  AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder,
  AOutBuilder: IMetadataBuilder);
begin

...

  TInput = record
    txt: ISC_QUAD;
    txtNull: WordBool;
    delimiter: array [0 .. 3] of AnsiChar;
    delimiterNull: WordBool;
  end;

  TInputPtr = ^TInput;

  TOutput = record
    Id: Integer;
    Null: WordBool;
  end;

  TOutputPtr = ^TOutput;

  TSplitProcedure = class(IExternalProcedureImpl)
  private
    procedure SaveBlobToStream(AStatus: IStatus; AContext: IExternalContext;
      ABlobId: ISC_QUADPtr; AStream: TStream);
    function readBlob(AStatus: IStatus; AContext: IExternalContext;
      ABlobId: ISC_QUADPtr): string;
  public
    // Вызывается при уничтожении экземпляра процедуры
    procedure dispose(); override;

    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;
      AName: PAnsiChar; ANameSize: Cardinal); override;

    function open(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer;
      AOutMsg: Pointer): IExternalResultSet; override;
  end;

  TSplitResultSet = class(IExternalResultSetImpl)
{$IFDEF FPC}
    OutputArray: TStringArray;
{$ELSE}
    OutputArray: TArray<string>;
{$ENDIF}
    Counter: Integer;
    Output: TOutputPtr;

    procedure dispose(); override;
    function fetch(AStatus: IStatus): Boolean; override;
  end;

function TSplitProcedure.open(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer): IExternalResultSet;
var
  xInput: TInputPtr;
  xText: string;
  xDelimiter: string;
begin
  xInput := AInMsg;

  Result := TSplitResultSet.Create;
  TSplitResultSet(Result).Output := AOutMsg;

  if xInput.txtNull or xInput.delimiterNull then
  begin
    with TSplitResultSet(Result) do
    begin
      // создаём пустой массив
      OutputArray := [];
      Counter := 1;
    end;
    Exit;
  end;

  xText := readBlob(AStatus, AContext, @xInput.txt);
  xDelimiter := TFBCharSet.CS_UTF8.GetString(TBytes(@xInput.delimiter), 0, 4);
  // автоматически не правильно определяется потому что строки
  // не завершены нулём
  // ставим кол-во байт/4
  SetLength(xDelimiter, 1);

  with TSplitResultSet(Result) do
  begin
    OutputArray := xText.Split([xDelimiter], TStringSplitOptions.ExcludeEmpty);
    Counter := 0;
  end;
end;

procedure TSplitProcedure.SaveBlobToStream(AStatus: IStatus;
  AContext: IExternalContext; ABlobId: ISC_QUADPtr; AStream: TStream);
var
  att: IAttachment;
  trx: ITransaction;
  blob: IBlob;
  buffer: array [0 .. 32767] of AnsiChar;
  l: Integer;
begin
  try
    att := AContext.getAttachment(AStatus);
    trx := AContext.getTransaction(AStatus);
    blob := att.openBlob(AStatus, trx, ABlobId, 0, nil);
    while True do
    begin
      case blob.getSegment(AStatus, SizeOf(buffer), @buffer, @l) of
        IStatus.RESULT_OK:
          AStream.WriteBuffer(buffer, l);
        IStatus.RESULT_SEGMENT:
          AStream.WriteBuffer(buffer, l);
      else
        break;
      end;
    end;
    AStream.Position := 0;
    // метод close в случае успеха совобождает интерфейс IBlob
    // поэтому последующий вызов release не нужен
    blob.close(AStatus);
    blob := nil;
  finally
    if Assigned(blob) then
      blob.release;
    if Assigned(trx) then
      trx.release;
    if Assigned(att) then
      att.release;
  end;
end;

function TSplitProcedure.readBlob(AStatus: IStatus; AContext: IExternalContext;
  ABlobId: ISC_QUADPtr): string;
var
{$IFDEF FPC}
  xStream: TBytesStream;
{$ELSE}
  xStream: TStringStream;
{$ENDIF}
begin
{$IFDEF FPC}
  xStream := TBytesStream.Create(nil);
{$ELSE}
  xStream := TStringStream.Create('', 65001);
{$ENDIF}
  try
    SaveBlobToStream(AStatus, AContext, ABlobId, xStream);
{$IFDEF FPC}
    Result := TEncoding.UTF8.GetString(xStream.Bytes, 0, xStream.Size);
{$ELSE}
    Result := xStream.DataString;
{$ENDIF}
  finally
    xStream.Free;
  end;
end;

procedure TSplitResultSet.dispose;
begin
  SetLength(OutputArray, 0);
  Destroy;
end;

function TSplitResultSet.fetch(AStatus: IStatus): Boolean;
var
  statusVector: array [0 .. 4] of NativeIntPtr;
begin
  if Counter <= High(OutputArray) then
  begin
    Output.Null := False;
    // исключение будут перехвачены в любом случае с кодом isc_random
    // здесь же мы будем выбрасывать стандартную для Firebird
    // ошибку isc_convert_error
    try
      Output.Id := OutputArray[Counter].ToInteger();
    except
      on e: EConvertError do
      begin

        statusVector[0] := NativeIntPtr(isc_arg_gds);
        statusVector[1] := NativeIntPtr(isc_convert_error);
        statusVector[2] := NativeIntPtr(isc_arg_string);
        statusVector[3] := NativeIntPtr(PAnsiChar('Cannot convert string to integer'));
        statusVector[4] := NativeIntPtr(isc_arg_end);

        AStatus.setErrors(@statusVector);
      end;
    end;
    inc(Counter);
    Result := True;
  end
  else
    Result := False;
end;

SELECT ids.ID
FROM SPLIT((SELECT LIST(ID) FROM MYTABLE), ',') ids

CREATE PACKAGE BlobFileUtils
AS
BEGIN
  PROCEDURE SaveBlobToFile(ABlob BLOB, AFileName VARCHAR(255) CHARACTER SET UTF8);

  FUNCTION LoadBlobFromFile(AFileName VARCHAR(255) CHARACTER SET UTF8) RETURNS BLOB;
END^

CREATE PACKAGE BODY BlobFileUtils
AS
BEGIN
  PROCEDURE SaveBlobToFile(ABlob BLOB, AFileName VARCHAR(255) CHARACTER SET UTF8)
  EXTERNAL NAME 'BlobFileUtils!SaveBlobToFile'
  ENGINE UDR;

  FUNCTION LoadBlobFromFile(AFileName VARCHAR(255) CHARACTER SET UTF8) RETURNS BLOB
  EXTERNAL NAME 'BlobFileUtils!LoadBlobFromFile'
  ENGINE UDR;
END^

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем
  AUdrPlugin.registerProcedure(AStatus, 'SaveBlobToFile', TSaveBlobToFileProcFactory.Create());
  AUdrPlugin.registerFunction(AStatus, 'LoadBlobFromFile', TLoadBlobFromFileFuncFactory.Create());

  theirUnloadFlag := AUnloadFlagLocal;
  Result := @myUnloadFlag;
end;

interface

uses
  Firebird, Classes, SysUtils;

type

  // входное сообщений функции
  TInput = record
    filename: record
      len: Smallint;
      str: array [0 .. 1019] of AnsiChar;
    end;
    filenameNull: WordBool;
  end;
  TInputPtr = ^TInput;

  // выходное сообщение функции
  TOutput = record
    blobData: ISC_QUAD;
    blobDataNull: WordBool;
  end;
  TOutputPtr = ^TOutput;

  // реализация функции LoadBlobFromFile
  TLoadBlobFromFileFunc = class(IExternalFunctionImpl)
  public
    procedure dispose(); override;

    procedure getCharSet(AStatus: IStatus; AContext: IExternalContext;
      AName: PAnsiChar; ANameSize: Cardinal); override;

    procedure execute(AStatus: IStatus; AContext: IExternalContext;
      AInMsg: Pointer; AOutMsg: Pointer); override;
  end;

  // Фабрика для создания экземпляра внешней функции LoadBlobFromFile
  TLoadBlobFromFileFuncFactory = class(IUdrFunctionFactoryImpl)
    procedure dispose(); override;

    procedure setup(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder;
      AOutBuilder: IMetadataBuilder); override;

    function newItem(AStatus: IStatus; AContext: IExternalContext;
      AMetadata: IRoutineMetadata): IExternalFunction; override;
  end;

procedure TLoadBlobFromFileFunc.execute(AStatus: IStatus;
  AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer);
const
  MaxBufSize = 16384;
var
  xInput: TInputPtr;
  xOutput: TOutputPtr;
  xFileName: string;
  xStream: TFileStream;
  att: IAttachment;
  trx: ITransaction;
  blob: IBlob;
  buffer: array [0 .. 32767] of Byte;
  xStreamSize: Integer;
  xBufferSize: Integer;
  xReadLength: Integer;
begin
  xInput := AInMsg;
  xOutput := AOutMsg;
  if xInput.filenameNull then
  begin
    xOutput.blobDataNull := True;
    Exit;
  end;
  xOutput.blobDataNull := False;
  // получаем имя файла
  xFileName := TEncoding.UTF8.GetString(TBytes(@xInput.filename.str), 0,
    xInput.filename.len * 4);
  SetLength(xFileName, xInput.filename.len);
  // читаем файл в поток
  xStream := TFileStream.Create(xFileName, fmOpenRead or fmShareDenyNone);
  att := AContext.getAttachment(AStatus);
  trx := AContext.getTransaction(AStatus);
  blob := nil;
  try
    xStreamSize := xStream.Size;
    // определяем максимальный размер буфера (сегмента)
    if xStreamSize > MaxBufSize then
      xBufferSize := MaxBufSize
    else
      xBufferSize := xStreamSize;
    // создаём новый blob
    blob := att.createBlob(AStatus, trx, @xOutput.blobData, 0, nil);
    // читаем содержимое потока и пишем его в BLOB посегментно
    while xStreamSize <> 0 do
    begin
      if xStreamSize > xBufferSize then
        xReadLength := xBufferSize
      else
        xReadLength := xStreamSize;
      xStream.ReadBuffer(buffer, xReadLength);

      blob.putSegment(AStatus, xReadLength, @buffer[0]);

      Dec(xStreamSize, xReadLength);
    end;
    // закрываем BLOB
    // метод close в случае успеха совобождает интерфейс IBlob
    // поэтому последующий вызов release не нужен
    blob.close(AStatus);
    blob := nil;
  finally
    if Assigned(blob) then
      blob.release;
    trx.release;
    att.release;
    xStream.Free;
  end;
end;

unit FbBlob;

interface

uses Classes, SysUtils, Firebird;

const
  MAX_SEGMENT_SIZE = $7FFF;

type
  TFbBlobHelper = class helper for IBlob
    { Загружает в BLOB содержимое потока

      @param(AStatus Статус вектор)
      @param(AStream Поток)
    }
    procedure LoadFromStream(AStatus: IStatus; AStream: TStream);
    { Загружает в поток содержимое BLOB

      @param(AStatus Статус вектор)
      @param(AStream Поток)
    }
    procedure SaveToStream(AStatus: IStatus; AStream: TStream);
  end;

implementation

uses Math;

procedure TFbBlobHelper.LoadFromStream(AStatus: IStatus; AStream: TStream);
var
  xStreamSize: Integer;
  xReadLength: Integer;
  xBuffer: array [0 .. MAX_SEGMENT_SIZE] of Byte;
begin
  xStreamSize := AStream.Size;
  AStream.Position := 0;
  while xStreamSize <> 0 do
  begin
    xReadLength := Min(xStreamSize, MAX_SEGMENT_SIZE);
    AStream.ReadBuffer(xBuffer, xReadLength);
    Self.putSegment(AStatus, xReadLength, @xBuffer[0]);
    Dec(xStreamSize, xReadLength);
  end;
end;

procedure TFbBlobHelper.SaveToStream(AStatus: IStatus; AStream: TStream);
var
  xInfo: TFbBlobInfo;
  Buffer: array [0 .. MAX_SEGMENT_SIZE] of Byte;
  xBytesRead: Cardinal;
  xBufferSize: Cardinal;
begin
  AStream.Position := 0;
  xBufferSize := Min(SizeOf(Buffer), MAX_SEGMENT_SIZE);
  while True do
  begin
    case Self.getSegment(AStatus, xBufferSize, @Buffer[0], @xBytesRead) of
      IStatus.RESULT_OK:
        AStream.WriteBuffer(Buffer, xBytesRead);
      IStatus.RESULT_SEGMENT:
        AStream.WriteBuffer(Buffer, xBytesRead);
    else
      break;
    end;
  end;
end;

end.

procedure TLoadBlobFromFileFunc.execute(AStatus: IStatus;
  AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer);
var
  xInput: TInputPtr;
  xOutput: TOutputPtr;
  xFileName: string;
  xStream: TFileStream;
  att: IAttachment;
  trx: ITransaction;
  blob: IBlob;
begin
  xInput := AInMsg;
  xOutput := AOutMsg;
  if xInput.filenameNull then
  begin
    xOutput.blobDataNull := True;
    Exit;
  end;
  xOutput.blobDataNull := False;
  // получаем имя файла
  xFileName := TEncoding.UTF8.GetString(TBytes(@xInput.filename.str), 0,
    xInput.filename.len * 4);
  SetLength(xFileName, xInput.filename.len);
  // читаем файл в поток
  xStream := TFileStream.Create(xFileName, fmOpenRead or fmShareDenyNone);
  att := AContext.getAttachment(AStatus);
  trx := AContext.getTransaction(AStatus);
  blob := nil;
  try
    // создаём новый blob
    blob := att.createBlob(AStatus, trx, @xOutput.blobData, 0, nil);
    // загружаем содержимое потока в BLOB
    blob.LoadFromStream(AStatus, xStream);
    // закрываем BLOB
    // метод close в случае успеха совобождает интерфейс IBlob
    // поэтому последующий вызов release не нужен
    blob.close(AStatus);
    blob := nil;
  finally
    if Assigned(blob) then
      blob.release;
    att.release;
    trx.release;
    xStream.Free;
  end;
end;