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 FPC}
{$mode objfpc}{$H+}
{$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: PChar;
    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: PChar;
    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: PChar;
    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: string;
     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: string);
     procedure SetAsString2(aValue: string);
     procedure SetAsString0(aValue: string);
  end;

  { TCustomParamBlock }

  generic TCustomParamBlock<_TItem; _IItem> = class(TParamBlock)
  public
    function Add(ParamType: byte): _IItem;
    function Find(ParamType: byte): _IItem;
    function GetItems(index: integer): _IItem;
  end;

  { TDPBItem }

  TDPBItem = class(TParamBlockItem,IDPBItem);

  { TDPB }

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

  { TTPBItem }

  TTPBItem = class(TParamBlockItem,ITPBItem);

  { TTPB }

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

  { TSPBItem }

  TSPBItem = class(TParamBlockItem,ISPBItem);

  { TSPB }

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

  { TSRBItem }

  TSRBItem = class(TParamBlockItem,ISRBItem)
  public
    function ISRBItem.SetAsString = SetAsString2;
    function ISRBItem.SetAsByte = SetAsByte2;
  end;

  { TSRB }

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

  { TSQPBItem }

  TSQPBItem = class(TParamBlockItem,ISQPBItem)
  public
   function CopyFrom(source: TStream; count: integer): integer;
   procedure ISQPBItem.SetAsInteger = SetAsInteger2;
   procedure ISQPBItem.SetAsString = SetAsString2;
  end;

  { TSQPB }

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

  { TBPBItem }

  TBPBItem =  class(TParamBlockItem,IBPBItem)
  public
    procedure IBPBItem.SetAsInteger = SetAsInteger1;
  end;

  { TBPB }

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

implementation

uses FBMessages;

const
  MaxBufferSize = 65535;

{ TCustomParamBlock }

function TCustomParamBlock.Add(ParamType: byte): _IItem;
var Item: PParamBlockItemData;
begin
  Item := inherited Add(ParamType);
  Result := _TItem.Create(self,Item);
end;

function TCustomParamBlock.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.GetItems(index: integer): _IItem;
var Item: PParamBlockItemData;
begin
  Item := inherited getItems(index);
  Result := _TItem.Create(self,Item);
end;

{ 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)^ := chr(isc_info_end);
      if Result <> count then
        FOwner.UpdateRequestItemSize(self,Result + 4);
      FDataType := dtString2;
    end;
end;

{ TBPB }

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

{ 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: string;
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 := byte((FBufPtr+1)^);
      SetString(Result,FBufPtr+2,len);
    end;
  dtString2:
    begin
      with FirebirdClientAPI do
        len := DecodeInteger(FBufPtr+1,2);
      SetString(Result,FBufPtr+3,len);
    end;
  dtString0:
      Result := strpas(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: PChar;
begin
  with FParamData^ do
  begin
    P := FBufPtr + FBufLength;
    len := FBufLength + 1;
    FOwner.UpdateRequestItemSize(self,len);
    P^ := char(aValue)
  end;
end;

procedure TParamBlockItem.addShortInteger(aValue: integer);
var len: integer;
    P: PChar;
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)^ := chr(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)^ := chr(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)^ := chr(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: string);
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)^ := char(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: string);
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: string);
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: PChar;
    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: PChar;
  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 += 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 += 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 += 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: PChar;
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^ := char(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 FItems[i]^.FBufPtr^ = char(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 FItems[i]^.FBufPtr^ = char(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 -= 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;

{ TDPB }

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

{ TTPB }

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

{ TSPB }

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

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	16613 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	User	Rev	Content
1	tony	45	(*
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
29			{$IFDEF FPC}
30			{$mode objfpc}{$H+}
31			{$interfaces COM}
32			{$ENDIF}
33
34			interface
35
36			{Provides common handling for the DPB, TPB, SPB and Service Request Block (SRB)}
37
38			uses
39			Classes, SysUtils, IB, FBClientAPI, FBActivityMonitor;
40
41			type
42			TParamDataType = (dtString, dtString2, dtString0, dtByte, dtByte2, dtInteger, dtInteger1,
43			dtInteger2, dtShortInteger,dtTinyInteger,dtnone);
44
45			PParamBlockItemData = ^TParamBlockItemData;
46			TParamBlockItemData = record
47			{Describes a Clumplet in the buffer. FBufPtr always points to the clumplet id
48			the rest of the clumplet up to the FBufLength is data. The data format is
49			given by FDataType}
50			FBufPtr: PChar;
51			FBuflength: integer;
52			FDataType: TParamDataType;
53			end;
54
55			TParamBlockItem = class;
56
57			{ TParamBlock }
58
59			TParamBlock = class(TFBInterfacedObject)
60			private
61			FItems: array of PParamBlockItemData;
62			FBufferSize: integer;
63			procedure AdjustBuffer;
64			procedure MoveBy(Item: PParamBlockItemData; delta: integer);
65			procedure UpdateRequestItemSize(Item: TParamBlockItem; NewSize: integer);
66			protected
67			FBuffer: PChar;
68			FDataLength: integer;
69			function Add(ParamType: byte): PParamBlockItemData;
70			function Find(ParamType: byte): PParamBlockItemData;
71			function GetItems(index: integer): PParamBlockItemData;
72			public
73			constructor Create;
74			destructor Destroy; override;
75			function getBuffer: PChar;
76			function getDataLength: integer;
77			function AvailableBufferSpace: integer;
78
79			public
80			function getCount: integer;
81			procedure Remove(ParamType: byte);
82			procedure PrintBuf;
83			end;
84
85			{ TParamBlockItem }
86
87			TParamBlockItem = class(TFBInterfacedObject)
88			private
89			FOwner: TParamBlock;
90			FOwnerIntf: IUnknown;
91			FParamData: PParamBlockItemData;
92			protected
93			property ParamData: PParamBlockItemData read FParamData;
94			public
95			constructor Create(AOwner: TParamBlock; Data: PParamBlockItemData);
96			public
97			function getAsInteger: integer;
98			function getParamType: byte;
99			function getAsString: string;
100			function getAsByte: byte;
101			procedure addByte(aValue: byte);
102			procedure addShortInteger(aValue: integer);
103			procedure setAsByte(aValue: byte);
104			procedure setAsByte2(aValue: byte);
105			procedure SetAsInteger(aValue: integer);
106			procedure SetAsInteger1(aValue: integer);
107			procedure SetAsInteger2(aValue: integer);
108			procedure SetAsShortInteger(aValue: integer);
109			procedure SetAsTinyInteger(aValue: integer);
110			procedure SetAsString(aValue: string);
111			procedure SetAsString2(aValue: string);
112			procedure SetAsString0(aValue: string);
113			end;
114
115			{ TCustomParamBlock }
116
117			generic TCustomParamBlock<_TItem; _IItem> = class(TParamBlock)
118			public
119			function Add(ParamType: byte): _IItem;
120			function Find(ParamType: byte): _IItem;
121			function GetItems(index: integer): _IItem;
122			end;
123
124			{ TDPBItem }
125
126			TDPBItem = class(TParamBlockItem,IDPBItem);
127
128			{ TDPB }
129
130			TDPB = class (specialize TCustomParamBlock<TDPBItem,IDPBItem>, IDPB)
131			public
132			constructor Create;
133			end;
134
135			{ TTPBItem }
136
137			TTPBItem = class(TParamBlockItem,ITPBItem);
138
139			{ TTPB }
140
141			TTPB = class (specialize TCustomParamBlock<TTPBItem,ITPBItem>, ITPB)
142			public
143			constructor Create;
144			end;
145
146			{ TSPBItem }
147
148			TSPBItem = class(TParamBlockItem,ISPBItem);
149
150			{ TSPB }
151
152			TSPB = class (specialize TCustomParamBlock<TSPBItem,ISPBItem>, ISPB)
153			public
154			constructor Create;
155			end;
156
157			{ TSRBItem }
158
159			TSRBItem = class(TParamBlockItem,ISRBItem)
160			public
161			function ISRBItem.SetAsString = SetAsString2;
162			function ISRBItem.SetAsByte = SetAsByte2;
163			end;
164
165			{ TSRB }
166
167			TSRB = class (specialize TCustomParamBlock<TSRBItem,ISRBItem>, ISRB);
168
169			{ TSQPBItem }
170
171			TSQPBItem = class(TParamBlockItem,ISQPBItem)
172			public
173			function CopyFrom(source: TStream; count: integer): integer;
174			procedure ISQPBItem.SetAsInteger = SetAsInteger2;
175			procedure ISQPBItem.SetAsString = SetAsString2;
176			end;
177
178			{ TSQPB }
179
180			TSQPB = class (specialize TCustomParamBlock<TSQPBItem,ISQPBItem>, ISQPB);
181
182			{ TBPBItem }
183
184			TBPBItem = class(TParamBlockItem,IBPBItem)
185			public
186			procedure IBPBItem.SetAsInteger = SetAsInteger1;
187			end;
188
189			{ TBPB }
190
191			TBPB = class (specialize TCustomParamBlock<TBPBItem,IBPBItem>, IBPB)
192			public
193			constructor Create;
194			end;
195
196			implementation
197
198			uses FBMessages;
199
200			const
201			MaxBufferSize = 65535;
202
203			{ TCustomParamBlock }
204
205			function TCustomParamBlock.Add(ParamType: byte): _IItem;
206			var Item: PParamBlockItemData;
207			begin
208			Item := inherited Add(ParamType);
209			Result := _TItem.Create(self,Item);
210			end;
211
212			function TCustomParamBlock.Find(ParamType: byte): _IItem;
213			var Item: PParamBlockItemData;
214			begin
215			Result := nil;
216			Item := inherited Find(ParamType);
217			if Item <> nil then
218			Result := _TItem.Create(self,Item);
219			end;
220
221			function TCustomParamBlock.GetItems(index: integer): _IItem;
222			var Item: PParamBlockItemData;
223			begin
224			Item := inherited getItems(index);
225			Result := _TItem.Create(self,Item);
226			end;
227
228			{ TSQPBItem }
229
230			function TSQPBItem.CopyFrom(source: TStream; count: integer): integer;
231			begin
232			if count > (FOwner.AvailableBufferSpace - 4) then
233			count := FOwner.AvailableBufferSpace - 4;
234			with FParamData^ do
235			begin
236			FOwner.UpdateRequestItemSize(self,count + 4);
237			Result := source.Read((FBufPtr+3)^,count);
238			with FirebirdClientAPI do
239			EncodeInteger(Result,2,FBufPtr+1);
240			(FBufPtr+Result + 3)^ := chr(isc_info_end);
241			if Result <> count then
242			FOwner.UpdateRequestItemSize(self,Result + 4);
243			FDataType := dtString2;
244			end;
245			end;
246
247			{ TBPB }
248
249			constructor TBPB.Create;
250			begin
251			inherited Create;
252			FDataLength := 1;
253			FBuffer^ := char(isc_bpb_version1);
254			end;
255
256			{ TParamBlockItem }
257
258			constructor TParamBlockItem.Create(AOwner: TParamBlock;
259			Data: PParamBlockItemData);
260			begin
261			inherited Create;
262			FOwner := AOwner;
263			FOwnerIntf := AOwner;
264			FParamData := Data;
265			end;
266
267			function TParamBlockItem.getAsInteger: integer;
268			begin
269			with FirebirdClientAPI, FParamData^ do
270			case FDataType of
271			dtInteger:
272			Result := DecodeInteger(FBufPtr+1,4);
273			dtShortInteger:
274			Result := DecodeInteger(FBufPtr+1,2);
275			dtTinyInteger:
276			Result := DecodeInteger(FBufPtr+1,1);
277			dtInteger1:
278			Result := DecodeInteger(FBufPtr+2,2);
279			dtInteger2:
280			Result := DecodeInteger(FBufPtr+3,4);
281			else
282			IBError(ibxePBParamTypeError,[nil]);
283			end;
284			end;
285
286			function TParamBlockItem.getParamType: byte;
287			begin
288			Result := byte(FParamData^.FBufPtr^);
289			end;
290
291			function TParamBlockItem.getAsString: string;
292			var len: byte;
293			begin
294			Result := '';
295
296			with FParamData^ do
297			case FDataType of
298			dtInteger,
299			dtInteger1,
300			dtInteger2,
301			dtShortInteger,
302			dtTinyInteger:
303			Result := IntToStr(getAsInteger);
304			dtByte,
305			dtByte2:
306			Result := IntToStr(getAsByte);
307			dtString:
308			begin
309			len := byte((FBufPtr+1)^);
310			SetString(Result,FBufPtr+2,len);
311			end;
312			dtString2:
313			begin
314			with FirebirdClientAPI do
315			len := DecodeInteger(FBufPtr+1,2);
316			SetString(Result,FBufPtr+3,len);
317			end;
318			dtString0:
319			Result := strpas(FBufPtr+1);
320			else
321			IBError(ibxeOutputBlockTypeError,[nil]);
322			end;
323			end;
324
325			function TParamBlockItem.getAsByte: byte;
326			begin
327			with FParamData^ do
328			if FDataType = dtByte then
329			Result := byte((FBufPtr+2)^)
330			else
331			if FDataType = dtByte2 then
332			Result := byte((FBufPtr+1)^)
333			else
334			IBError(ibxePBParamTypeError,[nil]);
335			end;
336
337			procedure TParamBlockItem.addByte(aValue: byte);
338			var len: integer;
339			P: PChar;
340			begin
341			with FParamData^ do
342			begin
343			P := FBufPtr + FBufLength;
344			len := FBufLength + 1;
345			FOwner.UpdateRequestItemSize(self,len);
346			P^ := char(aValue)
347			end;
348			end;
349
350			procedure TParamBlockItem.addShortInteger(aValue: integer);
351			var len: integer;
352			P: PChar;
353			begin
354			with FParamData^ do
355			begin
356			P := FBufPtr + FBufLength;
357			len := FBufLength + 2;
358			FOwner.UpdateRequestItemSize(self,len);
359			with FirebirdClientAPI do
360			EncodeInteger(aValue,2,P);
361			end;
362			end;
363
364			procedure TParamBlockItem.setAsByte(aValue: byte);
365			begin
366			with FParamData^ do
367			begin
368			if FBufLength <> 3 then
369			FOwner.UpdateRequestItemSize(self,3);
370			FDataType := dtByte;
371			(FBufPtr+1)^ := #1;
372			(FBufPtr+2)^ := chr(aValue);
373			end;
374			end;
375
376			procedure TParamBlockItem.setAsByte2(aValue: byte);
377			begin
378			with FParamData^ do
379			begin
380			if FBufLength <> 2 then
381			FOwner.UpdateRequestItemSize(self,2);
382			FDataType := dtByte2;
383			(FBufPtr+1)^ := chr(aValue);
384			end;
385			end;
386
387			{Four byte integer - no length}
388
389			procedure TParamBlockItem.SetAsInteger(aValue: integer);
390			begin
391			with FParamData^ do
392			begin
393			if FBufLength <> 5 then
394			FOwner.UpdateRequestItemSize(self,5);
395			with FirebirdClientAPI do
396			EncodeInteger(aValue,4,FBufPtr+1);
397			FDataType := dtInteger;
398			end;
399			end;
400
401			{Four byte integer - length byte}
402
403			procedure TParamBlockItem.SetAsInteger1(aValue: integer);
404			begin
405			with FParamData^ do
406			begin
407			if FBufLength <> 6 then
408			FOwner.UpdateRequestItemSize(self,6);
409			(FBufPtr+1)^ := chr(4);
410			with FirebirdClientAPI do
411			EncodeInteger(aValue,4,FBufPtr+2);
412			FDataType := dtInteger1;
413			end;
414			end;
415
416			{Four byte integer - 2 byte length}
417
418			procedure TParamBlockItem.SetAsInteger2(aValue: integer);
419			begin
420			with FParamData^ do
421			begin
422			if FBufLength <> 7 then
423			FOwner.UpdateRequestItemSize(self,7);
424			with FirebirdClientAPI do
425			begin
426			EncodeInteger(4,2,FBufPtr+1); {Encode length as two bytes}
427			EncodeInteger(aValue,4,FBufPtr+3);
428			end;
429			FDataType := dtInteger2
430			end;
431			end;
432
433			procedure TParamBlockItem.SetAsShortInteger(aValue: integer);
434			begin
435			with FParamData^ do
436			begin
437			if FBufLength <> 3 then
438			FOwner.UpdateRequestItemSize(self,3);
439			with FirebirdClientAPI do
440			EncodeInteger(aValue,2,FBufPtr+1);
441			FDataType := dtShortInteger;
442			end;
443			end;
444
445			procedure TParamBlockItem.SetAsTinyInteger(aValue: integer);
446			begin
447			with FParamData^ do
448			begin
449			if FBufLength <> 2 then
450			FOwner.UpdateRequestItemSize(self,2);
451			with FirebirdClientAPI do
452			EncodeInteger(aValue,1,FBufPtr+1);
453			FDataType := dtTinyInteger;
454			end;
455			end;
456
457			{Short string encoding}
458
459			procedure TParamBlockItem.SetAsString(aValue: string);
460			var len: integer;
461			begin
462			with FParamData^ do
463			begin
464			len := Length(aValue);
465			if len > 255 then
466			IBError(ibxStringTooLong,[aValue,255]);
467			FOwner.UpdateRequestItemSize(self,len+2);
468			(FBufPtr+1)^ := char(len);
469			if len > 0 then
470			Move(aValue[1],(FBufPtr+2)^,len);
471			FDataType := dtString;
472			end;
473			end;
474
475			{Long string up to 65535 encoding}
476
477			procedure TParamBlockItem.SetAsString2(aValue: string);
478			var len: integer;
479			begin
480			with FParamData^ do
481			begin
482			len := Length(aValue);
483			if len > 65535 then
484			IBError(ibxStringTooLong,[aValue,65535]);
485			FOwner.UpdateRequestItemSize(self,len + 3);
486			with FirebirdClientAPI do
487			EncodeInteger(len,2,FBufPtr+1);
488			if len > 0 then
489			Move(aValue[1],(FBufPtr+3)^,len);
490			FDataType := dtString2;
491			end;
492			end;
493
494			{Zero byte terminated string encoding}
495
496			procedure TParamBlockItem.SetAsString0(aValue: string);
497			var len: integer;
498			begin
499			with FParamData^ do
500			begin
501			len := Length(aValue);
502			FOwner.UpdateRequestItemSize(self,len+2);
503			if len > 0 then
504			Move(aValue[1],(FBufPtr+1)^,len);
505			(FBufPtr+len+1)^ := #0;
506			FDataType := dtString0;
507			end;
508			end;
509
510			{ TParamBlock }
511
512			procedure TParamBlock.AdjustBuffer;
513			var P: PChar;
514			i: integer;
515			headerLen: integer;
516			begin
517			if FDataLength > FBufferSize then
518			begin
519			if Length(FItems) > 0 then
520			headerLen := FItems[0]^.FBufPtr - FBuffer
521			else
522			headerLen := 0;
523			FBufferSize := 2*FDataLength;
524			ReallocMem(FBuffer,FBufferSize);
525			P := FBuffer + headerLen;
526			for i := 0 to Length(FItems) - 1 do
527			begin
528			FItems[i]^.FBufPtr := P;
529			Inc(P,FItems[i]^.FBuflength);
530			end;
531			end;
532			end;
533
534			procedure TParamBlock.MoveBy(Item: PParamBlockItemData; delta: integer);
535			var src, dest: PChar;
536			i: integer;
537			begin
538			with Item^ do
539			begin
540			src := FBufptr;
541			dest := FBufptr + delta ;
542			if delta > 0 then
543			begin
544			for i := FBufLength - 1 downto 0 do
545			(dest +i)^ := (src+i)^;
546			end
547			else
548			begin
549			for i := 0 to FBufLength - 1 do
550			(dest +i)^ := (src+i)^;
551			end;
552			FBufPtr += delta;
553			end;
554			end;
555
556			procedure TParamBlock.UpdateRequestItemSize(Item: TParamBlockItem;
557			NewSize: integer);
558			var i, delta: integer;
559			begin
560			delta := NewSize - Item.FParamData^.FBufLength;
561			Item.FParamData^.FBufLength := NewSize;
562			if delta > 0 then
563			begin
564			if FDataLength + delta > MaxBufferSize then
565			IBError(ibxeParamBufferOverflow,[nil]);
566			FDataLength += delta;
567			AdjustBuffer;
568			i := Length(FItems) - 1;
569			while i >= 0 do
570			begin
571			if FItems[i] = Item.FParamData then
572			break; {we're done}
573			Moveby(FItems[i],delta);
574			Dec(i);
575			end;
576			end
577			else
578			begin
579			i := 0;
580			while i < Length(FItems) do
581			begin
582			if FItems[i] = Item.FParamData then
583			break; {we're done}
584			Inc(i);
585			end;
586			Inc(i);
587			while i < Length(FItems) do
588			begin
589			Moveby(FItems[i],delta);
590			Inc(i);
591			end;
592			FDataLength += delta;
593			end;
594			end;
595
596			constructor TParamBlock.Create;
597			begin
598			inherited Create;
599			GetMem(FBuffer,128);
600			if FBuffer = nil then
601			OutOfMemoryError;
602			FBufferSize := 128;
603			FDataLength := 0;
604			end;
605
606			destructor TParamBlock.Destroy;
607			var i: integer;
608			begin
609			for i := 0 to Length(FItems) -1 do
610			dispose(FItems[i]);
611			Freemem(FBuffer);
612			inherited Destroy;
613			end;
614
615			function TParamBlock.getBuffer: PChar;
616			begin
617			if FDataLength = 0 then
618			Result := nil
619			else
620			Result := FBuffer;
621			end;
622
623			function TParamBlock.getDataLength: integer;
624			begin
625			Result := FDataLength
626			end;
627
628			function TParamBlock.AvailableBufferSpace: integer;
629			begin
630			Result := MaxBufferSize - FDataLength;
631			end;
632
633			function TParamBlock.Add(ParamType: byte): PParamBlockItemData;
634			begin
635			new(Result);
636			Result^.FBufPtr := FBuffer + FDataLength;
637			Result^.FBufLength := 1;
638			Result^.FBufPtr^ := char(ParamType);
639			Result^.FDataType := dtnone; {default}
640			Inc(FDataLength,1);
641			AdjustBuffer;
642			SetLength(FItems,Length(FItems)+1);
643			FItems[Length(FItems) - 1 ] := Result;
644			end;
645
646			function TParamBlock.Find(ParamType: byte): PParamBlockItemData;
647			var i: integer;
648			begin
649			Result := nil;
650			for i := 0 to getCount - 1 do
651			if FItems[i]^.FBufPtr^ = char(ParamType) then
652			begin
653			Result := FItems[i];
654			Exit;
655			end;
656			end;
657
658			function TParamBlock.GetItems(index: integer): PParamBlockItemData;
659			begin
660			if (index >= 0 ) and (index < Length(FItems)) then
661			Result := FItems[index]
662			else
663			IBError(ibxePBIndexError,[index]);
664			end;
665
666			function TParamBlock.getCount: integer;
667			begin
668			Result := Length(FItems);
669			end;
670
671			procedure TParamBlock.Remove(ParamType: byte);
672			var P: PParamBlockItemData;
673			i, j: integer;
674			begin
675			P := nil;
676			for i := 0 to getCount - 1 do
677			if FItems[i]^.FBufPtr^ = char(ParamType) then
678			begin
679			P := FItems[i];
680			for j := i + 1 to getCount - 1 do
681			begin
682			MoveBy(FItems[j],-P^.FBufLength);
683			FItems[j - 1] := FItems[j];
684			end;
685			FDataLength -= P^.FBufLength;
686			dispose(P);
687			SetLength(FItems,Length(FItems)-1);
688			Exit;
689			end;
690			end;
691
692			procedure TParamBlock.PrintBuf;
693			var i: integer;
694			begin
695			write(ClassName,': ');
696			for i := 0 to getDataLength - 1 do
697			write(Format('%x ',[byte(FBuffer[i])]));
698			writeln
699			end;
700
701			{ TDPB }
702
703			constructor TDPB.Create;
704			begin
705			inherited Create;
706			FDataLength := 1;
707			FBuffer^ := char(isc_dpb_version1);
708			end;
709
710			{ TTPB }
711
712			constructor TTPB.Create;
713			begin
714			inherited Create;
715			FDataLength := 1;
716			FBuffer^ := char(isc_tpb_version3);
717			end;
718
719			{ TSPB }
720
721			constructor TSPB.Create;
722			begin
723			inherited Create;
724			FDataLength := 2;
725			FBuffer^ := char(isc_spb_version);
726			(FBuffer+1)^ := char(isc_spb_current_version);
727			end;
728
729			end.
730