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

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

implementation

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

const
  MaxBufferSize = 65535;

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