{CREATE [OR ALTER] | RECREATE} FUNCTION funcname [(<inparam> [, <inparam> ...])] RETURNS <type> [COLLATE collation] [DETERMINISTIC] EXTERNAL NAME <extname> ENGINE <engine> [AS <extbody>] <inparam> ::= <param_decl> [{= |DEFAULT} <value>] <value> ::= {literal | NULL | context_var} <param_decl> ::= paramname <type> [NOT NULL] [COLLATE collation] <extname> ::= '<module name>!<routine name> [!<misc info>]' <type> ::= <datatype> | [TYPE OF] domain | TYPE OF COLUMN rel.col <datatype> ::= {SMALLINT | INT[EGER] | BIGINT} | BOOLEAN | {FLOAT | DOUBLE PRECISION} | {DATE | TIME | TIMESTAMP} | {DECIMAL | NUMERIC} [(precision [, scale])] | {CHAR | CHARACTER | CHARACTER VARYING | VARCHAR} [(size)] [CHARACTER SET charset] | {NCHAR |NATIONAL CHARACTER | NATIONAL CHAR} [VARYING] [(size)] | BLOB [SUB_TYPE {subtype_num | subtype_name}] [SEGMENT SIZE seglen] [CHARACTER SET charset] | BLOB [(seglen [, subtype_num])] 

 {CREATE [OR ALTER] | RECREATE} PROCEDURE procname [(<inparam> [, <inparam> ...])] RETURNS (<outparam> [<outparam> ...]) EXTERNAL NAME <extname> ENGINE <engine> [AS <extbody>] <inparam> ::= <param_decl> [{= | DEFAULT} <value>] <outparam> ::= <param_decl> <value> ::= {literal | NULL | context_var} <param_decl> ::= paramname <type> [NOT NULL] [COLLATE collation] <extname> ::= '<module name>!<routine name>[!<misc info>]' <type> ::= <datatype> | [TYPE OF] domain | TYPE OF COLUMN rel.col <datatype> ::= {SMALLINT | INT[EGER] | BIGINT} | BOOLEAN | {FLOAT | DOUBLE PRECISION} | {DATE | TIME | TIMESTAMP} | {DECIMAL | NUMERIC} [(precision [,scale])] | {CHAR | CHARACTER | CHARACTER VARYING | VARCHAR} [(size)] [CHARACTER SET charset] | {NCHAR | NATIONAL CHARACTER | NATIONAL CHAR} [VARYING] [(size)] | BLOB [SUB_TYPE {subtype_num | subtype_name}] [SEGMENT SIZE seglen] [CHARACTER SET charset] | BLOB [(seglen [, subtype_num])] 

 {CREATE [OR ALTER] | RECREATE} PACKAGE package_name AS BEGIN [<package_item> ...] END {CREATE | RECREATE} PACKAGE BODY package_name AS BEGIN [<package_item> ...] [<package_body_item> ...] END <package_item> ::= <function_decl>; | <procedure_decl>; <function_decl> ::= FUNCTION func_name [(<in_params>)] RETURNS <type> [COLLATE collation] [DETERMINISTIC] <procedure_decl> ::= PROCEDURE proc_name [(<in_params>)] [RETURNS (<out_params>)] <package_body_item> ::= <function_impl> | <procedure_impl> <function_impl> ::= FUNCTION func_name [(<in_impl_params>)] RETURNS <type> [COLLATE collation] [DETERMINISTIC] <routine body> <procedure_impl> ::= PROCEDURE proc_name [(<in_impl_params>)] [RETURNS (<out_params>)] <routine body> <routine body> ::= <sql routine body> | <external body reference> <sql routine body> ::= AS   [<declarations>] BEGIN [<PSQL_statements>]   END <declarations> ::= <declare_item> [<declare_item> ...] <declare_item> ::= <declare_var>; | <declare_cursor>; | <subroutine declaration>; | <subroutine implimentation> <subroutine declaration> ::= <subfunc_decl> | <subproc_decl> <subroutine implimentation> ::= <subfunc_impl> | <subproc_impl> <external body reference> ::= EXTERNAL NAME <extname> ENGINE <engine> [AS <extbody>] <extname> ::= '<module name>!<routine name>[!<misc info>]' 

 SET TERM ^; CREATE OR ALTER PACKAGE REGEXP AS BEGIN PROCEDURE preg_match( APattern VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS (Matches VARCHAR(8192)); FUNCTION preg_is_match( APattern VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS BOOLEAN; FUNCTION preg_replace( APattern VARCHAR(8192), AReplacement VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS VARCHAR(8192); PROCEDURE preg_split( APattern VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS (Lines VARCHAR(8192)); FUNCTION preg_quote( AStr VARCHAR(8192), ADelimiter CHAR(10) DEFAULT NULL) RETURNS VARCHAR(8192); END^ RECREATE PACKAGE BODY REGEXP AS BEGIN PROCEDURE preg_match( APattern VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS (Matches VARCHAR(8192)) EXTERNAL NAME 'PCRE!preg_match' ENGINE UDR; FUNCTION preg_is_match( APattern VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS BOOLEAN AS BEGIN RETURN EXISTS( SELECT * FROM preg_match(:APattern, :ASubject)); END FUNCTION preg_replace( APattern VARCHAR(8192), AReplacement VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS VARCHAR(8192) EXTERNAL NAME 'PCRE!preg_replace' ENGINE UDR; PROCEDURE preg_split( APattern VARCHAR(8192), ASubject VARCHAR(8192)) RETURNS (Lines VARCHAR(8192)) EXTERNAL NAME 'PCRE!preg_split' ENGINE UDR; FUNCTION preg_quote( AStr VARCHAR(8192), ADelimiter CHAR(10)) RETURNS VARCHAR(8192) EXTERNAL NAME 'PCRE!preg_quote' ENGINE UDR; END^ SET TERM ;^ 

 {CREATE [OR ALTER] | RECREATE} TRIGGER trigname {<relation_trigger_legacy> | <relation_trigger_sql2003> | <database_trigger> | <ddl_trigger> } <external-body> <external-body> ::= EXTERNAL NAME <extname> ENGINE <engine> [AS <extbody>] <relation_trigger_legacy> ::= FOR {tablename | viewname} [ACTIVE | INACTIVE] {BEFORE | AFTER} <mutation_list> [POSITION number] <relation_trigger_sql2003> ::= [ACTIVE | INACTIVE] {BEFORE | AFTER} <mutation_list> [POSITION number] ON {tablename | viewname} <database_trigger> ::= [ACTIVE | INACTIVE] ON db_event [POSITION number] <ddl_trigger> ::= [ACTIVE | INACTIVE] {BEFORE | AFTER} <ddl_events> [POSITION number] <mutation_list> ::= <mutation> [OR <mutation> [OR <mutation>]] <mutation> ::= INSERT | UPDATE | DELETE <db_event> ::= CONNECT | DISCONNECT | TRANSACTION START | TRANSACTION COMMIT | TRANSACTION ROLLBACK <ddl_events> ::= ANY DDL STATEMENT | <ddl_event_item> [{OR <ddl_event_item>} ...] <ddl_event_item> ::= CREATE TABLE | ALTER TABLE | DROP TABLE | CREATE PROCEDURE | ALTER PROCEDURE | DROP PROCEDURE | CREATE FUNCTION | ALTER FUNCTION | DROP FUNCTION | CREATE TRIGGER | ALTER TRIGGER | DROP TRIGGER | CREATE EXCEPTION | ALTER EXCEPTION | DROP EXCEPTION | CREATE VIEW | ALTER VIEW | DROP VIEW | CREATE DOMAIN | ALTER DOMAIN | DROP DOMAIN | CREATE ROLE | ALTER ROLE | DROP ROLE | CREATE SEQUENCE | ALTER SEQUENCE | DROP SEQUENCE | CREATE USER | ALTER USER | DROP USER | CREATE INDEX | ALTER INDEX | DROP INDEX | CREATE COLLATION | DROP COLLATION | ALTER CHARACTER SET | CREATE PACKAGE | ALTER PACKAGE | DROP PACKAGE | CREATE PACKAGE BODY | DROP PACKAGE BODY | CREATE MAPPING | ALTER MAPPING | DROP MAPPING 

يمكن تغيير المشغل الخارجي باستخدام عبارة ALTER TRIGGER.

بناء الجملة:

 ALTER TRIGGER trigname { [ACTIVE | INACTIVE] [ {BEFORE | AFTER} {<mutation_list> | <ddl_events>} | ON db_event ] [POSITION number] [<external-body>] <external-body> ::= EXTERNAL NAME <extname> ENGINE <engine> [AS <extbody>] <extname> ::= '<module name>!<routine name>[!<misc info>]' <mutation_list> ::= <mutation> [OR <mutation> [OR <mutation>]] <mutation> ::= { INSERT | UPDATE | DELETE } 

 unit SumArgsFunc; {$IFDEF FPC} {$MODE DELPHI}{$H+} {$ENDIF} interface uses Firebird; // ********************************************************* // create function sum_args ( // n1 integer, // n2 integer, // n3 integer // ) returns integer // external name 'myudr!sum_args' // engine udr; // ********************************************************* type //        TSumArgsInMsg = record n1: Integer; n1Null: WordBool; n2: Integer; n2Null: WordBool; n3: Integer; n3Null: WordBool; end; PSumArgsInMsg = ^TSumArgsInMsg; //        TSumArgsOutMsg = record result: Integer; resultNull: WordBool; end; PSumArgsOutMsg = ^TSumArgsOutMsg; //       TSumArgsFunction TSumArgsFunctionFactory = class(IUdrFunctionFactoryImpl) //     procedure dispose(); override; {          .        . @param(AStatus  ) @param(AContext    ) @param(AMetadata   ) @param(AInBuilder     ) @param(AOutBuilder     ) } procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; {      TSumArgsFunction @param(AStatus  ) @param(AContext    ) @param(AMetadata   ) @returns(  ) } function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; override; end; //   TSumArgsFunction. TSumArgsFunction = class(IExternalFunctionImpl) //      procedure dispose(); override; {      execute             .        ,   ExternalEngine::getCharSet. @param(AStatus  ) @param(AContext    ) @param(AName   ) @param(AName    ) } procedure getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); override; {    @param(AStatus  ) @param(AContext    ) @param(AInMsg    ) @param(AOutMsg    ) } procedure execute(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer); override; end; implementation { TSumArgsFunctionFactory } procedure TSumArgsFunctionFactory.dispose; begin Destroy; end; function TSumArgsFunctionFactory.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; begin Result := TSumArgsFunction.Create(); end; procedure TSumArgsFunctionFactory.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TSumArgsFunction } procedure TSumArgsFunction.dispose; begin Destroy; end; procedure TSumArgsFunction.execute(AStatus: IStatus; AContext: IExternalContext; AInMsg, AOutMsg: Pointer); var xInput: PSumArgsInMsg; xOutput: PSumArgsOutMsg; begin //         xInput := PSumArgsInMsg(AInMsg); xOutput := PSumArgsOutMsg(AOutMsg); //     NULL    NULL xOutput^.resultNull := xInput^.n1Null or xInput^.n2Null or xInput^.n3Null; xOutput^.result := xInput^.n1 + xInput^.n2 + xInput^.n3; end; procedure TSumArgsFunction.getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); begin end; end. 

 unit SumArgsProc; {$IFDEF FPC} {$MODE DELPHI}{$H+} {$ENDIF} interface uses Firebird; { ********************************************************** create procedure sp_sum_args ( n1 integer, n2 integer, n3 integer ) returns (result integer) external name 'myudr!sum_args_proc' engine udr; ********************************************************* } type //        TSumArgsInMsg = record n1: Integer; n1Null: WordBool; n2: Integer; n2Null: WordBool; n3: Integer; n3Null: WordBool; end; PSumArgsInMsg = ^TSumArgsInMsg; //        TSumArgsOutMsg = record result: Integer; resultNull: WordBool; end; PSumArgsOutMsg = ^TSumArgsOutMsg; //       TSumArgsProcedure TSumArgsProcedureFactory = class(IUdrProcedureFactoryImpl) //     procedure dispose(); override; {                  . @param(AStatus  ) @param(AContext    ) @param(AMetadata   ) @param(AInBuilder     ) @param(AOutBuilder     ) } procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; {      TSumArgsProcedure @param(AStatus  ) @param(AContext    ) @param(AMetadata   ) @returns(  ) } function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; override; end; TSumArgsProcedure = class(IExternalProcedureImpl) public //      procedure dispose(); override; {      open             .        ,   ExternalEngine::getCharSet. @param(AStatus  ) @param(AContext    ) @param(AName   ) @param(AName    ) } procedure getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); override; {    @param(AStatus  ) @param(AContext    ) @param(AInMsg    ) @param(AOutMsg    ) @returns(      nil   ) } function open(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer): IExternalResultSet; override; end; implementation { TSumArgsProcedureFactory } procedure TSumArgsProcedureFactory.dispose; begin Destroy; end; function TSumArgsProcedureFactory.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; begin Result := TSumArgsProcedure.create; end; procedure TSumArgsProcedureFactory.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TSumArgsProcedure } procedure TSumArgsProcedure.dispose; begin Destroy; end; procedure TSumArgsProcedure.getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); begin end; function TSumArgsProcedure.open(AStatus: IStatus; AContext: IExternalContext; AInMsg, AOutMsg: Pointer): IExternalResultSet; var xInput: PSumArgsInMsg; xOutput: PSumArgsOutMsg; begin Result := nil; //         xInput := PSumArgsInMsg(AInMsg); xOutput := PSumArgsOutMsg(AOutMsg); //     NULL    NULL xOutput^.resultNull := xInput^.n1Null or xInput^.n2Null or xInput^.n3Null; xOutput^.result := xInput^.n1 + xInput^.n2 + xInput^.n3; end; end. 

 unit GenRowsProc; {$IFDEF FPC} {$MODE DELPHI}{$H+} {$ENDIF} interface uses Firebird, SysUtils; type { ********************************************************** create procedure gen_rows ( start integer, finish integer ) returns (n integer) external name 'myudr!gen_rows' engine udr; ********************************************************* } TInput = record start: Integer; startNull: WordBool; finish: Integer; finishNull: WordBool; end; PInput = ^TInput; TOutput = record n: Integer; nNull: WordBool; end; POutput = ^TOutput; //       TGenRowsProcedure TGenRowsFactory = class(IUdrProcedureFactoryImpl) //     procedure dispose(); override; {          .        . @param(AStatus  ) @param(AContext    ) @param(AMetadata   ) @param(AInBuilder     ) @param(AOutBuilder     ) } procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; {      TGenRowsProcedure @param(AStatus  ) @param(AContext    ) @param(AMetadata   ) @returns(  ) } function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; override; end; //   TGenRowsProcedure. TGenRowsProcedure = class(IExternalProcedureImpl) public //      procedure dispose(); override; {      open             .        ,   ExternalEngine::getCharSet. @param(AStatus  ) @param(AContext    ) @param(AName   ) @param(AName    ) } procedure getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); override; {    @param(AStatus  ) @param(AContext    ) @param(AInMsg    ) @param(AOutMsg    ) @returns(      nil   ) } function open(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer): IExternalResultSet; override; end; //      TGenRowsProcedure TGenRowsResultSet = class(IExternalResultSetImpl) Input: PInput; Output: POutput; //       procedure dispose(); override; {      .     SUSPEND.          . @param(AStatus  ) @returns(True        , False   ) } function fetch(AStatus: IStatus): Boolean; override; end; implementation { TGenRowsFactory } procedure TGenRowsFactory.dispose; begin Destroy; end; function TGenRowsFactory.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; begin Result := TGenRowsProcedure.create; end; procedure TGenRowsFactory.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TGenRowsProcedure } procedure TGenRowsProcedure.dispose; begin Destroy; end; procedure TGenRowsProcedure.getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); begin end; function TGenRowsProcedure.open(AStatus: IStatus; AContext: IExternalContext; AInMsg, AOutMsg: Pointer): IExternalResultSet; begin //      NULL    if PInput(AInMsg).startNull or PInput(AInMsg).finishNull then begin POutput(AOutMsg).nNull := True; Result := nil; exit; end; //  if PInput(AInMsg).start > PInput(AInMsg).finish then raise Exception.Create('First parameter greater then second parameter.'); Result := TGenRowsResultSet.create; with TGenRowsResultSet(Result) do begin Input := AInMsg; Output := AOutMsg; //   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. 

 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. 

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

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

  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; 

 { 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) + 1); AInBuilder.setLength(AStatus, 0, sizeof(Int32)); AInBuilder.setType(AStatus, 1, Cardinal(SQL_LONG) + 1); AInBuilder.setLength(AStatus, 1, sizeof(Int32)); AInBuilder.setType(AStatus, 2, Cardinal(SQL_LONG) + 1); AInBuilder.setLength(AStatus, 2, sizeof(Int32)); //      AOutBuilder.setType(AStatus, 0, Cardinal(SQL_LONG) + 1); AOutBuilder.setLength(AStatus, 0, sizeof(Int32)); end; 

 unit UdrFactories; {$IFDEF FPC} {$MODE DELPHI}{$H+} {$ENDIF} interface uses SysUtils, Firebird; type //     TFunctionSimpleFactory<T: IExternalFunctionImpl, constructor> = class (IUdrFunctionFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; override; end; //     TProcedureSimpleFactory<T: IExternalProcedureImpl, constructor> = class (IUdrProcedureFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; override; end; //     TTriggerSimpleFactory<T: IExternalTriggerImpl, constructor> = class (IUdrTriggerFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalTrigger; override; end; 

 implementation { TProcedureSimpleFactory<T> } procedure TProcedureSimpleFactory<T>.dispose; begin Destroy; end; function TProcedureSimpleFactory<T>.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; begin Result := T.Create; end; procedure TProcedureSimpleFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TFunctionFactory<T> } procedure TFunctionSimpleFactory<T>.dispose; begin Destroy; end; function TFunctionSimpleFactory<T>.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; begin Result := T.Create; end; procedure TFunctionSimpleFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TTriggerSimpleFactory<T> } procedure TTriggerSimpleFactory<T>.dispose; begin Destroy; end; function TTriggerSimpleFactory<T>.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalTrigger; begin Result := T.Create; end; procedure TTriggerSimpleFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); begin end; 

 unit UdrFactories; {$IFDEF FPC} {$MODE DELPHI}{$H+} {$ENDIF} interface uses SysUtils, Firebird; type ... //      TFunctionFactory<T: TExternalFunction, constructor> = class (IUdrFunctionFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; override; end; //      TProcedureFactory<T: TExternalProcedure, constructor> = class (IUdrProcedureFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; override; end; //      TTriggerFactory<T: TExternalTrigger, constructor> = class (IUdrTriggerFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalTrigger; override; end; 

 implementation ... { TFunctionFactory<T> } procedure TFunctionFactory<T>.dispose; begin Destroy; end; function TFunctionFactory<T>.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; begin Result := T.Create; (Result as T).Metadata := AMetadata; end; procedure TFunctionFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TProcedureFactory<T> } procedure TProcedureFactory<T>.dispose; begin Destroy; end; function TProcedureFactory<T>.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalProcedure; begin Result := T.Create; (Result as T).Metadata := AMetadata; end; procedure TProcedureFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder, AOutBuilder: IMetadataBuilder); begin end; { TTriggerFactory<T> } procedure TTriggerFactory<T>.dispose; begin Destroy; end; function TTriggerFactory<T>.newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalTrigger; begin Result := T.Create; (Result as T).Metadata := AMetadata; end; procedure TTriggerFactory<T>.setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AFieldsBuilder: IMetadataBuilder); begin end; 

  TSplitProcedure = class(IExternalProcedureImpl) private procedure SaveBlobToStream(AStatus: IStatus; AContext: IExternalContext; ABlobId: ISC_QUADPtr; AStream: TStream); function readBlob(AStatus: IStatus; AContext: IExternalContext; ABlobId: ISC_QUADPtr): string; public //      procedure dispose(); override; procedure getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); override; function open(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer): IExternalResultSet; override; end; TSplitResultSet = class(IExternalResultSetImpl) {$IFDEF FPC} OutputArray: TStringArray; {$ELSE} OutputArray: TArray<string>; {$ENDIF} Counter: Integer; Output: TOutputPtr; procedure dispose(); override; function fetch(AStatus: IStatus): Boolean; override; end; 

 function TSplitProcedure.open(AStatus: IStatus; AContext: IExternalContext; AInMsg, AOutMsg: Pointer): IExternalResultSet; var xInput: TInputPtr; xText: string; xDelimiter: string; begin xInput := AInMsg; if xInput.txtNull or xInput.delimiterNull then begin Result := nil; Exit; end; xText := readBlob(AStatus, AContext, @xInput.txt); xDelimiter := TFBCharSet.CS_UTF8.GetString(TBytes(@xInput.delimiter), 0, 4); //        //    //  - /4 SetLength(xDelimiter, 1); Result := TSplitResultSet.Create; with TSplitResultSet(Result) do begin Output := AOutMsg; OutputArray := xText.Split([xDelimiter], TStringSplitOptions.ExcludeEmpty); Counter := 0; end; end; 

 procedure TSplitProcedure.SaveBlobToStream(AStatus: IStatus; AContext: IExternalContext; ABlobId: ISC_QUADPtr; AStream: TStream); var att: IAttachment; trx: ITransaction; blob: IBlob; buffer: array [0 .. 32767] of AnsiChar; l: Integer; begin try att := AContext.getAttachment(AStatus); trx := AContext.getTransaction(AStatus); blob := att.openBlob(AStatus, trx, ABlobId, 0, nil); while True do begin case blob.getSegment(AStatus, SizeOf(buffer), @buffer, @l) of IStatus.RESULT_OK: AStream.WriteBuffer(buffer, l); IStatus.RESULT_SEGMENT: AStream.WriteBuffer(buffer, l); else break; end; end; AStream.Position := 0; blob.close(AStatus); finally if Assigned(att) then att.release; if Assigned(trx) then trx.release; if Assigned(blob) then blob.release; end; end; 

 procedure TSplitResultSet.dispose; begin SetLength(OutputArray, 0); Destroy; end; function TSplitResultSet.fetch(AStatus: IStatus): Boolean; var statusVector: array [0 .. 4] of NativeIntPtr; begin if Counter <= High(OutputArray) then begin Output.Null := False; //         isc_random //        Firebird //  isc_convert_error try Output.Id := OutputArray[Counter].ToInteger(); except on e: EConvertError do begin statusVector[0] := NativeIntPtr(isc_arg_gds); statusVector[1] := NativeIntPtr(isc_convert_error); statusVector[2] := NativeIntPtr(isc_arg_string); statusVector[3] := NativeIntPtr(PAnsiChar('Cannot convert string to integer')); statusVector[4] := NativeIntPtr(isc_arg_end); AStatus.setErrors(@statusVector); end; end; inc(Counter); Result := True; end else Result := False; end; 

 interface uses Firebird, Classes, SysUtils; type //    TInput = record filename: record len: Smallint; str: array [0 .. 1019] of AnsiChar; end; filenameNull: WordBool; end; TInputPtr = ^TInput; //    TOutput = record blobData: ISC_QUAD; blobDataNull: WordBool; end; TOutputPtr = ^TOutput; //   LoadBlobFromFile TLoadBlobFromFileFunc = class(IExternalFunctionImpl) public procedure dispose(); override; procedure getCharSet(AStatus: IStatus; AContext: IExternalContext; AName: PAnsiChar; ANameSize: Cardinal); override; procedure execute(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer); override; end; //       LoadBlobFromFile TLoadBlobFromFileFuncFactory = class(IUdrFunctionFactoryImpl) procedure dispose(); override; procedure setup(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata; AInBuilder: IMetadataBuilder; AOutBuilder: IMetadataBuilder); override; function newItem(AStatus: IStatus; AContext: IExternalContext; AMetadata: IRoutineMetadata): IExternalFunction; override; end; 

 procedure TLoadBlobFromFileFunc.execute(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer); const MaxBufSize = 16384; var xInput: TInputPtr; xOutput: TOutputPtr; xFileName: string; xStream: TFileStream; att: IAttachment; trx: ITransaction; blob: IBlob; buffer: array [0 .. 32767] of Byte; xStreamSize: Integer; xBufferSize: Integer; xReadLength: Integer; begin xInput := AInMsg; xOutput := AOutMsg; if xInput.filenameNull then begin xOutput.blobDataNull := True; Exit; end; xOutput.blobDataNull := False; //    xFileName := TEncoding.UTF8.GetString(TBytes(@xInput.filename.str), 0, xInput.filename.len * 4); SetLength(xFileName, xInput.filename.len); //     xStream := TFileStream.Create(xFileName, fmOpenRead or fmShareDenyNone); att := AContext.getAttachment(AStatus); trx := AContext.getTransaction(AStatus); blob := nil; try xStreamSize := xStream.Size; //     () if xStreamSize > MaxBufSize then xBufferSize := MaxBufSize else xBufferSize := xStreamSize; //   blob blob := att.createBlob(AStatus, trx, @xOutput.blobData, 0, nil); //        BLOB   while xStreamSize <> 0 do begin if xStreamSize > xBufferSize then xReadLength := xBufferSize else xReadLength := xStreamSize; xStream.ReadBuffer(buffer, xReadLength); blob.putSegment(AStatus, xReadLength, @buffer[0]); Dec(xStreamSize, xReadLength); end; //  BLOB blob.close(AStatus); finally if Assigned(blob) then blob.release; att.release; trx.release; xStream.Free; end; end; 

 unit FbBlob; interface uses Classes, SysUtils, Firebird; const MAX_SEGMENT_SIZE = $7FFF; type TFbBlobHelper = class helper for IBlob {   BLOB   @param(AStatus  ) @param(AStream ) } procedure LoadFromStream(AStatus: IStatus; AStream: TStream); {     BLOB @param(AStatus  ) @param(AStream ) } procedure SaveToStream(AStatus: IStatus; AStream: TStream); end; implementation uses Math; procedure TFbBlobHelper.LoadFromStream(AStatus: IStatus; AStream: TStream); var xStreamSize: Integer; xReadLength: Integer; xBuffer: array [0 .. MAX_SEGMENT_SIZE] of Byte; begin xStreamSize := AStream.Size; AStream.Position := 0; while xStreamSize <> 0 do begin xReadLength := Min(xStreamSize, MAX_SEGMENT_SIZE); AStream.ReadBuffer(xBuffer, xReadLength); Self.putSegment(AStatus, xReadLength, @xBuffer[0]); Dec(xStreamSize, xReadLength); end; end; procedure TFbBlobHelper.SaveToStream(AStatus: IStatus; AStream: TStream); var xInfo: TFbBlobInfo; Buffer: array [0 .. MAX_SEGMENT_SIZE] of Byte; xBytesRead: Cardinal; xBufferSize: Cardinal; begin AStream.Position := 0; xBufferSize := Min(SizeOf(Buffer), MAX_SEGMENT_SIZE); while True do begin case Self.getSegment(AStatus, xBufferSize, @Buffer[0], @xBytesRead) of IStatus.RESULT_OK: AStream.WriteBuffer(Buffer, xBytesRead); IStatus.RESULT_SEGMENT: AStream.WriteBuffer(Buffer, xBytesRead); else break; end; end; end; end. 

 procedure TLoadBlobFromFileFunc.execute(AStatus: IStatus; AContext: IExternalContext; AInMsg: Pointer; AOutMsg: Pointer); var xInput: TInputPtr; xOutput: TOutputPtr; xFileName: string; xStream: TFileStream; att: IAttachment; trx: ITransaction; blob: IBlob; begin xInput := AInMsg; xOutput := AOutMsg; if xInput.filenameNull then begin xOutput.blobDataNull := True; Exit; end; xOutput.blobDataNull := False; //    xFileName := TEncoding.UTF8.GetString(TBytes(@xInput.filename.str), 0, xInput.filename.len * 4); SetLength(xFileName, xInput.filename.len); //     xStream := TFileStream.Create(xFileName, fmOpenRead or fmShareDenyNone); att := AContext.getAttachment(AStatus); trx := AContext.getTransaction(AStatus); blob := nil; try //   blob blob := att.createBlob(AStatus, trx, @xOutput.blobData, 0, nil); //     BLOB blob.LoadFromStream(AStatus, xStream); //  BLOB blob.close(AStatus); finally if Assigned(blob) then blob.release; att.release; trx.release; xStream.Free; end; 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; 

 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; //      xFormatSettings := TFormatSettings.Create; xFormatSettings.DateSeparator := '-'; xFormatSettings.TimeSeparator := ':'; //      blob inStream := TBytesStream.Create(nil); outStream := TStringStream.Create('', 65001); jsonArray := TJsonArray.Create; //      att := AContext.getAttachment(AStatus); tra := AContext.getTransaction(AStatus); stmt := nil; inBlob := nil; outBlob := nil; try //  BLOB   inBlob := att.openBlob(AStatus, tra, @xInput.SqlText, 0, nil); inBlob.SaveToStream(AStatus, inStream); inBlob.close(AStatus); //   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; //   rs.close(AStatus); //  JSON   outStream.WriteString(jsonArray.ToJSON); //  json   blob outBlob := att.createBlob(AStatus, tra, @xOutput.Json, 0, nil); outBlob.LoadFromStream(AStatus, outStream); outBlob.close(AStatus); finally if Assigned(inBlob) then inBlob.release; if Assigned(stmt) then stmt.release; if Assigned(outBlob) then outBlob.release; tra.release; att.release; jsonArray.Free; inStream.Free; outStream.Free; end; end; 

 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; pData: PByte; util: IUtil; metaLength: Integer; //  CharBuffer: array [0 .. 35766] of Byte; charLength: Smallint; charset: TFBCharSet; StringValue: string; SmallintValue: Smallint; IntegerValue: Integer; BigintValue: Int64; Scale: Smallint; SingleValue: Single; DoubleValue: Double; BooleanValue: Boolean; DateValue: ISC_DATE; TimeValue: ISC_TIME; TimestampValue: ISC_TIMESTAMP; DateTimeValue: TDateTime; year, month, day: Cardinal; hours, minutes, seconds, fractions: Cardinal; blobId: ISC_QUADPtr; BlobSubtype: Smallint; blob: IBlob; textStream: TStringStream; binaryStream: TBytesStream; att: IAttachment; tra: ITransaction; 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      jsonObject.AddPair(FieldName, TJsonNull.Create); continue; end; //      pData := ABuffer + AMeta.getOffset(AStatus, i); case TFBType(AMeta.getType(AStatus, i)) of // VARCHAR SQL_VARYING: begin //    VARCHAR metaLength := AMeta.getLength(AStatus, i); charset := TFBCharSet(AMeta.getCharSet(AStatus, i)); //  VARCHAR  2  -  charLength := PSmallint(pData)^; //     base64 if charset = CS_BINARY then StringValue := TNetEncoding.Base64.EncodeBytesToString((pData + 2), charLength) else begin //       3  Move((pData + 2)^, CharBuffer, metaLength - 2); StringValue := charset.GetString(TBytes(@CharBuffer), 0, charLength * charset.GetCharWidth) SetLength(StringValue, charLength); end; jsonObject.AddPair(FieldName, StringValue); end; // CHAR SQL_TEXT: begin //    CHAR metaLength := AMeta.getLength(AStatus, i); charset := TFBCharSet(AMeta.getCharSet(AStatus, i)); //     base64 if charset = CS_BINARY then StringValue := TNetEncoding.Base64.EncodeBytesToString((pData + 2), metaLength) else begin //     Move(pData^, CharBuffer, metaLength); StringValue := charset.GetString(TBytes(@CharBuffer), 0, metaLength); charLength := metaLength div charset.GetCharWidth; SetLength(StringValue, charLength); end; jsonObject.AddPair(FieldName, StringValue); end; // FLOAT SQL_FLOAT: begin SingleValue := PSingle(pData)^; jsonObject.AddPair(FieldName, TJSONNumber.Create(SingleValue)); end; // DOUBLE PRECISION // DECIMAL(p, s),  p = 10..15  1  SQL_DOUBLE, SQL_D_FLOAT: begin DoubleValue := PDouble(pData)^; jsonObject.AddPair(FieldName, TJSONNumber.Create(DoubleValue)); end; // INTEGER // NUMERIC(p, s),  p = 1..4 SQL_SHORT: begin Scale := AMeta.getScale(AStatus, i); SmallintValue := PSmallint(pData)^; if (Scale = 0) then begin jsonObject.AddPair(FieldName, TJSONNumber.Create(SmallintValue)); end else begin StringValue := MakeScaleInteger(SmallintValue, Scale); jsonObject.AddPair(FieldName, TJSONNumber.Create(StringValue)); 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 jsonObject.AddPair(FieldName, TJSONNumber.Create(IntegerValue)); end else begin StringValue := MakeScaleInteger(IntegerValue, Scale); jsonObject.AddPair(FieldName, TJSONNumber.Create(StringValue)); 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 jsonObject.AddPair(FieldName, TJSONNumber.Create(BigintValue)); end else begin StringValue := MakeScaleInteger(BigintValue, Scale); jsonObject.AddPair(FieldName, TJSONNumber.Create(StringValue)); end; end; // TIMESTAMP SQL_TIMESTAMP: begin TimestampValue := PISC_TIMESTAMP(pData)^; //    - util.decodeDate(TimestampValue.date, @year, @month, @day); util.decodeTime(TimestampValue.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); jsonObject.AddPair(FieldName, StringValue); 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); jsonObject.AddPair(FieldName, StringValue); 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); jsonObject.AddPair(FieldName, StringValue); end; // BOOLEAN SQL_BOOLEAN: begin BooleanValue := PBoolean(pData)^; jsonObject.AddPair(FieldName, TJsonBool.Create(BooleanValue)); 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); if BlobSubtype = 1 then begin //  charset := TFBCharSet(AMeta.getCharSet(AStatus, i)); //      textStream := TStringStream.Create('', charset.GetCodePage); try blob.SaveToStream(AStatus, textStream); StringValue := textStream.DataString; finally textStream.Free; blob.release; tra.release; att.release end; end else begin //      binaryStream := TBytesStream.Create; try blob.SaveToStream(AStatus, binaryStream); //    base64 StringValue := TNetEncoding.Base64.EncodeBytesToString (binaryStream.Memory, binaryStream.Size); finally binaryStream.Free; blob.release; tra.release; att.release end; end; jsonObject.AddPair(FieldName, StringValue); end; end; end; //     Json   AJson.AddElement(jsonObject); end;