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 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
Original Path:	*ibx/trunk/fbintf/client/FBParamBlock.pas*
File size:	16613 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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
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