fbintf/client/FBParamBlock.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API.
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit FBParamBlock;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

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

interface

{Provides common handling for the DPB, TPB, SPB and Service Request Block (SRB)}

uses
  Classes, SysUtils, IB, FBClientAPI, FBActivityMonitor;

type
  TParamDataType = (dtString, dtString2, dtString0, dtByte, dtByte2, dtInteger,  dtInteger1,
                    dtInteger2,  dtShortInteger,dtTinyInteger,dtnone);

  PParamBlockItemData = ^TParamBlockItemData;
  TParamBlockItemData = record
    {Describes a Clumplet in the buffer. FBufPtr always points to the clumplet id
     the rest of the clumplet up to the FBufLength is data. The data format is
     given by FDataType}
    FBufPtr: PByte;
    FBuflength: integer;
    FDataType: TParamDataType;
  end;

  TParamBlockItem = class;

  { TParamBlock }

  TParamBlock = class(TFBInterfacedObject)
  private
    FItems: array of PParamBlockItemData;
    FBufferSize: integer;
    FFirebirdClientAPI: TFBClientAPI;
    procedure AdjustBuffer;
    procedure MoveBy(Item: PParamBlockItemData; delta: integer);
    procedure UpdateRequestItemSize(Item: TParamBlockItem; NewSize: integer);
  protected
    FBuffer: PByte;
    FDataLength: integer;
    function Add(ParamType: byte): PParamBlockItemData;
    function Find(ParamType: byte): PParamBlockItemData;
    function GetItems(index: integer): PParamBlockItemData;
  public
    constructor Create(api: TFBClientAPI);
    destructor Destroy; override;
    function getBuffer: PByte;
    function getDataLength: integer;
    function AvailableBufferSpace: integer;

  public
    function getCount: integer;
    procedure Remove(ParamType: byte);
    procedure PrintBuf;
  end;

  { TParamBlockItem }

  TParamBlockItem = class(TFBInterfacedObject)
  private
     FOwner: TParamBlock;
     FOwnerIntf: IUnknown;
     FParamData: PParamBlockItemData;
     FFirebirdClientAPI: TFBClientAPI;
  protected
    property ParamData: PParamBlockItemData read FParamData;
  public
     constructor Create(AOwner: TParamBlock; Data: PParamBlockItemData);
  public
     function getAsInteger: integer;
     function getParamType: byte;
     function getAsString: AnsiString;
     function getAsByte: byte;
     procedure addByte(aValue: byte);
     procedure addShortInteger(aValue: integer);
     procedure setAsByte(aValue: byte);
     procedure setAsByte2(aValue: byte);
     procedure SetAsInteger(aValue: integer);
     procedure SetAsInteger1(aValue: integer);
     procedure SetAsInteger2(aValue: integer);
     procedure SetAsShortInteger(aValue: integer);
     procedure SetAsTinyInteger(aValue: integer);
     procedure SetAsString(aValue: AnsiString);
     procedure SetAsString2(aValue: AnsiString);
     procedure SetAsString0(aValue: AnsiString);
  end;

  { TDPBItem }

  TDPBItem = class(TParamBlockItem,IDPBItem);

  { TTPBItem }

  TTPBItem = class(TParamBlockItem,ITPBItem);

  { TSPBItem }

  TSPBItem = class(TParamBlockItem,ISPBItem);

  { TSRBItem }

  TSRBItem = class(TParamBlockItem,ISRBItem)
  public
    {$IFDEF FPC}
    procedure ISRBItem.SetAsString = SetAsString2;
    procedure ISRBItem.SetAsByte = SetAsByte2;
    {$ELSE}
    procedure SetAsString(aValue: AnsiString) ;
    procedure SetAsByte(aValue: byte);
    {$ENDIF}
  end;

  { TSQPBItem }

  TSQPBItem = class(TParamBlockItem,ISQPBItem)
  public
   function CopyFrom(source: TStream; count: integer): integer;
   {$IFDEF FPC}
   procedure ISQPBItem.SetAsInteger = SetAsInteger2;
   procedure ISQPBItem.SetAsString = SetAsString2;
   {$ELSE}
   procedure SetAsString(aValue: AnsiString) ;
   procedure SetAsInteger(aValue: integer);
   {$ENDIF}
  end;

  { TBPBItem }

  TBPBItem =  class(TParamBlockItem,IBPBItem)
  public
   {$IFDEF FPC}
    procedure IBPBItem.SetAsInteger = SetAsInteger1;
   {$ELSE}
    procedure SetAsInteger(aValue: integer);
   {$ENDIF}
  end;

  { TDIRBItem }

  TDIRBItem = class(TParamBlockItem,IDIRBItem)
  public
   {$IFDEF FPC}
    procedure IDIRBItem.SetAsInteger = SetAsInteger2;
   {$ELSE}
    procedure SetAsInteger(aValue: integer);
   {$ENDIF}
  end;

  { TCustomParamBlock }

{$IFDEF FPC}
  TCustomParamBlock<_TItem, _IItem> = class(TParamBlock)
{$ELSE}
  TParamBlockItemClass = class of TParamBlockItem;
  TCustomParamBlock<_TItem: TParamBlockItem;  _IItem: IParameterBlockItem> = class(TParamBlock)
{$ENDIF}
  public
    function Add(ParamType: byte): _IItem;
    function Find(ParamType: byte): _IItem;
    function GetItems(index: integer): _IItem;
  end;

  { TDPB }

  TDPB = class (TCustomParamBlock<TDPBItem,IDPBItem>, IDPB)
  public
    constructor Create(api: TFBClientAPI);
  end;

  { TTPB }

  TTPB = class (TCustomParamBlock<TTPBItem,ITPBItem>, ITPB)
  public
    constructor Create(api: TFBClientAPI);
  end;

  { TSPB }

  TSPB = class (TCustomParamBlock<TSPBItem,ISPBItem>, ISPB)
  public
   constructor Create(api: TFBClientAPI);
  end;

  { TSRB }

  TSRB = class (TCustomParamBlock<TSRBItem,ISRBItem>, ISRB);

  { TSQPB }

  TSQPB = class (TCustomParamBlock<TSQPBItem,ISQPBItem>, ISQPB);

  { TBPB }

  TBPB = class (TCustomParamBlock<TBPBItem,IBPBItem>, IBPB)
  public
   constructor Create(api: TFBClientAPI);
  end;

  TDIRB = class (TCustomParamBlock<TDIRBItem,IDIRBItem>, IDIRB);

implementation

uses FBMessages {$IFNDEF FPC} , TypInfo {$ENDIF};

const
  MaxBufferSize = 65535;

{ TDIRBItem }
{$IFNDEF FPC}
procedure TDIRBItem.SetAsInteger(aValue: integer);
begin
  SetAsInteger2(aValue);
end;
{$ENDIF}

{ TBPBItem }
{$IFNDEF FPC}
procedure TBPBItem.SetAsInteger(aValue: integer);
begin
  SetAsInteger1(aValue);
end;
{$ENDIF}

{ TSRBItem }

{$IFNDEF FPC}
procedure TSRBItem.SetAsString(aValue: AnsiString);
begin
  SetAsString2(aValue);
end;

procedure TSRBItem.SetAsByte(aValue: byte);
begin
  SetAsByte2(aValue);
end;
{$ENDIF}

{ TSQPBItem }

function TSQPBItem.CopyFrom(source: TStream; count: integer): integer;
begin
  if count > (FOwner.AvailableBufferSpace - 4) then
    count := FOwner.AvailableBufferSpace - 4;
    with FParamData^ do
    begin
      FOwner.UpdateRequestItemSize(self,count + 4);
      Result := source.Read((FBufPtr+3)^,count);
      with FFirebirdClientAPI do
        EncodeInteger(Result,2,FBufPtr+1);
      (FBufPtr+Result + 3)^ := isc_info_end;
      if Result <> count then
        FOwner.UpdateRequestItemSize(self,Result + 4);
      FDataType := dtString2;
    end;
end;

{$IFNDEF FPC}
procedure TSQPBItem.SetAsString(aValue: AnsiString);
begin
  SetAsString2(aValue);
end;

procedure TSQPBItem.SetAsInteger(aValue: integer);
begin
  SetAsInteger2(aValue);
end;
{$ENDIF}

{ TParamBlockItem }

constructor TParamBlockItem.Create(AOwner: TParamBlock;
  Data: PParamBlockItemData);
begin
  inherited Create;
  FOwner := AOwner;
  FFirebirdClientAPI := AOwner.FFirebirdClientAPI;
  FOwnerIntf := AOwner;
  FParamData := Data;
end;

function TParamBlockItem.getAsInteger: integer;
begin
  with FFirebirdClientAPI, FParamData^ do
  case FDataType of
  dtInteger:
    Result := DecodeInteger(FBufPtr+1,4);
  dtShortInteger:
    Result := DecodeInteger(FBufPtr+1,2);
  dtTinyInteger:
    Result := DecodeInteger(FBufPtr+1,1);
  dtInteger1:
    Result := DecodeInteger(FBufPtr+2,2);
  dtInteger2:
    Result := DecodeInteger(FBufPtr+3,4);
  else
    IBError(ibxePBParamTypeError,[nil]);
  end;
end;

function TParamBlockItem.getParamType: byte;
begin
  Result := byte(FParamData^.FBufPtr^);
end;

function TParamBlockItem.getAsString: AnsiString;
var len: byte;
begin
  Result := '';

  with FParamData^ do
  case FDataType of
  dtInteger,
  dtInteger1,
  dtInteger2,
  dtShortInteger,
  dtTinyInteger:
    Result := IntToStr(getAsInteger);
  dtByte,
  dtByte2:
    Result := IntToStr(getAsByte);
  dtString:
    begin
      len := (FBufPtr+1)^;
      SetString(Result,PAnsiChar(FBufPtr+2),len);
    end;
  dtString2:
    begin
      with FFirebirdClientAPI do
        len := DecodeInteger(FBufPtr+1,2);
      SetString(Result,PAnsiChar(FBufPtr+3),len);
    end;
  dtString0:
      Result := strpas(PAnsiChar(FBufPtr+1));
    else
      IBError(ibxeOutputBlockTypeError,[nil]);
  end;
end;

function TParamBlockItem.getAsByte: byte;
begin
  with FParamData^ do
  if FDataType = dtByte then
    Result := byte((FBufPtr+2)^)
  else
  if FDataType = dtByte2 then
    Result := byte((FBufPtr+1)^)
  else
    IBError(ibxePBParamTypeError,[nil]);
end;

procedure TParamBlockItem.addByte(aValue: byte);
var len: integer;
    P: PByte;
begin
  with FParamData^ do
  begin
    P := FBufPtr + FBufLength;
    len := FBufLength + 1;
    FOwner.UpdateRequestItemSize(self,len);
    P^ := aValue;
  end;
end;

procedure TParamBlockItem.addShortInteger(aValue: integer);
var len: integer;
    P: PByte;
begin
  with FParamData^ do
  begin
    P := FBufPtr + FBufLength;
    len := FBufLength + 2;
    FOwner.UpdateRequestItemSize(self,len);
    with FFirebirdClientAPI do
      EncodeInteger(aValue,2,P);
  end;
end;

procedure TParamBlockItem.setAsByte(aValue: byte);
begin
  with FParamData^ do
  begin
    if FBufLength <> 3 then
      FOwner.UpdateRequestItemSize(self,3);
    FDataType := dtByte;
    (FBufPtr+1)^ := $1;
    (FBufPtr+2)^ := aValue;
  end;
end;

procedure TParamBlockItem.setAsByte2(aValue: byte);
begin
  with FParamData^ do
  begin
    if FBufLength <> 2 then
      FOwner.UpdateRequestItemSize(self,2);
    FDataType := dtByte2;
    (FBufPtr+1)^ := aValue;
  end;
end;

{Four byte integer - no length}

procedure TParamBlockItem.SetAsInteger(aValue: integer);
begin
  with FParamData^ do
  begin
    if FBufLength <> 5 then
      FOwner.UpdateRequestItemSize(self,5);
    with FFirebirdClientAPI do
      EncodeInteger(aValue,4,FBufPtr+1);
    FDataType := dtInteger;
  end;
end;

{Four byte integer - length byte}

procedure TParamBlockItem.SetAsInteger1(aValue: integer);
begin
  with FParamData^ do
  begin
    if FBufLength <> 6 then
      FOwner.UpdateRequestItemSize(self,6);
    (FBufPtr+1)^ := $4;
    with FFirebirdClientAPI do
      EncodeInteger(aValue,4,FBufPtr+2);
    FDataType := dtInteger1;
  end;
end;

{Four byte integer - 2 byte length}

procedure TParamBlockItem.SetAsInteger2(aValue: integer);
begin
  with FParamData^ do
  begin
    if FBufLength <> 7 then
      FOwner.UpdateRequestItemSize(self,7);
    with FFirebirdClientAPI do
    begin
      EncodeInteger(4,2,FBufPtr+1); {Encode length as two bytes}
      EncodeInteger(aValue,4,FBufPtr+3);
    end;
    FDataType := dtInteger2
  end;
end;

procedure TParamBlockItem.SetAsShortInteger(aValue: integer);
begin
  with FParamData^ do
  begin
    if FBufLength <> 3 then
      FOwner.UpdateRequestItemSize(self,3);
    with FFirebirdClientAPI do
      EncodeInteger(aValue,2,FBufPtr+1);
    FDataType := dtShortInteger;
  end;
end;

procedure TParamBlockItem.SetAsTinyInteger(aValue: integer);
begin
  with FParamData^ do
  begin
    if FBufLength <> 2 then
      FOwner.UpdateRequestItemSize(self,2);
    with FFirebirdClientAPI do
      EncodeInteger(aValue,1,FBufPtr+1);
    FDataType := dtTinyInteger;
  end;
end;

{Short string encoding}

procedure TParamBlockItem.SetAsString(aValue: AnsiString);
var len: integer;
begin
  with FParamData^ do
  begin
    len := Length(aValue);
    if len > 255 then
      IBError(ibxStringTooLong,[aValue,255]);
    FOwner.UpdateRequestItemSize(self,len+2);
    (FBufPtr+1)^ := len;
    if len > 0 then
      Move(aValue[1],(FBufPtr+2)^,len);
    FDataType := dtString;
  end;
end;

{Long string up to 65535 encoding}

procedure TParamBlockItem.SetAsString2(aValue: AnsiString);
var len: integer;
begin
  with FParamData^ do
  begin
    len := Length(aValue);
    if len > 65535 then
      IBError(ibxStringTooLong,[aValue,65535]);
    FOwner.UpdateRequestItemSize(self,len + 3);
    with FFirebirdClientAPI do
      EncodeInteger(len,2,FBufPtr+1);
    if len > 0 then
      Move(aValue[1],(FBufPtr+3)^,len);
    FDataType := dtString2;
  end;
end;

{Zero byte terminated string encoding}

procedure TParamBlockItem.SetAsString0(aValue: AnsiString);
var len: integer;
begin
  with FParamData^ do
  begin
    len := Length(aValue);
    FOwner.UpdateRequestItemSize(self,len+2);
    if len > 0 then
      Move(aValue[1],(FBufPtr+1)^,len);
    (FBufPtr+len+1)^ := 0;
    FDataType := dtString0;
  end;
end;

{ TParamBlock }

procedure TParamBlock.AdjustBuffer;
var P: PByte;
    i: integer;
    headerLen: integer;
begin
  if FDataLength > FBufferSize then
  begin
    if Length(FItems) > 0 then
      headerLen := FItems[0]^.FBufPtr - FBuffer
    else
      headerLen := 0;
    FBufferSize := 2*FDataLength;
    ReallocMem(FBuffer,FBufferSize);
    P := FBuffer + headerLen;
    for i := 0 to Length(FItems) - 1 do
    begin
      FItems[i]^.FBufPtr := P;
      Inc(P,FItems[i]^.FBuflength);
    end;
  end;
end;

procedure TParamBlock.MoveBy(Item: PParamBlockItemData; delta: integer);
var src, dest: PByte;
  i: integer;
begin
  with Item^ do
  begin
    src := FBufptr;
    dest := FBufptr + delta ;
    if delta > 0 then
    begin
      for i := FBufLength - 1 downto 0 do
        (dest +i)^ := (src+i)^;
    end
    else
    begin
      for i := 0 to FBufLength - 1 do
      (dest +i)^ := (src+i)^;
    end;
    FBufPtr := FBufPtr + delta;
  end;
end;

procedure TParamBlock.UpdateRequestItemSize(Item: TParamBlockItem;
  NewSize: integer);
var i, delta: integer;
begin
  delta := NewSize - Item.FParamData^.FBufLength;
  Item.FParamData^.FBufLength := NewSize;
  if delta > 0 then
  begin
    if FDataLength + delta > MaxBufferSize then
      IBError(ibxeParamBufferOverflow,[nil]);
    FDataLength := FDataLength + delta;
    AdjustBuffer;
    i := Length(FItems) - 1;
    while i >= 0  do
    begin
      if FItems[i]  = Item.FParamData then
        break; {we're done}
      Moveby(FItems[i],delta);
      Dec(i);
    end;
  end
  else
  begin
    i := 0;
    while i < Length(FItems) do
    begin
      if FItems[i] = Item.FParamData then
        break; {we're done}
      Inc(i);
    end;
    Inc(i);
    while i < Length(FItems) do
    begin
      Moveby(FItems[i],delta);
      Inc(i);
    end;
    FDataLength := FDataLength + delta;
  end;
end;

constructor TParamBlock.Create(api: TFBClientAPI);
begin
  inherited Create;
  FFirebirdClientAPI := api;
  GetMem(FBuffer,128);
  if FBuffer = nil then
    OutOfMemoryError;
  FBufferSize := 128;
  FDataLength := 0;
end;

destructor TParamBlock.Destroy;
var i: integer;
begin
  for i := 0 to Length(FItems) -1 do
    dispose(FItems[i]);
  Freemem(FBuffer);
  inherited Destroy;
end;

function TParamBlock.getBuffer: PByte;
begin
  if FDataLength = 0 then
    Result := nil
  else
    Result := FBuffer;
end;

function TParamBlock.getDataLength: integer;
begin
  Result :=  FDataLength
end;

function TParamBlock.AvailableBufferSpace: integer;
begin
  Result := MaxBufferSize - FDataLength;
end;

function TParamBlock.Add(ParamType: byte): PParamBlockItemData;
begin
  new(Result);
  Result^.FBufPtr := FBuffer + FDataLength;
  Result^.FBufLength := 1;
  Result^.FBufPtr^ := ParamType;
  Result^.FDataType := dtnone; {default}
  Inc(FDataLength,1);
  AdjustBuffer;
  SetLength(FItems,Length(FItems)+1);
  FItems[Length(FItems) - 1 ] := Result;
end;

function TParamBlock.Find(ParamType: byte): PParamBlockItemData;
var i: integer;
begin
  Result := nil;
  for i := 0 to getCount - 1 do
    if byte(FItems[i]^.FBufPtr^) = ParamType then
    begin
      Result := FItems[i];
      Exit;
    end;
end;

function TParamBlock.GetItems(index: integer): PParamBlockItemData;
begin
  if (index >= 0 ) and (index < Length(FItems)) then
   Result := FItems[index]
 else
   IBError(ibxePBIndexError,[index]);
end;

function TParamBlock.getCount: integer;
begin
  Result := Length(FItems);
end;

procedure TParamBlock.Remove(ParamType: byte);
var P: PParamBlockItemData;
    i, j: integer;
begin
  P := nil;
  for i := 0 to getCount - 1 do
    if byte(FItems[i]^.FBufPtr^) = ParamType then
    begin
      P := FItems[i];
      for j := i + 1 to getCount - 1 do
      begin
        MoveBy(FItems[j],-P^.FBufLength);
        FItems[j - 1] := FItems[j];
      end;
      FDataLength := FDataLength - P^.FBufLength;
      dispose(P);
      SetLength(FItems,Length(FItems)-1);
      Exit;
    end;
end;

procedure TParamBlock.PrintBuf;
var i: integer;
begin
  write(ClassName,': ');
  for i := 0 to getDataLength - 1 do
    write(Format('%x ',[byte(FBuffer[i])]));
  writeln
end;

{ TCustomParamBlock }

{$IFDEF FPC}
function TCustomParamBlock<_TItem, _IItem>.Add(ParamType: byte): _IItem;
var Item: PParamBlockItemData;
begin
  Item := inherited Add(ParamType);
  Result := _TItem.Create(self,Item);
end;

function TCustomParamBlock<_TItem, _IItem>.Find(ParamType: byte): _IItem;
var Item: PParamBlockItemData;
begin
  Result := nil;
  Item := inherited Find(ParamType);
  if Item <> nil then
    Result := _TItem.Create(self,Item);
end;

function TCustomParamBlock<_TItem, _IItem>.GetItems(index: integer): _IItem;
var Item: PParamBlockItemData;
begin
  Item := inherited getItems(index);
  Result := _TItem.Create(self,Item);
end;
{$ELSE}
function TCustomParamBlock<_TItem, _IItem>.Add(ParamType: byte): _IItem;
var Item: PParamBlockItemData;
    Obj: TParamBlockItem;
begin
  Item := inherited Add(ParamType);
  Obj := TParamBlockItemClass(_TItem).Create(self,Item);
  if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
    IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
end;

function TCustomParamBlock<_TItem, _IItem>.Find(ParamType: byte): _IItem;
var Item: PParamBlockItemData;
    Obj: TParamBlockItem;
begin
  FillChar(Result,sizeof(Result),0); {workaround for older versions of Delphi}
  Item := inherited Find(ParamType);
  if Item <> nil then
  begin
    Obj := TParamBlockItemClass(_TItem).Create(self,Item);
    if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
      IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
  end;
end;

function TCustomParamBlock<_TItem, _IItem>.GetItems(index: integer): _IItem;
var Item: PParamBlockItemData;
    Obj: TParamBlockItem;
begin
  Item := inherited getItems(index);
  Obj := TParamBlockItemClass(_TItem).Create(self,Item);
  if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
    IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
end;
{$ENDIF}

{ TDPB }

constructor TDPB.Create(api: TFBClientAPI);
begin
  inherited Create(api);
  FDataLength := 1;
  FBuffer^ := isc_dpb_version1;
end;

{ TTPB }

constructor TTPB.Create(api: TFBClientAPI);
begin
  inherited Create(api);
  FDataLength := 1;
  FBuffer^ := isc_tpb_version3;
end;

{ TSPB }

constructor TSPB.Create(api: TFBClientAPI);
begin
  inherited Create(api);
  FDataLength := 2;
  FBuffer^ := isc_spb_version;
  (FBuffer+1)^ := isc_spb_current_version;
end;

{ TBPB }

constructor TBPB.Create(api: TFBClientAPI);
begin
  inherited Create(api);
  FDataLength := 1;
  FBuffer^ := isc_bpb_version1;
end;

end.

Revision:	263
Committed:	Thu Dec 6 15:55:01 2018 UTC (5 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	19915 byte(s)
Log Message:	Release 2.3.2 committed
#	Content
1	(*
2	* Firebird Interface (fbintf). The fbintf components provide a set of
3	* Pascal language bindings for the Firebird API.
4	*
5	* The contents of this file are subject to the Initial Developer's
6	* Public License Version 1.0 (the "License"); you may not use this
7	* file except in compliance with the License. You may obtain a copy
8	* of the License here:
9	*
10	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11	*
12	* Software distributed under the License is distributed on an "AS
13	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14	* implied. See the License for the specific language governing rights
15	* and limitations under the License.
16	*
17	* The Initial Developer of the Original Code is Tony Whyman.
18	*
19	* The Original Code is (C) 2016 Tony Whyman, MWA Software
20	* (http://www.mwasoftware.co.uk).
21	*
22	* All Rights Reserved.
23	*
24	* Contributor(s): ______________________________________.
25	*
26	*)
27	unit FBParamBlock;
28	{$IFDEF MSWINDOWS}
29	{$DEFINE WINDOWS}
30	{$ENDIF}
31
32	{$IFDEF FPC}
33	{$mode delphi}
34	{$interfaces COM}
35	{$ENDIF}
36
37	interface
38
39	{Provides common handling for the DPB, TPB, SPB and Service Request Block (SRB)}
40
41	uses
42	Classes, SysUtils, IB, FBClientAPI, FBActivityMonitor;
43
44	type
45	TParamDataType = (dtString, dtString2, dtString0, dtByte, dtByte2, dtInteger, dtInteger1,
46	dtInteger2, dtShortInteger,dtTinyInteger,dtnone);
47
48	PParamBlockItemData = ^TParamBlockItemData;
49	TParamBlockItemData = record
50	{Describes a Clumplet in the buffer. FBufPtr always points to the clumplet id
51	the rest of the clumplet up to the FBufLength is data. The data format is
52	given by FDataType}
53	FBufPtr: PByte;
54	FBuflength: integer;
55	FDataType: TParamDataType;
56	end;
57
58	TParamBlockItem = class;
59
60	{ TParamBlock }
61
62	TParamBlock = class(TFBInterfacedObject)
63	private
64	FItems: array of PParamBlockItemData;
65	FBufferSize: integer;
66	FFirebirdClientAPI: TFBClientAPI;
67	procedure AdjustBuffer;
68	procedure MoveBy(Item: PParamBlockItemData; delta: integer);
69	procedure UpdateRequestItemSize(Item: TParamBlockItem; NewSize: integer);
70	protected
71	FBuffer: PByte;
72	FDataLength: integer;
73	function Add(ParamType: byte): PParamBlockItemData;
74	function Find(ParamType: byte): PParamBlockItemData;
75	function GetItems(index: integer): PParamBlockItemData;
76	public
77	constructor Create(api: TFBClientAPI);
78	destructor Destroy; override;
79	function getBuffer: PByte;
80	function getDataLength: integer;
81	function AvailableBufferSpace: integer;
82
83	public
84	function getCount: integer;
85	procedure Remove(ParamType: byte);
86	procedure PrintBuf;
87	end;
88
89	{ TParamBlockItem }
90
91	TParamBlockItem = class(TFBInterfacedObject)
92	private
93	FOwner: TParamBlock;
94	FOwnerIntf: IUnknown;
95	FParamData: PParamBlockItemData;
96	FFirebirdClientAPI: TFBClientAPI;
97	protected
98	property ParamData: PParamBlockItemData read FParamData;
99	public
100	constructor Create(AOwner: TParamBlock; Data: PParamBlockItemData);
101	public
102	function getAsInteger: integer;
103	function getParamType: byte;
104	function getAsString: AnsiString;
105	function getAsByte: byte;
106	procedure addByte(aValue: byte);
107	procedure addShortInteger(aValue: integer);
108	procedure setAsByte(aValue: byte);
109	procedure setAsByte2(aValue: byte);
110	procedure SetAsInteger(aValue: integer);
111	procedure SetAsInteger1(aValue: integer);
112	procedure SetAsInteger2(aValue: integer);
113	procedure SetAsShortInteger(aValue: integer);
114	procedure SetAsTinyInteger(aValue: integer);
115	procedure SetAsString(aValue: AnsiString);
116	procedure SetAsString2(aValue: AnsiString);
117	procedure SetAsString0(aValue: AnsiString);
118	end;
119
120	{ TDPBItem }
121
122	TDPBItem = class(TParamBlockItem,IDPBItem);
123
124	{ TTPBItem }
125
126	TTPBItem = class(TParamBlockItem,ITPBItem);
127
128	{ TSPBItem }
129
130	TSPBItem = class(TParamBlockItem,ISPBItem);
131
132	{ TSRBItem }
133
134	TSRBItem = class(TParamBlockItem,ISRBItem)
135	public
136	{$IFDEF FPC}
137	procedure ISRBItem.SetAsString = SetAsString2;
138	procedure ISRBItem.SetAsByte = SetAsByte2;
139	{$ELSE}
140	procedure SetAsString(aValue: AnsiString) ;
141	procedure SetAsByte(aValue: byte);
142	{$ENDIF}
143	end;
144
145	{ TSQPBItem }
146
147	TSQPBItem = class(TParamBlockItem,ISQPBItem)
148	public
149	function CopyFrom(source: TStream; count: integer): integer;
150	{$IFDEF FPC}
151	procedure ISQPBItem.SetAsInteger = SetAsInteger2;
152	procedure ISQPBItem.SetAsString = SetAsString2;
153	{$ELSE}
154	procedure SetAsString(aValue: AnsiString) ;
155	procedure SetAsInteger(aValue: integer);
156	{$ENDIF}
157	end;
158
159	{ TBPBItem }
160
161	TBPBItem = class(TParamBlockItem,IBPBItem)
162	public
163	{$IFDEF FPC}
164	procedure IBPBItem.SetAsInteger = SetAsInteger1;
165	{$ELSE}
166	procedure SetAsInteger(aValue: integer);
167	{$ENDIF}
168	end;
169
170	{ TDIRBItem }
171
172	TDIRBItem = class(TParamBlockItem,IDIRBItem)
173	public
174	{$IFDEF FPC}
175	procedure IDIRBItem.SetAsInteger = SetAsInteger2;
176	{$ELSE}
177	procedure SetAsInteger(aValue: integer);
178	{$ENDIF}
179	end;
180
181	{ TCustomParamBlock }
182
183	{$IFDEF FPC}
184	TCustomParamBlock<_TItem, _IItem> = class(TParamBlock)
185	{$ELSE}
186	TParamBlockItemClass = class of TParamBlockItem;
187	TCustomParamBlock<_TItem: TParamBlockItem; _IItem: IParameterBlockItem> = class(TParamBlock)
188	{$ENDIF}
189	public
190	function Add(ParamType: byte): _IItem;
191	function Find(ParamType: byte): _IItem;
192	function GetItems(index: integer): _IItem;
193	end;
194
195	{ TDPB }
196
197	TDPB = class (TCustomParamBlock<TDPBItem,IDPBItem>, IDPB)
198	public
199	constructor Create(api: TFBClientAPI);
200	end;
201
202	{ TTPB }
203
204	TTPB = class (TCustomParamBlock<TTPBItem,ITPBItem>, ITPB)
205	public
206	constructor Create(api: TFBClientAPI);
207	end;
208
209	{ TSPB }
210
211	TSPB = class (TCustomParamBlock<TSPBItem,ISPBItem>, ISPB)
212	public
213	constructor Create(api: TFBClientAPI);
214	end;
215
216	{ TSRB }
217
218	TSRB = class (TCustomParamBlock<TSRBItem,ISRBItem>, ISRB);
219
220	{ TSQPB }
221
222	TSQPB = class (TCustomParamBlock<TSQPBItem,ISQPBItem>, ISQPB);
223
224	{ TBPB }
225
226	TBPB = class (TCustomParamBlock<TBPBItem,IBPBItem>, IBPB)
227	public
228	constructor Create(api: TFBClientAPI);
229	end;
230
231	TDIRB = class (TCustomParamBlock<TDIRBItem,IDIRBItem>, IDIRB);
232
233	implementation
234
235	uses FBMessages {$IFNDEF FPC} , TypInfo {$ENDIF};
236
237	const
238	MaxBufferSize = 65535;
239
240	{ TDIRBItem }
241	{$IFNDEF FPC}
242	procedure TDIRBItem.SetAsInteger(aValue: integer);
243	begin
244	SetAsInteger2(aValue);
245	end;
246	{$ENDIF}
247
248	{ TBPBItem }
249	{$IFNDEF FPC}
250	procedure TBPBItem.SetAsInteger(aValue: integer);
251	begin
252	SetAsInteger1(aValue);
253	end;
254	{$ENDIF}
255
256	{ TSRBItem }
257
258	{$IFNDEF FPC}
259	procedure TSRBItem.SetAsString(aValue: AnsiString);
260	begin
261	SetAsString2(aValue);
262	end;
263
264	procedure TSRBItem.SetAsByte(aValue: byte);
265	begin
266	SetAsByte2(aValue);
267	end;
268	{$ENDIF}
269
270	{ TSQPBItem }
271
272	function TSQPBItem.CopyFrom(source: TStream; count: integer): integer;
273	begin
274	if count > (FOwner.AvailableBufferSpace - 4) then
275	count := FOwner.AvailableBufferSpace - 4;
276	with FParamData^ do
277	begin
278	FOwner.UpdateRequestItemSize(self,count + 4);
279	Result := source.Read((FBufPtr+3)^,count);
280	with FFirebirdClientAPI do
281	EncodeInteger(Result,2,FBufPtr+1);
282	(FBufPtr+Result + 3)^ := isc_info_end;
283	if Result <> count then
284	FOwner.UpdateRequestItemSize(self,Result + 4);
285	FDataType := dtString2;
286	end;
287	end;
288
289	{$IFNDEF FPC}
290	procedure TSQPBItem.SetAsString(aValue: AnsiString);
291	begin
292	SetAsString2(aValue);
293	end;
294
295	procedure TSQPBItem.SetAsInteger(aValue: integer);
296	begin
297	SetAsInteger2(aValue);
298	end;
299	{$ENDIF}
300
301	{ TParamBlockItem }
302
303	constructor TParamBlockItem.Create(AOwner: TParamBlock;
304	Data: PParamBlockItemData);
305	begin
306	inherited Create;
307	FOwner := AOwner;
308	FFirebirdClientAPI := AOwner.FFirebirdClientAPI;
309	FOwnerIntf := AOwner;
310	FParamData := Data;
311	end;
312
313	function TParamBlockItem.getAsInteger: integer;
314	begin
315	with FFirebirdClientAPI, FParamData^ do
316	case FDataType of
317	dtInteger:
318	Result := DecodeInteger(FBufPtr+1,4);
319	dtShortInteger:
320	Result := DecodeInteger(FBufPtr+1,2);
321	dtTinyInteger:
322	Result := DecodeInteger(FBufPtr+1,1);
323	dtInteger1:
324	Result := DecodeInteger(FBufPtr+2,2);
325	dtInteger2:
326	Result := DecodeInteger(FBufPtr+3,4);
327	else
328	IBError(ibxePBParamTypeError,[nil]);
329	end;
330	end;
331
332	function TParamBlockItem.getParamType: byte;
333	begin
334	Result := byte(FParamData^.FBufPtr^);
335	end;
336
337	function TParamBlockItem.getAsString: AnsiString;
338	var len: byte;
339	begin
340	Result := '';
341
342	with FParamData^ do
343	case FDataType of
344	dtInteger,
345	dtInteger1,
346	dtInteger2,
347	dtShortInteger,
348	dtTinyInteger:
349	Result := IntToStr(getAsInteger);
350	dtByte,
351	dtByte2:
352	Result := IntToStr(getAsByte);
353	dtString:
354	begin
355	len := (FBufPtr+1)^;
356	SetString(Result,PAnsiChar(FBufPtr+2),len);
357	end;
358	dtString2:
359	begin
360	with FFirebirdClientAPI do
361	len := DecodeInteger(FBufPtr+1,2);
362	SetString(Result,PAnsiChar(FBufPtr+3),len);
363	end;
364	dtString0:
365	Result := strpas(PAnsiChar(FBufPtr+1));
366	else
367	IBError(ibxeOutputBlockTypeError,[nil]);
368	end;
369	end;
370
371	function TParamBlockItem.getAsByte: byte;
372	begin
373	with FParamData^ do
374	if FDataType = dtByte then
375	Result := byte((FBufPtr+2)^)
376	else
377	if FDataType = dtByte2 then
378	Result := byte((FBufPtr+1)^)
379	else
380	IBError(ibxePBParamTypeError,[nil]);
381	end;
382
383	procedure TParamBlockItem.addByte(aValue: byte);
384	var len: integer;
385	P: PByte;
386	begin
387	with FParamData^ do
388	begin
389	P := FBufPtr + FBufLength;
390	len := FBufLength + 1;
391	FOwner.UpdateRequestItemSize(self,len);
392	P^ := aValue;
393	end;
394	end;
395
396	procedure TParamBlockItem.addShortInteger(aValue: integer);
397	var len: integer;
398	P: PByte;
399	begin
400	with FParamData^ do
401	begin
402	P := FBufPtr + FBufLength;
403	len := FBufLength + 2;
404	FOwner.UpdateRequestItemSize(self,len);
405	with FFirebirdClientAPI do
406	EncodeInteger(aValue,2,P);
407	end;
408	end;
409
410	procedure TParamBlockItem.setAsByte(aValue: byte);
411	begin
412	with FParamData^ do
413	begin
414	if FBufLength <> 3 then
415	FOwner.UpdateRequestItemSize(self,3);
416	FDataType := dtByte;
417	(FBufPtr+1)^ := $1;
418	(FBufPtr+2)^ := aValue;
419	end;
420	end;
421
422	procedure TParamBlockItem.setAsByte2(aValue: byte);
423	begin
424	with FParamData^ do
425	begin
426	if FBufLength <> 2 then
427	FOwner.UpdateRequestItemSize(self,2);
428	FDataType := dtByte2;
429	(FBufPtr+1)^ := aValue;
430	end;
431	end;
432
433	{Four byte integer - no length}
434
435	procedure TParamBlockItem.SetAsInteger(aValue: integer);
436	begin
437	with FParamData^ do
438	begin
439	if FBufLength <> 5 then
440	FOwner.UpdateRequestItemSize(self,5);
441	with FFirebirdClientAPI do
442	EncodeInteger(aValue,4,FBufPtr+1);
443	FDataType := dtInteger;
444	end;
445	end;
446
447	{Four byte integer - length byte}
448
449	procedure TParamBlockItem.SetAsInteger1(aValue: integer);
450	begin
451	with FParamData^ do
452	begin
453	if FBufLength <> 6 then
454	FOwner.UpdateRequestItemSize(self,6);
455	(FBufPtr+1)^ := $4;
456	with FFirebirdClientAPI do
457	EncodeInteger(aValue,4,FBufPtr+2);
458	FDataType := dtInteger1;
459	end;
460	end;
461
462	{Four byte integer - 2 byte length}
463
464	procedure TParamBlockItem.SetAsInteger2(aValue: integer);
465	begin
466	with FParamData^ do
467	begin
468	if FBufLength <> 7 then
469	FOwner.UpdateRequestItemSize(self,7);
470	with FFirebirdClientAPI do
471	begin
472	EncodeInteger(4,2,FBufPtr+1); {Encode length as two bytes}
473	EncodeInteger(aValue,4,FBufPtr+3);
474	end;
475	FDataType := dtInteger2
476	end;
477	end;
478
479	procedure TParamBlockItem.SetAsShortInteger(aValue: integer);
480	begin
481	with FParamData^ do
482	begin
483	if FBufLength <> 3 then
484	FOwner.UpdateRequestItemSize(self,3);
485	with FFirebirdClientAPI do
486	EncodeInteger(aValue,2,FBufPtr+1);
487	FDataType := dtShortInteger;
488	end;
489	end;
490
491	procedure TParamBlockItem.SetAsTinyInteger(aValue: integer);
492	begin
493	with FParamData^ do
494	begin
495	if FBufLength <> 2 then
496	FOwner.UpdateRequestItemSize(self,2);
497	with FFirebirdClientAPI do
498	EncodeInteger(aValue,1,FBufPtr+1);
499	FDataType := dtTinyInteger;
500	end;
501	end;
502
503	{Short string encoding}
504
505	procedure TParamBlockItem.SetAsString(aValue: AnsiString);
506	var len: integer;
507	begin
508	with FParamData^ do
509	begin
510	len := Length(aValue);
511	if len > 255 then
512	IBError(ibxStringTooLong,[aValue,255]);
513	FOwner.UpdateRequestItemSize(self,len+2);
514	(FBufPtr+1)^ := len;
515	if len > 0 then
516	Move(aValue[1],(FBufPtr+2)^,len);
517	FDataType := dtString;
518	end;
519	end;
520
521	{Long string up to 65535 encoding}
522
523	procedure TParamBlockItem.SetAsString2(aValue: AnsiString);
524	var len: integer;
525	begin
526	with FParamData^ do
527	begin
528	len := Length(aValue);
529	if len > 65535 then
530	IBError(ibxStringTooLong,[aValue,65535]);
531	FOwner.UpdateRequestItemSize(self,len + 3);
532	with FFirebirdClientAPI do
533	EncodeInteger(len,2,FBufPtr+1);
534	if len > 0 then
535	Move(aValue[1],(FBufPtr+3)^,len);
536	FDataType := dtString2;
537	end;
538	end;
539
540	{Zero byte terminated string encoding}
541
542	procedure TParamBlockItem.SetAsString0(aValue: AnsiString);
543	var len: integer;
544	begin
545	with FParamData^ do
546	begin
547	len := Length(aValue);
548	FOwner.UpdateRequestItemSize(self,len+2);
549	if len > 0 then
550	Move(aValue[1],(FBufPtr+1)^,len);
551	(FBufPtr+len+1)^ := 0;
552	FDataType := dtString0;
553	end;
554	end;
555
556	{ TParamBlock }
557
558	procedure TParamBlock.AdjustBuffer;
559	var P: PByte;
560	i: integer;
561	headerLen: integer;
562	begin
563	if FDataLength > FBufferSize then
564	begin
565	if Length(FItems) > 0 then
566	headerLen := FItems[0]^.FBufPtr - FBuffer
567	else
568	headerLen := 0;
569	FBufferSize := 2*FDataLength;
570	ReallocMem(FBuffer,FBufferSize);
571	P := FBuffer + headerLen;
572	for i := 0 to Length(FItems) - 1 do
573	begin
574	FItems[i]^.FBufPtr := P;
575	Inc(P,FItems[i]^.FBuflength);
576	end;
577	end;
578	end;
579
580	procedure TParamBlock.MoveBy(Item: PParamBlockItemData; delta: integer);
581	var src, dest: PByte;
582	i: integer;
583	begin
584	with Item^ do
585	begin
586	src := FBufptr;
587	dest := FBufptr + delta ;
588	if delta > 0 then
589	begin
590	for i := FBufLength - 1 downto 0 do
591	(dest +i)^ := (src+i)^;
592	end
593	else
594	begin
595	for i := 0 to FBufLength - 1 do
596	(dest +i)^ := (src+i)^;
597	end;
598	FBufPtr := FBufPtr + delta;
599	end;
600	end;
601
602	procedure TParamBlock.UpdateRequestItemSize(Item: TParamBlockItem;
603	NewSize: integer);
604	var i, delta: integer;
605	begin
606	delta := NewSize - Item.FParamData^.FBufLength;
607	Item.FParamData^.FBufLength := NewSize;
608	if delta > 0 then
609	begin
610	if FDataLength + delta > MaxBufferSize then
611	IBError(ibxeParamBufferOverflow,[nil]);
612	FDataLength := FDataLength + delta;
613	AdjustBuffer;
614	i := Length(FItems) - 1;
615	while i >= 0 do
616	begin
617	if FItems[i] = Item.FParamData then
618	break; {we're done}
619	Moveby(FItems[i],delta);
620	Dec(i);
621	end;
622	end
623	else
624	begin
625	i := 0;
626	while i < Length(FItems) do
627	begin
628	if FItems[i] = Item.FParamData then
629	break; {we're done}
630	Inc(i);
631	end;
632	Inc(i);
633	while i < Length(FItems) do
634	begin
635	Moveby(FItems[i],delta);
636	Inc(i);
637	end;
638	FDataLength := FDataLength + delta;
639	end;
640	end;
641
642	constructor TParamBlock.Create(api: TFBClientAPI);
643	begin
644	inherited Create;
645	FFirebirdClientAPI := api;
646	GetMem(FBuffer,128);
647	if FBuffer = nil then
648	OutOfMemoryError;
649	FBufferSize := 128;
650	FDataLength := 0;
651	end;
652
653	destructor TParamBlock.Destroy;
654	var i: integer;
655	begin
656	for i := 0 to Length(FItems) -1 do
657	dispose(FItems[i]);
658	Freemem(FBuffer);
659	inherited Destroy;
660	end;
661
662	function TParamBlock.getBuffer: PByte;
663	begin
664	if FDataLength = 0 then
665	Result := nil
666	else
667	Result := FBuffer;
668	end;
669
670	function TParamBlock.getDataLength: integer;
671	begin
672	Result := FDataLength
673	end;
674
675	function TParamBlock.AvailableBufferSpace: integer;
676	begin
677	Result := MaxBufferSize - FDataLength;
678	end;
679
680	function TParamBlock.Add(ParamType: byte): PParamBlockItemData;
681	begin
682	new(Result);
683	Result^.FBufPtr := FBuffer + FDataLength;
684	Result^.FBufLength := 1;
685	Result^.FBufPtr^ := ParamType;
686	Result^.FDataType := dtnone; {default}
687	Inc(FDataLength,1);
688	AdjustBuffer;
689	SetLength(FItems,Length(FItems)+1);
690	FItems[Length(FItems) - 1 ] := Result;
691	end;
692
693	function TParamBlock.Find(ParamType: byte): PParamBlockItemData;
694	var i: integer;
695	begin
696	Result := nil;
697	for i := 0 to getCount - 1 do
698	if byte(FItems[i]^.FBufPtr^) = ParamType then
699	begin
700	Result := FItems[i];
701	Exit;
702	end;
703	end;
704
705	function TParamBlock.GetItems(index: integer): PParamBlockItemData;
706	begin
707	if (index >= 0 ) and (index < Length(FItems)) then
708	Result := FItems[index]
709	else
710	IBError(ibxePBIndexError,[index]);
711	end;
712
713	function TParamBlock.getCount: integer;
714	begin
715	Result := Length(FItems);
716	end;
717
718	procedure TParamBlock.Remove(ParamType: byte);
719	var P: PParamBlockItemData;
720	i, j: integer;
721	begin
722	P := nil;
723	for i := 0 to getCount - 1 do
724	if byte(FItems[i]^.FBufPtr^) = ParamType then
725	begin
726	P := FItems[i];
727	for j := i + 1 to getCount - 1 do
728	begin
729	MoveBy(FItems[j],-P^.FBufLength);
730	FItems[j - 1] := FItems[j];
731	end;
732	FDataLength := FDataLength - P^.FBufLength;
733	dispose(P);
734	SetLength(FItems,Length(FItems)-1);
735	Exit;
736	end;
737	end;
738
739	procedure TParamBlock.PrintBuf;
740	var i: integer;
741	begin
742	write(ClassName,': ');
743	for i := 0 to getDataLength - 1 do
744	write(Format('%x ',[byte(FBuffer[i])]));
745	writeln
746	end;
747
748	{ TCustomParamBlock }
749
750	{$IFDEF FPC}
751	function TCustomParamBlock<_TItem, _IItem>.Add(ParamType: byte): _IItem;
752	var Item: PParamBlockItemData;
753	begin
754	Item := inherited Add(ParamType);
755	Result := _TItem.Create(self,Item);
756	end;
757
758	function TCustomParamBlock<_TItem, _IItem>.Find(ParamType: byte): _IItem;
759	var Item: PParamBlockItemData;
760	begin
761	Result := nil;
762	Item := inherited Find(ParamType);
763	if Item <> nil then
764	Result := _TItem.Create(self,Item);
765	end;
766
767	function TCustomParamBlock<_TItem, _IItem>.GetItems(index: integer): _IItem;
768	var Item: PParamBlockItemData;
769	begin
770	Item := inherited getItems(index);
771	Result := _TItem.Create(self,Item);
772	end;
773	{$ELSE}
774	function TCustomParamBlock<_TItem, _IItem>.Add(ParamType: byte): _IItem;
775	var Item: PParamBlockItemData;
776	Obj: TParamBlockItem;
777	begin
778	Item := inherited Add(ParamType);
779	Obj := TParamBlockItemClass(_TItem).Create(self,Item);
780	if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
781	IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
782	end;
783
784	function TCustomParamBlock<_TItem, _IItem>.Find(ParamType: byte): _IItem;
785	var Item: PParamBlockItemData;
786	Obj: TParamBlockItem;
787	begin
788	FillChar(Result,sizeof(Result),0); {workaround for older versions of Delphi}
789	Item := inherited Find(ParamType);
790	if Item <> nil then
791	begin
792	Obj := TParamBlockItemClass(_TItem).Create(self,Item);
793	if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
794	IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
795	end;
796	end;
797
798	function TCustomParamBlock<_TItem, _IItem>.GetItems(index: integer): _IItem;
799	var Item: PParamBlockItemData;
800	Obj: TParamBlockItem;
801	begin
802	Item := inherited getItems(index);
803	Obj := TParamBlockItemClass(_TItem).Create(self,Item);
804	if Obj.QueryInterface(GetTypeData(TypeInfo(_IItem))^.Guid,Result) <> 0 then
805	IBError(ibxeInterfaceNotSupported,[GuidToString(GetTypeData(TypeInfo(_IItem))^.Guid)]);
806	end;
807	{$ENDIF}
808
809	{ TDPB }
810
811	constructor TDPB.Create(api: TFBClientAPI);
812	begin
813	inherited Create(api);
814	FDataLength := 1;
815	FBuffer^ := isc_dpb_version1;
816	end;
817
818	{ TTPB }
819
820	constructor TTPB.Create(api: TFBClientAPI);
821	begin
822	inherited Create(api);
823	FDataLength := 1;
824	FBuffer^ := isc_tpb_version3;
825	end;
826
827	{ TSPB }
828
829	constructor TSPB.Create(api: TFBClientAPI);
830	begin
831	inherited Create(api);
832	FDataLength := 2;
833	FBuffer^ := isc_spb_version;
834	(FBuffer+1)^ := isc_spb_current_version;
835	end;
836
837	{ TBPB }
838
839	constructor TBPB.Create(api: TFBClientAPI);
840	begin
841	inherited Create(api);
842	FDataLength := 1;
843	FBuffer^ := isc_bpb_version1;
844	end;
845
846	end.
847