FirebirdSQL logo
 Объявления UDRСообщения 

Фабрика процедур

Фабрика внешней процедуры должна реализовать интерфейсIUdrProcedureFactory. Для упрощения просто наследуем классIUdrProcedureFactoryImpl. Для каждой внешней процедуры нужна свояфабрика. Впрочем, если фабрики не имеют специфики для создания некоторойпроцедуры, то можно написать обобщённую фабрику с помощью дженериков.Позже мы приведём пример как это сделать.

Метод dispose вызывается при уничтожении фабрики, в нём мы должныосвободить ранее выделенные ресурсы. В данном случае просто вызываемдеструктор.

Метод setup выполняется каждый раз при загрузке внешней процедуры в кешметаданных. В нём можно делать различные действия которые необходимыперед созданием экземпляра процедуры, например изменение формата длявходных и выходных сообщений. Более подробно поговорим о нём позже.

Метод newItem вызывается для создания экземпляра внешней процедуры. Вэтот метод передаётся указатель на статус вектор, контекст внешнейпроцедуры и метаданные внешней процедуры. С помощью IRoutineMetadata выможете получить формат входного и выходного сообщения, тело внешнейфункции и другие метаданные. В этом методе вы можете создавать различныеэкземпляры внешней функции в зависимости от её объявления в PSQL.Метаданные можно передать в созданный экземпляр внешней процедуры еслиэто необходимо. В нашем случае мы просто создаём экземпляр внешнейпроцедуры TSumArgsProcedure.

Фабрику процедуры, а также саму процедуру расположим в модулеSumArgsProc.

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.

Экземпляр процедуры

Внешняя процедура должна реализовать интерфейс IExternalProcedure. Дляупрощения просто наследуем класс IExternalProcedureImpl.

Метод dispose вызывается при уничтожении экземпляра процедуры, в нём мыдолжны освободить ранее выделенные ресурсы. В данном случае простовызываем деструктор.

Метод getCharSet используется для того, чтобы сообщить контексту внешней процедурынабор символов, который мы хотим использовать при работе с соединением из текущего контекста.По умолчанию соединение из текущего контекста работает в кодировке текущего подключения, что не всегда удобно.

Метод open обрабатывает непосредственно сам вызов процедуры. В этотметод передаётся указатель на статус вектор, указатель на контекствнешней процедуры, указатели на входное и выходное сообщение. Если у васвыполняемая процедура, то метод должен вернуть значение nil, в противномслучае должен вернуться экземпляр набора выходных данных для процедуры.В данном случае нам не нужно создавать экземпляр набора данных. Простопереносим логику из метода TSumArgsFunction.execute.

Хранимая процедура выбора

Теперь добавим в наш UDR модуль простую процедуру выбора. Для этогоизменим функцию регистрации firebird_udr_plugin.

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;
Note
Замечание

Не забудьте добавить в список uses модуль GenRowsProc, в котором и будетрасположена наша процедура.

Фабрика процедур полностью идентична как для случая с выполняемойхранимой процедурой. Методы экземпляра процедуры тоже идентичны, заисключением метода open, который разберём чуть подробнее.

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.

В методе open экземпляра процедуры TGenRowsProcedure проверяем первыйи второй входной аргумент на значение NULL, если один из аргументовравен NULL, то и выходной аргумент равен NULL, кроме того процедура недолжна вернуть ни одной строки при выборке через оператор SELECT,поэтому присваиваем Output.n такое значение чтобы метод TGenRowsResultSet.fetchвернул False.

Кроме того мы проверяем, чтобы первый аргумент не превышал значениевторого, в противном случае бросаем исключение. Не волнуйтесь этоисключение будет перехвачено в подсистеме UDR и преобразовано кисключению Firebird. Это одно из преимуществ новых UDR перед Legacy UDF.

Поскольку мы создаём процедуру выбора, то метод open должен возвращатьэкземпляр набора данных, который реализует интерфейс IExternalResultSet.Для упрощения унаследуем свой набор данных от классаIExternalResultSetImpl.

Метод dispose предназначен для освобождения выделенных ресурсов. В нёммы просто вызываем деструктор.

Метод fetch вызывается при извлечении очередной записи операторомSELECT. Этот метод по сути является аналогом оператора SUSPENDиспользуемый в обычных PSQL хранимых процедурах. Каждый раз когда онвызывается, в нём подготавливаются новые значения для выходногосообщения. Метод возвращает true, если запись должна быть возвращенавызывающей стороне, и false, если данных для извлечения больше нет. Внашем случае мы просто инкрементируем текущее значение выходнойпеременной до тех пор, пока оно не больше максимальной границы.

Note
Замечание

В Delphi нет поддержки оператора yeild, таким образом у вас не получитсянаписать код вроде

while(...) do {
  ...
  yield result;
}

Вы можете использовать любой класс коллекции, заполнить его в методеopen, хранимой процедуры, и затем поэлементно возвращать значения изэтой коллекции в fetch. Однако в этом случае вы лишаетесь возможностидосрочно прервать выполнение процедуры (неполный фетч в SELECT илиограничители FIRST/ROWS/FETCH в операторе SELECT.)

Регистрация триггеров

Теперь добавим в наш UDR модуль внешний триггер.

Note
Замечание

В оригинальных примерах на C++ триггер копирует запись в другую внешнююбазу данных. Я считаю, что такой пример излишне сложен для первогоознакомления с внешними триггерами. Работа с подключениями к внешнимбазам данных будет рассмотрен позже.

Вернитесь в модуль UdrInit и измените функцию firebird_udr_plugin так,чтобы она выглядела следующим образом.

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;
Note
Замечание

Не забудьте добавить в список uses модуль TestTrigger, в котором и будетрасположен наш триггер.

Фабрика триггеров

Фабрика внешнего триггера должна реализовать интерфейсIUdrTriggerFactory. Для упрощения просто наследуем классIUdrTriggerFactoryImpl. Для каждого внешнего триггера нужна свояфабрика.

Метод dispose вызывается при уничтожении фабрики, в нём мы должныосвободить ранее выделенные ресурсы. В данном случае просто вызываемдеструктор.

Метод setup выполняется каждый раз при загрузке внешнего триггера в кешметаданных. В нём можно делать различные действия которые необходимыперед созданием экземпляра триггера, например для изменения форматасообщений для полей таблицы. Более подробно поговорим о нём позже.

Метод newItem вызывается для создания экземпляра внешнего триггера. Вэтот метод передаётся указатель на статус вектор, контекст внешнеготриггера и метаданные внешнего триггера. С помощью IRoutineMetadata выможете получить формат сообщения для новых и старых значений полей, теловнешнего триггера и другие метаданные. В этом методе вы можете создаватьразличные экземпляры внешнего триггера в зависимости от его объявления вPSQL. Метаданные можно передать в созданный экземпляр внешнего триггераесли это необходимо. В нашем случае мы просто создаём экземпляр внешнеготриггера TMyTrigger.

Фабрику триггера, а также сам триггер расположим в модуле TestTrigger.

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.

Сообщения

Под сообщением в UDR понимается область памяти фиксированного размерадля передачи в процедуру или функцию входных аргументов, или возвратавыходных аргументов. Для внешних триггеров на события записи таблицысообщения используются для получения и возврата данных в NEW и OLD.

Для доступа к отдельным переменным или полям таблицы, необходимо знатькак минимум тип этой переменной, и смещение от начала буфера сообщений.Как уже упоминалось ранее для этого существует два способа:

  • преобразование указателя на буфер сообщения к указателю на статическуюструктуру (в Delphi это запись, т.е. record);

  • получение смещений с помощью экземпляра класса реализующего интерфейсIMessageMetadata, и чтение/запись из буфера данных, размеромсоответствующим типу переменной или поля.

Первый способ является наиболее быстрым, второй — более гибким, так какв ряде случаев позволяет изменять типы и размеры для входных и выходныхпеременных или полей таблицы без перекомпиляции динамической библиотекисодержащей UDR.

Работа с буфером сообщения с использованием структуры

Как говорилось выше мы можем работать с буфером сообщений черезуказатель на структуру. Такая структура выглядит следующим образом:

Синтаксис
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;

Типы членов данных должны соответствовать типам входных/выходныхпеременных или полей (для триггеров). Null-индикатор должен быть послекаждой переменной/поля, даже если у них есть ограничение NOT NULL.Null-индикатор занимает 2 байта. Значение -1 обозначает чтопеременная/поле имеют значение NULL. Поскольку на данный момент вNULL-индикатор пишется только признак NULL, то удобно отразить его на2-х байтный логический тип. Типы данных SQL отображаются в структуреследующим образом:

Table 1. Отображение типов SQL на типы Delphi
SQL тип Delphi тип Замечание

BOOLEAN

Boolean, ByteBool

SMALLINT

Smallint

INTEGER

Integer

BIGINT

Int64

INT128

FB_I128

Доступно начиная с Firebird 4.0.

FLOAT

Single

DOUBLE PRECISION

Double

DECFLOAT(16)

FB_DEC16

Доступно начиная с Firebird 4.0.

DECFLOAT(34)

FB_DEC34

Доступно начиная с Firebird 4.0.

NUMERIC(N, M)

Тип данных зависит от точности и диалекта:

  • 1-4 — Smallint;

  • 5-9 — Integer;

  • 10-18 (3 диалект) — Int64;

  • 10-15 (1 диалект) — Double;

  • 19-38 - FB_I128 (начиная с Firebird 4.0).

В качестве значения в сообщение будет передано число умноженное на10M.

DECIMAL(N, M)

Тип данных зависит от точности и диалекта:

  • 1-4 — Integer;

  • 5-9 — Integer;

  • 10-18 (3 диалект) — Int64;

  • 10-15 (1 диалект) — Double;

  • 19-38 - FB_I128 (начиная с Firebird 4.0).

В качестве значения в сообщение будет передано число умноженное на10M.

CHAR(N)

array[0 .. M] of AnsiChar

M вычисляется по формуле M = N * BytesPerChar - 1, гдеBytesPerChar - количество байт на символ, зависит от кодировкипеременной/поля. Например, для UTF-8 - это 4 байт/символ, для WIN1251 - 1байт/символ.

VARCHAR(N)

 
record
  Length: Smallint;
  Data: array[0 .. M] of AnsiChar;
end

M вычисляется по формуле M = N * BytesPerChar - 1, гдеBytesPerChar - количество байт на символ, зависит от кодировкипеременной/поля. Например, для UTF-8 - это 4 байт/символ, для WIN1251 - 1байт/символ. В Length передаётся реальная длина строки в символах.

DATE

ISC_DATE

TIME

ISC_TIME

TIME WITH TIME ZONE

ISC_TIME_TZ

Доступно начиная с Firebird 4.0.

TIMESTAMP

ISC_TIMESTAMP

TIMESTAMP WITH TIME ZONE

ISC_TIMESTAMP_TZ

Доступно начиная с Firebird 4.0.

BLOB

ISC_QUAD

Содержимое BLOB никогда не передаётсянепосредственно, вместо него передаётся BlobId. Как работать с типомBLOB будет рассказано в главе Работа с типом BLOB.

Теперь рассмотрим несколько примеров того как составлять структурысообщений по декларациям процедур, функций или триггеров.

Предположим у нас есть внешняя функция объявленная следующим образом:

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;

Если та же самая функция определена с другими типами (в 3 диалекте):

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;

Работа с буфером сообщений с помощью IMessageMetadata

Как было описано выше с буфером сообщений можно работать сиспользованием экземпляра объекта реализующего интерфейсIMessageMetadata. Этот интерфейс позволяет узнать о переменной/полеследующие сведения:

  • имя переменной/поля;

  • тип данных;

  • набор символов для строковых данных;

  • подтип для типа данных BLOB;

  • размер буфера в байтах под переменную/поле;

  • может ли переменная/поле принимать значение NULL;

  • смещение в буфере сообщений для данных;

  • смещение в буфере сообщений для NULL-индикатора.

Методы интерфейса IMessageMetadata

  1. getCount

    unsigned getCount(StatusType* status)

    возвращает количество полей/параметров в сообщении. Во всех вызовах,содержащих индексный параметр, это значение должно быть: 0 <= index < getCount().

  2. getField

    const char* getField(StatusType* status, unsigned index)

    возвращает имя поля.

  3. getRelation

    const char* getRelation(StatusType* status, unsigned index)

    возвращает имя отношения (из которого выбрано данное поле).

  4. getOwner

    const char* getOwner(StatusType* status, unsigned index)

    возвращает имя владельца отношения.

  5. getAlias

    const char* getAlias(StatusType* status, unsigned index)

    возвращает псевдоним поля.

  6. getType

    unsigned getType(StatusType* status, unsigned index)

    возвращает SQL тип поля.

  7. isNullable

    FB_BOOLEAN isNullable(StatusType* status, unsigned index)

    возвращает true, если поле может принимать значение NULL.

  8. getSubType

    int getSubType(StatusType* status, unsigned index)

    возвращает подтип поля BLOB (0 - двоичный, 1 - текст и т. д.).

  9. getLength

    unsigned getLength(StatusType* status, unsigned index)

    возвращает максимальную длину поля в байтах.

  10. getScale

    int getScale(StatusType* status, unsigned index)

    возвращает масштаб для числового поля.

  11. getCharSet

    unsigned getCharSet(StatusType* status, unsigned index)

    возвращает набор символов для символьных полей и текстового BLOB.

  12. getOffset

    unsigned getOffset(StatusType* status, unsigned index)

    возвращает смещение данных поля в буфере сообщений (используйте его длядоступа к данным в буфере сообщений).

  13. getNullOffset

    unsigned getNullOffset(StatusType* status, unsigned index)

    возвращает смещение NULL индикатора для поля в буфере сообщений.

  14. getBuilder

    IMetadataBuilder* getBuilder(StatusType* status)

    возвращает интерфейс IMetadataBuilder, инициализированный метаданнымиэтого сообщения.

  15. getMessageLength

    unsigned getMessageLength(StatusType* status)

    возвращает длину буфера сообщения (используйте его для выделения памятипод буфер).

Получение и использование IMessageMetadata

Экземпляры объектов реализующих интерфейс IMessageMetadata для входных ивыходных переменных можно получить из интерфейса IRoutineMetadata. Он непередаётся непосредственно в экземпляр процедуры, функции или триггера.Это необходимо делать явно в фабрике соответствующего типа. Например:

  // Фабрика для создания экземпляра внешней функции 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)
  private
    FMetadata: IRoutineMetadata;
  public
    property Metadata: IRoutineMetadata read FMetadata write FMetadata;
  public
    // Вызывается при уничтожении экземпляра функции
    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;
........................

{ TSumArgsFunctionFactory }

procedure TSumArgsFunctionFactory.dispose;
begin
  Destroy;
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;

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

end;

Экземпляры IMessageMetadata для входных и выходных переменных можнополучить с помощью методов getInputMetadata и getOutputMetadata изIRoutineMetadata. Метаданные для полей таблицы, на которую написантриггер, можно получить с помощью метода getTriggerMetadata.

Important
Важно

Обратите внимание, жизненный цикл объектов интерфейса IMessageMetadataуправляется с помощью подсчёта ссылок. Он наследует интерфейсIReferenceCounted. Методы getInputMetadata и getOutputMetadataувеличивают счётчик ссылок на 1 для возвращаемых объектов, поэтому послеокончания использования этих объектов необходимо уменьшить счётчикссылок для переменных xInputMetadata и xOutputMetadata вызывав методrelease.

Для получения значения соответствующего входного аргумента намнеобходимо воспользоваться адресной арифметикой. Для этого получаемсмещение из IMessageMetadata с помощью метода getOffset и прибавляем кадресу буфера для входного сообщения. После чего полученный результатприводим к соответствующему типизированному указателю. Примерна такая жесхема работы для получения null индикаторов аргументов, только дляполучения смещений используется метод getNullOffset.

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

procedure TSumArgsFunction.execute(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer);
var
  n1, n2, n3: Integer;
  n1Null, n2Null, n3Null: WordBool;
  Result: Integer;
  resultNull: WordBool;
  xInputMetadata, xOutputMetadata: IMessageMetadata;
begin
  xInputMetadata := FMetadata.getInputMetadata(AStatus);
  xOutputMetadata := FMetadata.getOutputMetadata(AStatus);
  try
    // получаем значения входных аргументов по их смещениям
    n1 := PInteger(PByte(AInMsg) + xInputMetadata.getOffset(AStatus, 0))^;
    n2 := PInteger(PByte(AInMsg) + xInputMetadata.getOffset(AStatus, 1))^;
    n3 := PInteger(PByte(AInMsg) + xInputMetadata.getOffset(AStatus, 2))^;
    // получаем значения null-индикаторов входных аргументов по их смещениям
    n1Null := PWordBool(PByte(AInMsg) +
      xInputMetadata.getNullOffset(AStatus, 0))^;
    n2Null := PWordBool(PByte(AInMsg) +
      xInputMetadata.getNullOffset(AStatus, 1))^;
    n3Null := PWordBool(PByte(AInMsg) +
      xInputMetadata.getNullOffset(AStatus, 2))^;
    // по умолчанию выходной аргемент = NULL, а потому выставляем ему nullFlag
    resultNull := True;
    Result := 0;
    // если один из аргументов NULL значит и результат NULL
    // в противном случае считаем сумму аргументов
    if not(n1Null or n2Null or n3Null) then
    begin
      Result := n1 + n2 + n3;
      // раз есть результат, то сбрасываем NULL флаг
      resultNull := False;
    end;
    PWordBool(PByte(AInMsg) + xOutputMetadata.getNullOffset(AStatus, 0))^ :=
      resultNull;
    PInteger(PByte(AInMsg) + xOutputMetadata.getOffset(AStatus, 0))^ := Result;
  finally
    xInputMetadata.release;
    xOutputMetadata.release;
  end;
end;
Note
Замечание

В главе Контекст соединения и транзакции приведёнбольшой пример для работы с различными SQL типами с использованиеминтерфейса IMessageMetadata.

Фабрики

Вы уже сталкивались с фабриками ранее. Настало время рассмотреть ихболее подробно.

Фабрики предназначены для создания экземпляров процедур, функций илитриггеров. Класс фабрики должен быть наследником одного из интерфейсовIUdrProcedureFactory, IUdrFunctionFactory или IUdrTriggerFactory взависимости от типа UDR. Их экземпляры должны быть зарегистрированы вкачестве точки входа UDR в функции firebird_udr_plugin.

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

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

В данном примере класс TSumArgsFunctionFactory наследует интерфейсIUdrFunctionFactory, TGenRowsFactory наследует интерфейсIUdrProcedureFactory, а TMyTriggerFactory наследует интерфейсIUdrTriggerFactory.

Экземпляры фабрик создаются и привязываются к точкам входа в моментпервой загрузки внешней процедуры, функции или триггера. Это происходитодин раз при создании каждого процесса Firebird. Таким образом, дляархитектуры SuperServer для всех соединений будет ровно один экземплярфабрики связанный с каждой точкой входа, для Classic это количествоэкземпляров будет умножено на количество соединений.

При написании классов фабрик вам необходимо реализовать методы setup иnewItem из интерфейсов IUdrProcedureFactory, IUdrFunctionFactory илиIUdrTriggerFactory.

  IUdrFunctionFactory = class(IDisposable)
    const VERSION = 3;

    procedure setup(status: IStatus; context: IExternalContext;
      metadata: IRoutineMetadata; inBuilder: IMetadataBuilder;
        outBuilder: IMetadataBuilder);

    function newItem(status: IStatus; context: IExternalContext;
      metadata: IRoutineMetadata): IExternalFunction;
  end;

  IUdrProcedureFactory = class(IDisposable)
    const VERSION = 3;

    procedure setup(status: IStatus; context: IExternalContext;
      metadata: IRoutineMetadata; inBuilder: IMetadataBuilder;
        outBuilder: IMetadataBuilder);

    function newItem(status: IStatus; context: IExternalContext;
      metadata: IRoutineMetadata): IExternalProcedure;
  end;

  IUdrTriggerFactory = class(IDisposable)
    const VERSION = 3;

    procedure setup(status: IStatus; context: IExternalContext;
      metadata: IRoutineMetadata; fieldsBuilder: IMetadataBuilder);

    function newItem(status: IStatus; context: IExternalContext;
      metadata: IRoutineMetadata): IExternalTrigger;
  end;

Кроме того, поскольку эти интерфейсы наследуют интерфейс IDisposable, тонеобходимо так же реализовать метод dispose. Это обозначает что Firebirdсам выгрузит фабрику, когда это будет необходимо. В методе disposeнеобходимо разместить код, который освобождает ресурсы, при уничтоженииэкземпляра фабрики. Для упрощения реализации методов интерфейсов удобновоспользоваться классами IUdrProcedureFactoryImpl,IUdrFunctionFactoryImpl, IUdrTriggerFactoryImpl. Рассмотрим каждыйиз методов более подробно.

Метод newItem

Метод newItem вызывается для создания экземпляра внешней процедуры,функции или триггера. Создание экземпляров UDR происходит в момент еёзагрузки в кэш метаданных, т.е. при первом вызове процедуры, функции илитриггера. В настоящий момент кэш метаданных раздельный для каждогосоединения для всех архитектур сервера.

Кэш метаданных процедур и функция связан с их именами в базе данных.Например, две внешние функции с разными именами, но одинаковыми точкамивхода, будут разными экземплярами IUdrFunctionFactory. Точка входасостоит из имени внешнего модуля и имени под которым зарегистрированафабрика. Как это можно использовать покажем позже.

В метод newItem передаётся указатель на статус вектор, контекствыполнения UDR и метаданные UDR.

В простейшем случае реализация этого метода тривиальна

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

С помощью IRoutineMetadata вы можете получить формат входного ивыходного сообщения, тело UDR и другие метаданные. Метаданные можнопередать в созданный экземпляр UDR. В этом случае в экземпляр классареализующего вашу UDR необходимо добавить поле для хранения метаданных.

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

В этом случае реализация метода newItem выглядит следующим образом:

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

Создание экземпляров UDR в зависимости от их объявления

В методе newItem вы можете создавать различные экземпляры внешнейпроцедуры или функции в зависимости от её объявления в PSQL. Для этогоможно использовать информацию полученную из IMessageMetadata.

Допустим мы хотим реализовать PSQL пакет с однотипным набором внешнихфункций для возведения числа в квадрат под различные типы данных иединой точкой входа.

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

Для упрощения работы с IMessageMetadata и буферами можно написатьудобную обёртку или попробовать совместно использовать IMessageMetadataи структуры для отображения сообщений. Здесь мы покажем использованиевторого способа.

Реализация такой идея достаточно проста: в фабрике функций мы будемсоздавать различные экземпляры функций в зависимости от типа входногоаргумента. В современных версиях Delphi вы можете использовать дженерикидля обобщения кода.

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

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

Метод setup

Метод setup позволяет изменить типы входных параметров и выходныхпеременных для внешних процедур и функций или полей для триггеров. Дляэтого используется интерфейс IMetadataBuilder, который позволяетпостроить входные и выходные сообщения с заданными типами, размерностьюи набором символов. Входные сообщения будут перестроены в форматзаданный в методе setup, а выходные перестроены из формата заданного вметоде setup в формат сообщения определенного в DLL процедуры, функцииили триггера. Типы полей или параметров должны быть совместимы дляпреобразования.

Данный метод позволяет упростить создание обобщённых для разных типовпараметров процедур и функций путём их приведения в наиболее общий тип.Более сложный и полезный пример будет рассмотрен позже, а пока немногоизменим уже существующий пример внешней функции SumArgs.

Наша функция будет работать с сообщениями, которые описываются следующейструктурой

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;

Теперь создадим фабрику функций, в методе setup зададим форматсообщений, которые соответствуют выше приведённым структурам.

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

Теперь даже если мы объявим функции следующим образом, она всё равносохранит свою работоспособность, поскольку входные и выходные сообщениябудут преобразованы к тому формату, что мы задали в методе setup.

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

Обобщённые фабрики

В процессе разработки UDR необходимо под каждую внешнюю процедуру,функцию или триггер писать свою фабрику создающую экземпляр это UDR. Этузадачу можно упростить написав обобщённые фабрики с помощью такназываемых дженериков. Они доступны начиная с Delphi 2009, в Free Pascalначиная с версии FPC 2.2.

Note
Замечание

В Free Pascal синтаксис создания обобщённых типов отличается от Delphi.Начиная с версии FPC 2.6.0 декларируется совместимый с Delphi синтаксис.

Рассмотрим два основных случая для которых будут написаны обобщённыефабрики:

  • экземплярам внешних процедур, функций и триггеров не требуются какие-либосведения о метаданных, не нужны специальные действия в логикесоздания экземпляров UDR, для работы с сообщениями используютсяфиксированные структуры;

  • экземплярам внешних процедур, функций и триггеров требуются сведения ометаданных, не нужны специальные действия в логике создания экземпляровUDR, для работы с сообщениями используются экземпляры интерфейсовIMessageMetadata.

В первом случае достаточно просто создавать нужный экземпляр класса вметоде newItem без дополнительных действий. Для этого воспользуемсяограничением конструктора в классах потомках классовIUdrFunctionFactoryImpl, IUdrProcedureFactoryImpl,IUdrTriggerFactoryImpl. Объявления таких фабрик выглядит следующимобразом:

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;

В секции реализации тело метода setup можно оставить пустым, в нихничего не делается, в теле метода dispose просто вызвать деструктор. А втеле метода newItem необходимо просто вызвать конструктор по умолчаниюдля подстановочного типа T.

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;

Теперь для случая 1 можно не писать фабрики под каждую процедуру,функцию или триггер. Вместо этого регистрировать их с помощью обобщённыхфабрик следующим образом:

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;

Второй случай более сложный. По умолчанию сведения о метаданных непередаются в экземпляры процедур, функций и триггеров. Однако метаданныхпередаются в качестве параметра в методе newItem фабрик. Метаданные UDRимеют тип IRoutineMetadata, жизненный цикл которого контролируется самимдвижком Firebird, поэтому его можно смело передавать в экземпляры UDR.Из него можно получить экземпляры интерфейсов для входного и выходногосообщения, метаданные и тип триггера, имя UDR, пакета, точки входа итело UDR. Сами классы для реализаций внешних процедур, функций итриггеров не имеют полей для хранения метаданных, поэтому нам придётсясделать своих наследников.

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;

В этом случае ваши собственные хранимые процедуры, функции и триггерыдолжны быть унаследованы от новых классов с метаданными.

Теперь объявим фабрики, которые будут создавать UDR и инициализироватьметаданные.

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;

Реализация метода newItem тривиальна и похожа на первый случай, заисключением того, что необходимо инициализировать поле с метаданными.

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;

Готовый модуль с обобщёнными фабриками можно скачать по адресуhttps://github.com/sim1984/udr-book/blob/master/examples/Common/UdrFactories.pas.

Работа с типом BLOB

В отличие от других типов данных BLOB передаются по ссылке(идентификатор BLOB), а не по значению. Это логично, BLOB могут бытьогромных размеров, а потому поместить их в буфер фиксированный шириныневозможно. Вместо этого в буфер сообщений помещается так называемыйBLOB идентификатор, а работа с данными типа BLOB осуществляются черезинтерфейс IBlob.

Ещё одной важной особенностью типа BLOB является то, что BLOB являетсянеизменяемым типом, вы не можете изменить содержимое BLOB с заданнымидентификатором, вместо этого нужно создать BLOB с новым содержимым иидентификатором.

Поскольку размер данных типа BLOB может быть очень большим, то данныеBLOB читаются и пишутся порциями (сегментами), максимальный размерсегмента равен 64 Кб. Чтение сегмента осуществляется методом getSegmentинтерфейса IBlob. Запись сегмента осуществляется методом putSegmentинтерфейса IBlob.

Чтение данных из BLOB

В качестве примера чтения BLOB рассмотрим процедуру, которая разбиваетстроку по разделителю (обратная процедура для встроенной агрегатнойфункции LIST). Она объявлена следующим образом

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;

Как видите вместо значения BLOB передаётся идентификатор BLOB, которыйописывается структурой ISC_QUAD.

Теперь опишем класс процедуры и возвращаемого набора данных:

  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;

Дополнительные методы SaveBlobToStream и readBlob предназначены длячтения BLOB. Первая читает BLOB в поток, вторая — основана на первой ивыполняет преобразование прочтённого потока в строку Delphi. В наборданных передаётся массив строк OutputArray и счётчик возвращённыхзаписей Counter.

В методе open читается BLOB и преобразуется в строку. Полученная строкаразбивается по разделителю с помощью встроенного метода Split из хелперадля строк. Полученный массив строк передаётся в результирующий наборданных.

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;
Note
Замечание

Тип перечисление TFBCharSet не входит в Firebird.pas. Он написан мноюдля облегчения работы с кодировками Firebird. В данном случае считаемчто все наши строки приходят в кодировке UTF-8.

Теперь опишем процедуру чтения данных из BLOB в поток. Для того чтобыпрочитать данные из BLOB, его необходимо его открыть. Это можно сделатьвызвав метод openBlob интерфейса IAttachment. Поскольку мы читаем BLOBиз своей базы данных, то будем открывать его в контексте текущегоподключения. Контекст текущего подключения и контекст текущей транзакциимы можем получить из контекста внешней процедуры, функции или триггера(интерфейс IExternalContext).

BLOB читается порциями (сегментами), максимальный размер сегмента равен64 Кб. Чтение сегмента осуществляется методом getSegment интерфейсаIBlob.

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;
Note
Замечание

Обратите внимание, интерфейсы IAttachment, ITransaction и IBlobнаследуют интерфейс IReferenceCounted, а значит это объекты с подсчётомссылок. Методы возвращающие объекты этих интерфейсов устанавливаютсчётчик ссылок в 1. По завершению работы с такими объектами нужноуменьшить счётчик ссылок с помощью метода release.
Important
Важно

Метод close интерфейса IBlob в случае успешного выполнения освобождает интерфейс,поэтому нет необходимости вызывать метод release.

В примере переменной blob присваивается значение nil. Далее в секции finally, проверяется инициализирован ли указатель на интерфейс IBlob, и только если выполнение было завершено ранее вызова blob.close(AStatus) или если этот вызов завершился ошибкой, вызывается IBlob.release.

На основе метода SaveBlobToStream написана процедура чтения BLOB встроку:

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;
Note
Замечание

К сожалению Free Pascal не обеспечивает полную обратную совместимость сDelphi для класса TStringStream. В версии для FPC нельзя указатькодировку с которой будет работать поток, а потому приходитсяобрабатывать для него преобразование в строку особым образом.

Метод fetch выходного набора данных извлекает из массива строк элемент синдексом Counter и увеличивает его до тех пор, пока не будет извлечёнпоследний элемент массива. Каждая извлечённая строка преобразуется кцелому. Если это невозможно сделать, то будет возбуждено исключение скодом isc_convert_error.

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;
Note
Замечание

На самом деле обработка любых ошибок кроме isc_random не очень удобна,для упрощения можно написать свою обёртку.

Работоспособность процедуры можно проверить следующим образом:

SELECT ids.ID
FROM SPLIT((SELECT LIST(ID) FROM MYTABLE), ',') ids
Note
Замечание

Главным недостатком такой реализации состоит в том, что BLOB будетвсегда прочитан целиком, даже если вы хотите досрочно прерватьизвлечение записей из процедуры. При желании вы можете изменить кодпроцедуры таким образом, чтобы разбиение на подстроки осуществлялосьболее маленькими порциями. Для этого чтение этих порций необходимоосуществлять в методе fetch по мере извлечения строк результата.

Запись данных в BLOB

В качестве примера записи BLOB рассмотрим функцию читающую содержимоеBLOB из файла.

Note
Замечание

Этот пример является адаптированной версией UDF функций для чтения изаписи BLOB из/в файл. Оригинальная UDF доступна по адресуblobsaveload.zip

Утилиты для чтения и записи BLOB из/в файл оформлены в виде пакета

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;

В данном случае приведём пример только для функции считывающий BLOB изфайла, полный пример UDR вы можете скачать по адресу06.BlobSaveLoad.Интерфейсная часть модуля с описанием функции LoadBlobFromFile выглядитследующим образом:

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;

Приведём только реализацию основного метода execute классаTLoadBlobFromFile, остальные методы классов элементарны.

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;

Первым делом необходимо создать новый BLOB и привязать его в blobIdвыхода с помощью метода createBlob интерфейса IAttachment. Поскольку мыпишем пусть и временный BLOB для своей базы данных, то будем создаватьего в контексте текущего подключения. Контекст текущего подключения иконтекст текущей транзакции мы можем получить из контекста внешнейпроцедуры, функции или триггера (интерфейс IExternalContext).

Так же как и в случае с чтением данных из BLOB, запись ведётся посегментно с помощью метода putSegment интерфейса IBlob до тех пор, покаданные в потоке файла не закончатся. По завершению записи данных в BLOBнеобходимо закрыть его с помощью метода close.

Important
Важно

Метод close интерфейса IBlob в случае успешного выполнения освобождает интерфейс,поэтому нет необходимости вызывать метод release.

Хелпер для работы с типом BLOB

В выше описанных примерах мы использовали сохранение содержимого BLOB впоток, а также загрузку содержимого BLOB в поток. Это довольно частаяоперация при работе с типом BLOB, поэтому было бы хорошо написатьспециальный набор утилит для повторного использования кода.

Современные версии Delphi и Free Pascal позволяют расширять существующиеклассы и типы без наследования с помощью так называемых хэлперов.Добавим методы в интерфейс IBlob для сохранения и загрузки содержимогопотока из/в Blob.

Создадим специальный модуль FbBlob, где будет размещён наш хэлпер.

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.

Теперь вы можете значительно упростить операции с типом BLOB, напримервышеприведенная функция сохранения BLOB в файл может быть переписанатак:

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;

Контекст соединения и транзакции

Если ваша внешняя процедура, функция или триггер должна получать данныеиз собственной базы данных не через входные аргументы, а например череззапрос, то вам потребуется получать контекст текущего соединения и/илитранзакции. Кроме того, контекст соединения и транзакции необходим есливы будете работать с типом BLOB.

Контекст выполнения текущей процедуры, функции или триггера передаётся вкачестве параметра с типом IExternalContext в метод execute триггера илифункции, или в метод open процедуры. Интерфейс IExternalContextпозволяет получить текущее соединение с помощью метода getAttachment, итекущую транзакцию с помощью метода getTransaction. Это даёт большуюгибкость вашим UDR, например вы можете выполнять запросы к текущей базеданных с сохранением текущего сессионного окружения, в той же транзакцииили в новой транзакции, созданной с помощью метода startTransactionинтерфейса IExternalContext. В последнем случае запрос будет выполнентак как будто он выполняется в автономной транзакции. Кроме того, выможете выполнить запрос к внешней базе данных с использованиемтранзакции присоединённой к текущей транзакции, т.е. транзакции сдвухфазным подтверждением (2PC).

В качестве примера работы с контекстом выполнения функции напишемфункцию, которая будет сериализовать результат выполнения SELECT запросав формате JSON. Она объявлена следующим образом:

create function GetJson (
    sql_text blob sub_type text character set utf8,
    sql_dialect smallint not null default 3
)
returns returns blob sub_type text character set utf8
external name 'JsonUtils!getJson'
engine udr;

Поскольку мы позволяем выполнять произвольный SQL запрос, то мы не знаемзаранее формат выходных полей, и мы не сможем использовать структуру сфиксированными полями. В этом случае нам придётся работать с интерфейсомIMessageMetadata. Мы уже сталкивались с ним ранее, но на этот разпридётся работать с ним более основательно, поскольку мы должныобрабатывать все существующие типы Firebird.

Note
Замечание

В JSON можно закодировать практически любые типы данных кроме бинарных.Для кодирования типов CHAR, VARCHAR с OCTETS NONE и BLOB SUB_TYPE BINARYбудем кодировать бинарное содержимое с помощью кодирования base64,которое уже можно размещать в JSON.

Зарегистрируем фабрику нашей функции:

function firebird_udr_plugin(AStatus: IStatus; AUnloadFlagLocal: BooleanPtr;
  AUdrPlugin: IUdrPlugin): BooleanPtr; cdecl;
begin
  // регистрируем функцию
  AUdrPlugin.registerFunction(AStatus, 'getJson', TFunctionSimpleFactory<TJsonFunction>.Create());

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

Теперь объявим структуры для входного и выходного сообщения, а так жеинтерфейсную часть нашей функции:

unit JsonFunc;

{$IFDEF FPC}
{$MODE objfpc}{$H+}
{$DEFINE DEBUGFPC}
{$ENDIF}

interface

uses
  Firebird,
  UdrFactories,
  FbTypes,
  FbCharsets,
  SysUtils,
  System.NetEncoding,
  System.Json;

{ *********************************************************
 create function GetJson (
   sql_text blob sub_type text,
   sql_dialect smallint not null default 3
 ) returns blob sub_type text character set utf8
 external name 'JsonUtils!getJson'
 engine udr;
 ********************************************************* }

type

  TInput = record
    SqlText: ISC_QUAD;
    SqlNull: WordBool;
    SqlDialect: Smallint;
    SqlDialectNull: WordBool;
  end;

  InputPtr = ^TInput;

  TOutput = record
    Json: ISC_QUAD;
    NullFlag: WordBool;
  end;

  OutputPtr = ^TOutput;

  // Внешняя функция TSumArgsFunction.
  TJsonFunction = class(IExternalFunctionImpl)
  public
    procedure dispose(); override;

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

    { Преобразует целое в строку в соответствии с масштабом

      @param(AValue Значение)
      @param(Scale Масштаб)
      @returns(Строковое представление масштабированного целого)
    }
    function MakeScaleInteger(AValue: Int64; Scale: Smallint): string;

    { Добавляет закодированную запись в массив объектов Json

      @param(AStatus Статус вектор)
      @param(AContext Контекст выполнения внешней функции)
      @param(AJson Массив объектов Json)
      @param(ABuffer Буфер записи)
      @param(AMeta Метаданные курсора)
      @param(AFormatSetting Установки формата даты и времени)
    }
    procedure writeJson(AStatus: IStatus; AContext: IExternalContext;
      AJson: TJsonArray; ABuffer: PByte; AMeta: IMessageMetadata;
      AFormatSettings: TFormatSettings);

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

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

Дополнительный метод MakeScaleInteger предназначен для преобразованиямасштабируемых чисел в строку, метод writeJson кодирует очередную записьвыбранную из курсора в Json объект и добавляет его в массив такихобъектов.

В этом примере, нам потребуется реализовать метод getCharSet, чтобы указать желаемую кодировкурезультата запроса выполняемого в контексте текущего подключения внутри внешней функции. По умолчаниюэта внутренний запрос будет выполняться в кодировке текущего подключения. Однако это не совсем удобно.Мы заранее не знаем в какой кодировке будет работать клиент, поэтому придётся определять кодировку каждоговозвращаемого строкового поля и перекодировать в UTF8. Для упрощения задачи, сразу укажем контексту, что мы собираемсяработать внутри процедуры в кодировке UTF8.

procedure TJsonFunction.getCharSet(AStatus: IStatus; AContext: IExternalContext;
  AName: PAnsiChar; ANameSize: Cardinal);
begin
  // затираем предыдущую кодировку
  FillChar(AName, ANameSize, #0);
  // ставим желаемую кодировку
  StrCopy(AName, 'UTF8');
end;

Эти методы мы опишем позже, а пока приведём основной методexecute для выполнения внешней функции.

procedure TJsonFunction.execute(AStatus: IStatus; AContext: IExternalContext;
  AInMsg, AOutMsg: Pointer);
var
  xFormatSettings: TFormatSettings;
  xInput: InputPtr;
  xOutput: OutputPtr;
  att: IAttachment;
  tra: ITransaction;
  stmt: IStatement;
  inBlob, outBlob: IBlob;
  inStream: TBytesStream;
  outStream: TStringStream;
  cursorMetaData: IMessageMetadata;
  rs: IResultSet;
  msgLen: Cardinal;
  msg: Pointer;
  jsonArray: TJsonArray;
begin
  xInput := AInMsg;
  xOutput := AOutMsg;
  // если один из входных аргументов NULL, то и результат NULL
  if xInput.SqlNull or xInput.SqlDialectNull then
  begin
    xOutput.NullFlag := True;
    Exit;
  end;
  xOutput.NullFlag := False;
  // установки форматирования даты и времени
{$IFNDEF FPC}
  xFormatSettings := TFormatSettings.Create;
{$ELSE}
  xFormatSettings := DefaultFormatSettings;
{$ENDIF}
  xFormatSettings.DateSeparator := '-';
  xFormatSettings.TimeSeparator := ':';
  // создаём поток байт для чтения blob
  inStream := TBytesStream.Create(nil);
{$IFNDEF FPC}
  outStream := TStringStream.Create('', 65001);
{$ELSE}
  outStream := TStringStream.Create('');
{$ENDIF}
  jsonArray := TJsonArray.Create;
  // получение текущего соединения и транзакции
  att := AContext.getAttachment(AStatus);
  tra := AContext.getTransaction(AStatus);
  stmt := nil;
  rs := nil;
  inBlob := nil;
  outBlob := nil;
  try
    // читаем BLOB в поток
    inBlob := att.openBlob(AStatus, tra, @xInput.SqlText, 0, nil);
    inBlob.SaveToStream(AStatus, inStream);
    // метод close в случае успеха совобождает интерфейс IBlob
    // поэтому последующий вызов release не нужен
    inBlob.close(AStatus);
    inBlob := nil;
    // подготавливаем оператор
    stmt := att.prepare(AStatus, tra, inStream.Size, @inStream.Bytes[0],
      xInput.SqlDialect, IStatement.PREPARE_PREFETCH_METADATA);
    // получаем выходные метаданные курсора
    cursorMetaData := stmt.getOutputMetadata(AStatus);
    // откурываем курсор
    rs := stmt.openCursor(AStatus, tra, nil, nil, nil, 0);
    // выделяем буфер нужного размера
    msgLen := cursorMetaData.getMessageLength(AStatus);
    msg := AllocMem(msgLen);
    try
      // читаем каждую запись курсора
      while rs.fetchNext(AStatus, msg) = IStatus.RESULT_OK do
      begin
        // и пишем её в JSON
        writeJson(AStatus, AContext, jsonArray, msg, cursorMetaData,
          xFormatSettings);
      end;
    finally
      // освобождаем буфер
      FreeMem(msg);
    end;
    // закрываем курсор
    // метод close в случае успеха совобождает интерфейс IResultSet
    // поэтому последующий вызов release не нужен
    rs.close(AStatus);
    rs := nil;
    // освобождаем подготовленный запрос
    // метод free в случае успеха совобождает интерфейс IStatement
    // поэтому последующий вызов release не нужен
    stmt.free(AStatus);
    stmt := nil;
    // пишем JSON в поток
{$IFNDEF FPC}
    outStream.WriteString(jsonArray.ToJSON);
{$ELSE}
    outStream.WriteString(jsonArray.AsJSON);
{$ENDIF}
    // пишем json в выходной blob
    outBlob := att.createBlob(AStatus, tra, @xOutput.Json, 0, nil);
    outBlob.LoadFromStream(AStatus, outStream);
    // метод close в случае успеха совобождает интерфейс IBlob
    // поэтому последующий вызов release не нужен
    outBlob.close(AStatus);
    outBlob := nil;
  finally
    if Assigned(inBlob) then
      inBlob.release;
    if Assigned(stmt) then
      stmt.release;
    if Assigned(rs) then
      rs.release;
    if Assigned(outBlob) then
      outBlob.release;
    tra.release;
    att.release;
    jsonArray.Free;
    inStream.Free;
    outStream.Free;
  end;
end;

Первым делом получаем из контекста выполнения функции текущееподключение и текущую транзакцию с помощью методов getAttachment иgetTransaction интерфейса IExternalContext. Затем читаем содержимое BLOBдля получения текста SQL запроса. Запрос подготавливается с помощьюметода prepare интерфейса IAttachment. Пятым параметром передаётся SQLдиалект полученный из входного параметра нашей функции. Шестымпараметром передаём флаг IStatement.PREPARE_PREFETCH_METADATA, чтообозначает что мы хотим получить метаданные курсора вместе с результатомпрепарирования запроса. Сами выходные метаданные курсора получаем спомощью метода getOutputMetadata интерфейса IStatement.

Note
Замечание

На самом деле метод getOutputMetadata вернёт выходные метаданные в любомслучае. Флаг IStatement.PREPARE_PREFETCH_METADATA заставит получитьметаданные вместе с результатом подготовки запроса за один сетевойпакет. Поскольку мы выполняем запрос в рамках текущего соединениеникакого сетевого обмена не будет, и это не принципиально.

Далее открываем курсор с помощью метода openCursor в рамках текущейтранзакции (параметр 2). Получаем размер выходного буфера под результаткурсора с помощью метода getMessageLength интерфейса IMessageMetadata.Это позволяет выделить память под буфер, которую мы освободим сразупосле вычитки последней записи курсора.

Записи курсора читаются с помощью метода fetchNext интерфейсаIResultSet. Этот метод заполняет буфер msg значениями полей курсора ивозвращает IStatus.RESULT_OK до тех пор, пока записи курсора некончатся. Каждая прочитанная запись передаётся в метод writeJson,который добавляет объект типа TJsonObject с сериализованной записьюкурсора в массив TJsonArray.

После завершения работы с курсором, закрываем его методом close,преобразуем массив Json объектов в строку, пишем её в выходной поток,который записываем в выходной Blob.

Теперь разберём метод writeJson. Объект IUtil потребуется нам для того,чтобы получать функции для декодирования даты и времени. В этом методеактивно задействована работа с метаданными выходных полей курсора спомощью интерфейса IMessageMetadata. Первым дело создаём объект типTJsonObject в который будем записывать значения полей текущей записи.В качестве имён ключей будем использовать алиасы полей из курсора. Еслиустановлен NullFlag, то пишем значение null для ключа и переходим кследующему полю, в противном случае анализируем тип поля и пишем егозначение в Json.

function TJsonFunction.MakeScaleInteger(AValue: Int64; Scale: Smallint): string;
var
  L: Integer;
begin
  Result := AValue.ToString;
  L := Result.Length;
  if (-Scale >= L) then
    Result := '0.' + Result.PadLeft(-Scale, '0')
  else
    Result := Result.Insert(Scale + L, '.');
end;


procedure TJsonFunction.writeJson(AStatus: IStatus; AContext: IExternalContext;
  AJson: TJsonArray; ABuffer: PByte; AMeta: IMessageMetadata;
  AFormatSettings: TFormatSettings);
var
  jsonObject: TJsonObject;
  i: Integer;
  FieldName: string;
  NullFlag: WordBool;
  fieldType: Cardinal;
  pData: PByte;
  util: IUtil;
  metaLength: Integer;
  // типы
  CharBuffer: TBytes;
  charLength: Smallint;
  charset: TFBCharSet;
  StringValue: string;
  SmallintValue: Smallint;
  IntegerValue: Integer;
  BigintValue: Int64;
  Scale: Smallint;
  SingleValue: Single;
  DoubleValue: Double;
  Dec16Value: FB_DEC16Ptr;
  xDec16Buf: array[0..IDecFloat16.STRING_SIZE-1] of AnsiChar;
  xDecFloat16: IDecFloat16;
  Dec34Value: FB_DEC34Ptr;
  xDec34Buf: array[0..IDecFloat34.STRING_SIZE-1] of AnsiChar;
  xDecFloat34: IDecFloat34;
  BooleanValue: Boolean;
  DateValue: ISC_DATE;
  TimeValue: ISC_TIME;
  TimeValueTz: ISC_TIME_TZPtr;
  TimestampValue: ISC_TIMESTAMP;
  TimestampValueTz: ISC_TIMESTAMP_TZPtr;
  tzBuffer: array[0..63] of AnsiChar;
  DateTimeValue: TDateTime;
  year, month, day: Cardinal;
  hours, minutes, seconds, fractions: Cardinal;
  blobId: ISC_QUADPtr;
  BlobSubtype: Smallint;
  att: IAttachment;
  tra: ITransaction;
  blob: IBlob;
  textStream: TStringStream;
  binaryStream: TBytesStream;
{$IFDEF FPC}
  base64Stream: TBase64EncodingStream;
  xFloatJson: TJSONFloatNumber;
{$ENDIF}
  xInt128: IInt128;
  Int128Value: FB_I128Ptr;
  xInt128Buf: array[0..IInt128.STRING_SIZE-1] of AnsiChar;
begin
  // Получаем IUtil
  util := AContext.getMaster().getUtilInterface();
  // Создаём объект TJsonObject в которой будем
  // записывать значение полей записи
  jsonObject := TJsonObject.Create;
  for i := 0 to AMeta.getCount(AStatus) - 1 do
  begin
    // получаем алиас поля в запросе
    FieldName := AMeta.getAlias(AStatus, i);
    NullFlag := PWordBool(ABuffer + AMeta.getNullOffset(AStatus, i))^;
    if NullFlag then
    begin
      // если NULL пишем его в JSON и переходим к следующему полю
{$IFNDEF FPC}
      jsonObject.AddPair(FieldName, TJsonNull.Create);
{$ELSE}
      jsonObject.Add(FieldName, TJsonNull.Create);
{$ENDIF}
      continue;
    end;
    // получаем указатель на данные поля
    pData := ABuffer + AMeta.getOffset(AStatus, i);
    // аналог AMeta->getType(AStatus, i) & ~1
    fieldType := AMeta.getType(AStatus, i) and not 1;
    case fieldType of
      // VARCHAR
      SQL_VARYING:
        begin
          // размер буфера для VARCHAR
          metaLength := AMeta.getLength(AStatus, i);
          SetLength(CharBuffer, metaLength);
          charset := TFBCharSet(AMeta.getCharSet(AStatus, i));
          charLength := PSmallint(pData)^;
          // бинарные данные кодируем в base64
          if charset = CS_BINARY then
          begin
{$IFNDEF FPC}
            StringValue := TNetEncoding.base64.EncodeBytesToString((pData + 2),
              charLength);
{$ELSE}
            // Для VARCHAR первые 2 байта - длина в байтах
            // поэтому копируем в буфер начиная с 3 байта
            Move((pData + 2)^, CharBuffer[0], metaLength);
            StringValue := charset.GetString(CharBuffer, 0, charLength);
            StringValue := EncodeStringBase64(StringValue);
{$ENDIF}
          end
          else
          begin
            // Для VARCHAR первые 2 байта - длина в байтах
            // поэтому копируем в буфер начиная с 3 байта
            Move((pData + 2)^, CharBuffer[0], metaLength);
            StringValue := charset.GetString(CharBuffer, 0, charLength);
          end;
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // CHAR
      SQL_TEXT:
        begin
          // размер буфера для CHAR
          metaLength := AMeta.getLength(AStatus, i);
          SetLength(CharBuffer, metaLength);
          charset := TFBCharSet(AMeta.getCharSet(AStatus, i));
          Move(pData^, CharBuffer[0], metaLength);
          // бинарные данные кодируем в base64
          if charset = CS_BINARY then
          begin
{$IFNDEF FPC}
            StringValue := TNetEncoding.base64.EncodeBytesToString(pData,
              metaLength);
{$ELSE}
            StringValue := charset.GetString(CharBuffer, 0, metaLength);
            StringValue := EncodeStringBase64(StringValue);
{$ENDIF}
          end
          else
          begin
            StringValue := charset.GetString(CharBuffer, 0, metaLength);
            charLength := metaLength div charset.GetCharWidth;
            SetLength(StringValue, charLength);
          end;
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // FLOAT
      SQL_FLOAT:
        begin
          SingleValue := PSingle(pData)^;
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, TJSONNumber.Create(SingleValue));
{$ELSE}
          jsonObject.Add(FieldName, TJSONFloatNumber.Create(SingleValue));
{$ENDIF}
        end;
      // DOUBLE PRECISION
      // DECIMAL(p, s), где p = 10..15 в 1 диалекте
      SQL_DOUBLE, SQL_D_FLOAT:
        begin
          DoubleValue := PDouble(pData)^;
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, TJSONNumber.Create(DoubleValue));
{$ELSE}
          jsonObject.Add(FieldName, TJSONFloatNumber.Create(DoubleValue));
{$ENDIF}
        end;
      // DECFLOAT(16)
      SQL_DEC16:
        begin
          Dec16Value := FB_Dec16Ptr(pData);
          xDecFloat16 := util.getDecFloat16(AStatus);
          xDecFloat16.toString(AStatus, Dec16Value, IDecFloat16.STRING_SIZE, @xDec16Buf[0]);
          StringValue := AnsiString(@xDec16Buf[0]);
          StringValue := Trim(StringValue);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // DECFLOAT(34)
      SQL_DEC34:
        begin
          Dec34Value := FB_Dec34Ptr(pData);
          xDecFloat34 := util.getDecFloat34(AStatus);
          xDecFloat34.toString(AStatus, Dec34Value, IDecFloat34.STRING_SIZE, @xDec34Buf[0]);
          StringValue := AnsiString(@xDec34Buf[0]);
          StringValue := Trim(StringValue);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // INTEGER
      // NUMERIC(p, s), где p = 1..4
      SQL_SHORT:
        begin
          Scale := AMeta.getScale(AStatus, i);
          SmallintValue := PSmallint(pData)^;
          if (Scale = 0) then
          begin
{$IFNDEF FPC}
            jsonObject.AddPair(FieldName, TJSONNumber.Create(SmallintValue));
{$ELSE}
            jsonObject.Add(FieldName, SmallintValue);
{$ENDIF}
          end
          else
          begin
            StringValue := MakeScaleInteger(SmallintValue, Scale);
{$IFNDEF FPC}
            jsonObject.AddPair(FieldName, TJSONNumber.Create(StringValue));
{$ELSE}
            xFloatJson := TJSONFloatNumber.Create(0);
            xFloatJson.AsString := StringValue;
            jsonObject.Add(FieldName, xFloatJson);
{$ENDIF}
          end;
        end;
      // INTEGER
      // NUMERIC(p, s), где p = 5..9
      // DECIMAL(p, s), где p = 1..9
      SQL_LONG:
        begin
          Scale := AMeta.getScale(AStatus, i);
          IntegerValue := PInteger(pData)^;
          if (Scale = 0) then
          begin
{$IFNDEF FPC}
            jsonObject.AddPair(FieldName, TJSONNumber.Create(IntegerValue));
{$ELSE}
            jsonObject.Add(FieldName, IntegerValue);
{$ENDIF}
          end
          else
          begin
            StringValue := MakeScaleInteger(IntegerValue, Scale);
{$IFNDEF FPC}
            jsonObject.AddPair(FieldName, TJSONNumber.Create(StringValue));
{$ELSE}
            xFloatJson := TJSONFloatNumber.Create(0);
            xFloatJson.AsString := StringValue;
            jsonObject.Add(FieldName, xFloatJson);
{$ENDIF}
          end;
        end;
      // BIGINT
      // NUMERIC(p, s), где p = 10..18 в 3 диалекте
      // DECIMAL(p, s), где p = 10..18 в 3 диалекте
      SQL_INT64:
        begin
          Scale := AMeta.getScale(AStatus, i);
          BigintValue := Pint64(pData)^;
          if (Scale = 0) then
          begin
{$IFNDEF FPC}
            jsonObject.AddPair(FieldName, TJSONNumber.Create(BigintValue));
{$ELSE}
            jsonObject.Add(FieldName, BigintValue);
{$ENDIF}
          end
          else
          begin
            StringValue := MakeScaleInteger(BigintValue, Scale);
{$IFNDEF FPC}
            jsonObject.AddPair(FieldName, TJSONNumber.Create(StringValue));
{$ELSE}
            xFloatJson := TJSONFloatNumber.Create(0);
            xFloatJson.AsString := StringValue;
            jsonObject.Add(FieldName, xFloatJson);
{$ENDIF}
          end;
        end;
      SQL_INT128:
        begin
          Scale := AMeta.getScale(AStatus, i);
          Int128Value := FB_I128Ptr(pData);
          xInt128 := util.getInt128(AStatus);
          xInt128.toString(AStatus, Int128Value, Scale, IInt128.STRING_SIZE, @xInt128Buf[0]);
          StringValue := AnsiString(@xInt128Buf[0]);
          StringValue := Trim(StringValue);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // TIMESTAMP
      SQL_TIMESTAMP:
        begin
          TimestampValue := PISC_TIMESTAMP(pData)^;
          // получаем составные части даты-времени
          util.decodeDate(TimestampValue.timestamp_date, @year, @month, @day);
          util.decodeTime(TimestampValue.timestamp_time, @hours, @minutes, @seconds,
            @fractions);
          // получаем дату-время в родном типе Delphi
          DateTimeValue := EncodeDate(year, month, day) +
            EncodeTime(hours, minutes, seconds, fractions div 10);
          // форматируем дату-время по заданному формату
          StringValue := FormatDateTime('yyyy/mm/dd hh:nn:ss', DateTimeValue,
            AFormatSettings);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // TIMESTAMP WITH TIME_ZONE
      SQL_TIMESTAMP_TZ:
        begin
          TimestampValueTz := ISC_TIMESTAMP_TZPtr(pData);
          // получаем составные части даты-времени и часовой пояс
          util.decodeTimeStampTz(AStatus, TimestampValueTz, @year, @month, @day, @hours, @minutes, @seconds,
            @fractions, 64, @tzBuffer[0]);

          // получаем дату-время в родном типе Delphi
          DateTimeValue := EncodeDate(year, month, day) +
            EncodeTime(hours, minutes, seconds, fractions div 10);
          // форматируем дату-время по заданному формату + часовой пояс
          StringValue := FormatDateTime('yyyy/mm/dd hh:nn:ss', DateTimeValue,
            AFormatSettings) + ' ' + AnsiString(@tzBuffer[0]);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // DATE
      SQL_DATE:
        begin
          DateValue := PISC_DATE(pData)^;
          // получаем составные части даты
          util.decodeDate(DateValue, @year, @month, @day);
          // получаем дату в родном типе Delphi
          DateTimeValue := EncodeDate(year, month, day);
          // форматируем дату по заданному формату
          StringValue := FormatDateTime('yyyy/mm/dd', DateTimeValue,
            AFormatSettings);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // TIME
      SQL_TIME:
        begin
          TimeValue := PISC_TIME(pData)^;
          // получаем составные части времени
          util.decodeTime(TimeValue, @hours, @minutes, @seconds, @fractions);
          // получаем время в родном типе Delphi
          DateTimeValue := EncodeTime(hours, minutes, seconds,
            fractions div 10);
          // форматируем время по заданному формату
          StringValue := FormatDateTime('hh:nn:ss', DateTimeValue,
            AFormatSettings);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // TIME WITH TIME ZONE
      SQL_TIME_TZ:
        begin
          TimeValueTz := ISC_TIME_TZPtr(pData);
          // получаем составные части времени и часовой пояс
          util.decodeTimeTz(AStatus, TimeValueTz, @hours, @minutes, @seconds,
            @fractions, 64, @tzBuffer[0]);
          // получаем время в родном типе Delphi
          DateTimeValue := EncodeTime(hours, minutes, seconds,
            fractions div 10);
          // форматируем время по заданному формату + часовой пояс
          StringValue := FormatDateTime('hh:nn:ss', DateTimeValue,
            AFormatSettings) + ' ' + AnsiString(@tzBuffer[0]);
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
      // BOOLEAN
      SQL_BOOLEAN:
        begin
          BooleanValue := PBoolean(pData)^;
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, TJsonBool.Create(BooleanValue));
{$ELSE}
          jsonObject.Add(FieldName, BooleanValue);
{$ENDIF}
        end;
      // BLOB
      SQL_BLOB, SQL_QUAD:
        begin
          BlobSubtype := AMeta.getSubType(AStatus, i);
          blobId := ISC_QUADPtr(pData);
          att := AContext.getAttachment(AStatus);
          tra := AContext.getTransaction(AStatus);
          blob := att.openBlob(AStatus, tra, blobId, 0, nil);
          try
            if BlobSubtype = 1 then
            begin
              // текст
              charset := TFBCharSet(AMeta.getCharSet(AStatus, i));
              // создаём поток с заданой кодировкой
{$IFNDEF FPC}
              textStream := TStringStream.Create('', charset.GetCodePage);
              try
                blob.SaveToStream(AStatus, textStream);
                blob.close(AStatus);
                blob := nil;
                StringValue := textStream.DataString;
              finally
                textStream.Free;
              end;
{$ELSE}
              binaryStream := TBytesStream.Create(nil);
              try
                blob.SaveToStream(AStatus, binaryStream);
                blob.close(AStatus);
                blob := nil;
                StringValue := TEncoding.UTF8.GetString(binaryStream.Bytes, 0,
                  binaryStream.Size);
              finally
                binaryStream.Free;
              end;
{$ENDIF}
            end
            else
            begin
{$IFNDEF FPC}
              // все остальные подтипытипы считаем бинарными
              binaryStream := TBytesStream.Create;
              try
                blob.SaveToStream(AStatus, binaryStream);
                blob.close(AStatus);
                blob := nil;
                // кодируем строку в base64
                StringValue := TNetEncoding.base64.EncodeBytesToString
                  (binaryStream.Memory, binaryStream.Size);
              finally
                binaryStream.Free;
              end
{$ELSE}
              textStream := TStringStream.Create('');
              base64Stream := TBase64EncodingStream.Create(textStream);
              try
                blob.SaveToStream(AStatus, base64Stream);
                blob.close(AStatus);
                blob := nil;
                StringValue := textStream.DataString;
              finally
                base64Stream.Free;
                textStream.Free;
              end;
{$ENDIF}
            end;
          finally
            if Assigned(blob) then blob.release;
            if Assigned(tra) then tra.release;
            if Assigned(att) then att.release;
          end;
{$IFNDEF FPC}
          jsonObject.AddPair(FieldName, StringValue);
{$ELSE}
          jsonObject.Add(FieldName, StringValue);
{$ENDIF}
        end;
    end;
  end;
  // добавление записи в формате Json в массив
{$IFNDEF FPC}
  AJson.AddElement(jsonObject);
{$ELSE}
  AJson.Add(jsonObject);
{$ENDIF}
end;
Note
Замечание

Перечисление типа TFbType отсутствует в стандартном модулеFirebird.pas. Однако использовать числовые значения не удобно, поэтомуя написал специальный модульFbTypesв котором разместил некоторые дополнительные типы для удобства.

Перечисление TFBCharSet также отсутствует в модуле Firebird.pas. Янаписал отдельный модульFbCharsetsв котором размещено это перечисление. Кроме того, для этого типа написанспециальный хелпер, в котором размещены функции для получения названиянабора символов, кодовой страницы, размера символа в байтах, получениекласса TEncoding в нужной кодировки, а также функцию дляпреобразования массива байт в юникодную строку Delphi.

Для строк типа CHAR и VARCHAR проверяем кодировку, если это кодировкаOCTETS, то кодируем строку алгоритмом base64, в противном случаепреобразуем данные из буфера в строку Delphi. Обратите внимание, что длятипа VARCHAR первые 2 байта содержат длину строки в символах.

Типы SMALLINT, INTEGER, BIGINT могут быть как обычными целыми числами,так масштабируемыми. Масштаб числа можно получить методом getScaleинтерфейса IMessageMetadata. Если масштаб не равен 0, то требуетсяспециальная обработка числа, которая осуществляет методомMakeScaleInteger.

Типы DATE, TIME и TIMESTAMP декодируются на составные части даты ивремени с помощью методов decodeDate и decodeTime интерфейса IUtil.Используем части даты и времени для получения даты-времени в стандартномDelphi типе TDateTime.

С типом BLOB работаем через потоки Delphi. Если BLOB бинарный, тосоздаём поток типа TBytesStream. Полученный массив байт кодируем спомощью алгоритма base64. Если BLOB текстовый, то используемспециализированный поток TStringStream для строк, который позволяетучесть кодовую страницу. Кодовую страницу мы получаем из кодировки BLOBполя.

Для работы с типом данных INT128 существует специальный интерфейс IInt128. Его можно получитьвызвав метод getInt128 интерфейса IUtil.Этот тип появился в Firebird 4.0 и предназначен для точного представления очень больших чисел.Не существует непосредственного типа данных в Delphi, который мог бы работать с этим типом,поэтому просто выводим его строковое представление.

Для работы с типами DECFLOAT(16) и DECFLOAT(34) существуют специальные интерфейсы IDecFloat16 и IDecFloat34.Их можно получить вызвав методы getDecFloat16 или getDecFloat34 интерфейса IUtil.Эти типы доступны начиная с Firebird 4.0. Не существует непосредственных типов данных в Delphi, которые могли бы работать с этим типами.Эти типы можно отобразить в BCD или представить в виде строки.

Типы TIME WITH TIME ZONE и TIMESTAMP WITH TIME ZONE декодируются на составные части даты ивремени, а также наименование часового пояса, с помощью методов decodeTimeStampTz и decodeTimeTz.Используем части даты и времени для получения даты-времени в стандартномDelphi типе TDateTime. Далее преобразуем значение этого типа в строку и добавляем к ней наименование часового пояса.