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

  { TTPB }

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

  { TSPB }

  TSPB = class (TCustomParamBlock<TSPBItem,ISPBItem>, ISPB)
  public
   constructor Create;
  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;
  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 FirebirdClientAPI 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;
  FOwnerIntf := AOwner;
  FParamData := Data;
end;

function TParamBlockItem.getAsInteger: integer;
begin
  with FirebirdClientAPI, 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 FirebirdClientAPI 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 FirebirdClientAPI 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 FirebirdClientAPI 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 FirebirdClientAPI 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 FirebirdClientAPI 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 FirebirdClientAPI 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 FirebirdClientAPI 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 FirebirdClientAPI 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;
begin
  inherited Create;
  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;
begin
  inherited Create;
  FDataLength := 1;
  FBuffer^ := isc_dpb_version1;
end;

{ TTPB }

constructor TTPB.Create;
begin
  inherited Create;
  FDataLength := 1;
  FBuffer^ := isc_tpb_version3;
end;

{ TSPB }

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

{ TBPB }

constructor TBPB.Create;
begin
  inherited Create;
  FDataLength := 1;
  FBuffer^ := isc_bpb_version1;
end;

end.

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