client/3.0/FB30Array.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 FB30Array;

{$IFDEF FPC}
{$mode objfpc}{$H+}
{$codepage UTF8}
{$interfaces COM}
{$ENDIF}

interface

uses
  Classes, SysUtils, Firebird, IB, FBArray, IBHeader, FB30Attachment, FBClientAPI,
  FB30Transaction, FBParamBlock;

type

  ISDLItem = interface
    function getParamType: byte;
    function getAsInteger: integer;
    function getAsString: string;
    function getAsByte: byte;
    procedure addByte(aValue: byte);
    procedure addShortInteger(aValue: integer);
    procedure setAsString(aValue: string);
    procedure setAsByte(aValue: byte);
    procedure SetAsInteger(aValue: integer);
    procedure SetAsShortInteger(aValue: integer);
    procedure SetAsTinyInteger(aValue: integer);
    property AsString: string read getAsString write setAsString;
    property AsByte: byte read getAsByte write setAsByte;
    property AsInteger: integer read getAsInteger write SetAsInteger;
  end;

  ISDL = interface
    function getCount: integer;
    function Add(ParamType: byte): ISDLItem;
    function getItems(index: integer): ISDLItem;
    function Find(ParamType: byte): ISDLItem;
    property Items[index: integer]: ISDLItem read getItems; default;
  end;

  { TFB30ArrayMetaData }

  TFB30ArrayMetaData = class(TFBArrayMetaData,IArrayMetaData)
  private
    FCharSetID: integer;
    FCodePage: TSystemCodePage;
  protected
    procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
                   relationName, columnName: string); override;
  public
    function GetCharSetID: cardinal; override;
    function GetCodePage: TSystemCodePage; override;
  end;

  { TFB30Array }

  TFB30Array = class(TFBArray,IArray)
  private
    FAttachmentIntf: Firebird.IAttachment;
    FTransactionIntf: Firebird.ITransaction;
    FSDL: ISDL;
  protected
    procedure AllocateBuffer; override;
    procedure InternalGetSlice; override;
    procedure InternalPutSlice(Force: boolean); override;
  public
    constructor Create(aAttachment: TFB30Attachment; aTransaction: TFB30Transaction; aField: IArrayMetaData); overload;
    constructor Create(aAttachment: TFB30Attachment; aTransaction: TFB30Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
 end;

  TSDLItem = class(TParamBlockItem,ISDLItem);

  { TSDLBlock }

  TSDLBlock = class (specialize TCustomParamBlock<TSDLItem,ISDLItem>, ISDL)
  public
    constructor Create;
  end;

implementation

uses FB30ClientAPI, FB30Statement;

const
  sGetArrayMetaData = 'Select F.RDB$FIELD_LENGTH, F.RDB$FIELD_SCALE, F.RDB$FIELD_TYPE, '+
                      'F.RDB$DIMENSIONS, FD.RDB$DIMENSION, FD.RDB$LOWER_BOUND, FD.RDB$UPPER_BOUND, '+
                      'F.RDB$CHARACTER_SET_ID '+
                      'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
                      'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE JOIN RDB$FIELD_DIMENSIONS FD '+
                      'On FD.RDB$FIELD_NAME = F.RDB$FIELD_NAME ' +
                      'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ? Order by FD.RDB$DIMENSION asc';


{ TFB30ArrayMetaData }

{Assemble the array descriptor from the System Tables}

procedure TFB30ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
  aTransaction: ITransaction; relationName, columnName: string);
var stmt: IStatement;
begin
  RelationName := AnsiUpperCase(RelationName);
  ColumnName := AnsiUpperCase(ColumnName);
  stmt := TFB30Statement.Create(aAttachment as TFB30Attachment,aTransaction,
                               sGetArrayMetaData ,aAttachment.GetSQLDialect);
  with stmt do
  begin
    SQLParams[0].AsString := RelationName;
    SQLParams[1].AsString := ColumnName;
    with OpenCursor do
    if FetchNext then
    begin
      FillChar(FArrayDesc.array_desc_field_name,sizeof(FArrayDesc.array_desc_field_name),' ');
      FillChar(FArrayDesc.array_desc_relation_name,sizeof(FArrayDesc.array_desc_field_name),' ');
      Move(columnName[1],FArrayDesc.array_desc_field_name,Length(columnName));
      Move(relationName[1],FArrayDesc.array_desc_relation_name,length(relationName));
      FArrayDesc.array_desc_length := Data[0].AsInteger;
      FArrayDesc.array_desc_scale := char(Data[1].AsInteger);
      FArrayDesc.array_desc_dtype := Data[2].AsInteger;
      FArrayDesc.array_desc_dimensions := Data[3].AsInteger;
      FArrayDesc.array_desc_flags := 0; {row major}
      FCharSetID := Data[7].AsInteger;
      if (FCharSetID > 1) and (aAttachment as TFB30Attachment).HasDefaultCharSet then
        FCharSetID := (aAttachment as TFB30Attachment).CharSetID;
      FCodePage := CP_NONE;
      FirebirdClientAPI.CharSetID2CodePage(FCharSetID,FCodePage);
      repeat
        with FArrayDesc.array_desc_bounds[Data[4].AsInteger] do
        begin
          array_bound_lower := Data[5].AsInteger;
          array_bound_upper := Data[6].AsInteger;
        end;
      until not FetchNext;
    end;
  end;
end;

function TFB30ArrayMetaData.GetCharSetID: cardinal;
begin
  Result := FCharSetID;
end;

function TFB30ArrayMetaData.GetCodePage: TSystemCodePage;
begin
  Result := FCodePage;
end;

{ TFB30Array }

procedure TFB30Array.AllocateBuffer;

  procedure AddVarInteger(aValue: integer);
  begin
    if (aValue >= -128) and (aValue <= 127) then
      FSDL.Add(isc_sdl_tiny_integer).SetAsTinyInteger(aValue)
    else
    if (aValue >= -32768) and (aValue <= 32767) then
      FSDL.Add(isc_sdl_short_integer).SetAsShortInteger(aValue)
    else
      FSDL.Add(isc_sdl_long_integer).SetAsInteger(aValue);
  end;

var i: integer;
    SDLItem: ISDLItem;
begin
  inherited AllocateBuffer;
  {Now set up the SDL}

  FSDL := TSDLBlock.Create;
  with GetArrayDesc^ do
  {The following is based on gen_SDL from Firebird src/dsql/array.cpp}
  begin
    SDLItem := FSDL.Add(isc_sdl_struct);
    SDLItem.SetAsByte(array_desc_dtype);

    case array_desc_dtype of
    blr_short,blr_long,
    blr_int64,blr_quad:
        SDLItem.AddByte(byte(array_desc_scale));

    blr_text,blr_cstring, blr_varying:
        SDLItem.addShortInteger(array_desc_length);
    end;

    FSDL.Add(isc_sdl_relation).SetAsString(GetTableName);
    FSDL.Add(isc_sdl_field).SetAsString(GetColumnName);

    for i := 0 to array_desc_dimensions - 1 do
    begin
      if array_desc_bounds[i].array_bound_lower = 1 then
        FSDL.Add(isc_sdl_do1).SetAsTinyInteger(i)
      else
      begin
        FSDL.Add(isc_sdl_do2).SetAsTinyInteger(i);
        AddVarInteger(array_desc_bounds[i].array_bound_lower);
      end;
      AddVarInteger(array_desc_bounds[i].array_bound_upper);
    end;

    SDLItem := FSDL.Add(isc_sdl_element);
    SDLItem.AddByte(1);
    SDLItem := FSDL.Add(isc_sdl_scalar);
    SDLItem.AddByte(0);
    SDLItem.AddByte(array_desc_dimensions);
    for i := 0 to array_desc_dimensions - 1 do
    begin
      SDLItem := FSDL.Add(isc_sdl_variable);
      SDLItem.AddByte(i);
    end;
    FSDL.Add(isc_sdl_eoc);
  end;
end;

procedure TFB30Array.InternalGetSlice;
begin
  with Firebird30ClientAPI do
  begin
    FAttachmentIntf.getSlice(StatusIntf,FTransactionIntf,
                          @FArrayID,
                          (FSDL as TSDLBlock).getDataLength,
                          BytePtr((FSDL as TSDLBlock).getBuffer),
                          0,nil,
                          FBufSize,BytePtr(FBuffer)
                          );
    Check4DataBaseError;
  end;
  SignalActivity;
end;

procedure TFB30Array.InternalPutSlice(Force: boolean);
begin
  with Firebird30ClientAPI do
  begin
    FAttachmentIntf.putSlice(StatusIntf,FTransactionIntf, @FArrayID,
                          (FSDL as TSDLBlock).getDataLength,
                          BytePtr((FSDL as TSDLBlock).getBuffer),
                          0,nil,
                          FBufSize,BytePtr(FBuffer)
                          );
    if not Force then
      Check4DataBaseError;
  end;
  SignalActivity;
end;

constructor TFB30Array.Create(aAttachment: TFB30Attachment;
  aTransaction: TFB30Transaction; aField: IArrayMetaData);
begin
  inherited Create(aAttachment,aTransaction,aField);
  FAttachmentIntf := aAttachment.AttachmentIntf;
  FTransactionIntf := aTransaction.TransactionIntf;
end;

constructor TFB30Array.Create(aAttachment: TFB30Attachment;
  aTransaction: TFB30Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
begin
  inherited Create(aAttachment,aTransaction,aField,ArrayID);
  FAttachmentIntf := aAttachment.AttachmentIntf;
  FTransactionIntf := aTransaction.TransactionIntf;
end;

{ TSDLBlock }

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

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	9482 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 FB30Array;
28
29			{$IFDEF FPC}
30			{$mode objfpc}{$H+}
31			{$codepage UTF8}
32			{$interfaces COM}
33			{$ENDIF}
34
35			interface
36
37			uses
38			Classes, SysUtils, Firebird, IB, FBArray, IBHeader, FB30Attachment, FBClientAPI,
39			FB30Transaction, FBParamBlock;
40
41			type
42
43			ISDLItem = interface
44			function getParamType: byte;
45			function getAsInteger: integer;
46			function getAsString: string;
47			function getAsByte: byte;
48			procedure addByte(aValue: byte);
49			procedure addShortInteger(aValue: integer);
50			procedure setAsString(aValue: string);
51			procedure setAsByte(aValue: byte);
52			procedure SetAsInteger(aValue: integer);
53			procedure SetAsShortInteger(aValue: integer);
54			procedure SetAsTinyInteger(aValue: integer);
55			property AsString: string read getAsString write setAsString;
56			property AsByte: byte read getAsByte write setAsByte;
57			property AsInteger: integer read getAsInteger write SetAsInteger;
58			end;
59
60			ISDL = interface
61			function getCount: integer;
62			function Add(ParamType: byte): ISDLItem;
63			function getItems(index: integer): ISDLItem;
64			function Find(ParamType: byte): ISDLItem;
65			property Items[index: integer]: ISDLItem read getItems; default;
66			end;
67
68			{ TFB30ArrayMetaData }
69
70			TFB30ArrayMetaData = class(TFBArrayMetaData,IArrayMetaData)
71			private
72			FCharSetID: integer;
73			FCodePage: TSystemCodePage;
74			protected
75			procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
76			relationName, columnName: string); override;
77			public
78			function GetCharSetID: cardinal; override;
79			function GetCodePage: TSystemCodePage; override;
80			end;
81
82			{ TFB30Array }
83
84			TFB30Array = class(TFBArray,IArray)
85			private
86			FAttachmentIntf: Firebird.IAttachment;
87			FTransactionIntf: Firebird.ITransaction;
88			FSDL: ISDL;
89			protected
90			procedure AllocateBuffer; override;
91			procedure InternalGetSlice; override;
92			procedure InternalPutSlice(Force: boolean); override;
93			public
94			constructor Create(aAttachment: TFB30Attachment; aTransaction: TFB30Transaction; aField: IArrayMetaData); overload;
95			constructor Create(aAttachment: TFB30Attachment; aTransaction: TFB30Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
96			end;
97
98			TSDLItem = class(TParamBlockItem,ISDLItem);
99
100			{ TSDLBlock }
101
102			TSDLBlock = class (specialize TCustomParamBlock<TSDLItem,ISDLItem>, ISDL)
103			public
104			constructor Create;
105			end;
106
107			implementation
108
109			uses FB30ClientAPI, FB30Statement;
110
111			const
112			sGetArrayMetaData = 'Select F.RDB$FIELD_LENGTH, F.RDB$FIELD_SCALE, F.RDB$FIELD_TYPE, '+
113			'F.RDB$DIMENSIONS, FD.RDB$DIMENSION, FD.RDB$LOWER_BOUND, FD.RDB$UPPER_BOUND, '+
114			'F.RDB$CHARACTER_SET_ID '+
115			'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
116			'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE JOIN RDB$FIELD_DIMENSIONS FD '+
117			'On FD.RDB$FIELD_NAME = F.RDB$FIELD_NAME ' +
118			'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ? Order by FD.RDB$DIMENSION asc';
119
120
121			{ TFB30ArrayMetaData }
122
123			{Assemble the array descriptor from the System Tables}
124
125			procedure TFB30ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
126			aTransaction: ITransaction; relationName, columnName: string);
127			var stmt: IStatement;
128			begin
129			RelationName := AnsiUpperCase(RelationName);
130			ColumnName := AnsiUpperCase(ColumnName);
131			stmt := TFB30Statement.Create(aAttachment as TFB30Attachment,aTransaction,
132			sGetArrayMetaData ,aAttachment.GetSQLDialect);
133			with stmt do
134			begin
135			SQLParams[0].AsString := RelationName;
136			SQLParams[1].AsString := ColumnName;
137			with OpenCursor do
138			if FetchNext then
139			begin
140			FillChar(FArrayDesc.array_desc_field_name,sizeof(FArrayDesc.array_desc_field_name),' ');
141			FillChar(FArrayDesc.array_desc_relation_name,sizeof(FArrayDesc.array_desc_field_name),' ');
142			Move(columnName[1],FArrayDesc.array_desc_field_name,Length(columnName));
143			Move(relationName[1],FArrayDesc.array_desc_relation_name,length(relationName));
144			FArrayDesc.array_desc_length := Data[0].AsInteger;
145			FArrayDesc.array_desc_scale := char(Data[1].AsInteger);
146			FArrayDesc.array_desc_dtype := Data[2].AsInteger;
147			FArrayDesc.array_desc_dimensions := Data[3].AsInteger;
148			FArrayDesc.array_desc_flags := 0; {row major}
149			FCharSetID := Data[7].AsInteger;
150			if (FCharSetID > 1) and (aAttachment as TFB30Attachment).HasDefaultCharSet then
151			FCharSetID := (aAttachment as TFB30Attachment).CharSetID;
152			FCodePage := CP_NONE;
153			FirebirdClientAPI.CharSetID2CodePage(FCharSetID,FCodePage);
154			repeat
155			with FArrayDesc.array_desc_bounds[Data[4].AsInteger] do
156			begin
157			array_bound_lower := Data[5].AsInteger;
158			array_bound_upper := Data[6].AsInteger;
159			end;
160			until not FetchNext;
161			end;
162			end;
163			end;
164
165			function TFB30ArrayMetaData.GetCharSetID: cardinal;
166			begin
167			Result := FCharSetID;
168			end;
169
170			function TFB30ArrayMetaData.GetCodePage: TSystemCodePage;
171			begin
172			Result := FCodePage;
173			end;
174
175			{ TFB30Array }
176
177			procedure TFB30Array.AllocateBuffer;
178
179			procedure AddVarInteger(aValue: integer);
180			begin
181			if (aValue >= -128) and (aValue <= 127) then
182			FSDL.Add(isc_sdl_tiny_integer).SetAsTinyInteger(aValue)
183			else
184			if (aValue >= -32768) and (aValue <= 32767) then
185			FSDL.Add(isc_sdl_short_integer).SetAsShortInteger(aValue)
186			else
187			FSDL.Add(isc_sdl_long_integer).SetAsInteger(aValue);
188			end;
189
190			var i: integer;
191			SDLItem: ISDLItem;
192			begin
193			inherited AllocateBuffer;
194			{Now set up the SDL}
195
196			FSDL := TSDLBlock.Create;
197			with GetArrayDesc^ do
198			{The following is based on gen_SDL from Firebird src/dsql/array.cpp}
199			begin
200			SDLItem := FSDL.Add(isc_sdl_struct);
201			SDLItem.SetAsByte(array_desc_dtype);
202
203			case array_desc_dtype of
204			blr_short,blr_long,
205			blr_int64,blr_quad:
206			SDLItem.AddByte(byte(array_desc_scale));
207
208			blr_text,blr_cstring, blr_varying:
209			SDLItem.addShortInteger(array_desc_length);
210			end;
211
212			FSDL.Add(isc_sdl_relation).SetAsString(GetTableName);
213			FSDL.Add(isc_sdl_field).SetAsString(GetColumnName);
214
215			for i := 0 to array_desc_dimensions - 1 do
216			begin
217			if array_desc_bounds[i].array_bound_lower = 1 then
218			FSDL.Add(isc_sdl_do1).SetAsTinyInteger(i)
219			else
220			begin
221			FSDL.Add(isc_sdl_do2).SetAsTinyInteger(i);
222			AddVarInteger(array_desc_bounds[i].array_bound_lower);
223			end;
224			AddVarInteger(array_desc_bounds[i].array_bound_upper);
225			end;
226
227			SDLItem := FSDL.Add(isc_sdl_element);
228			SDLItem.AddByte(1);
229			SDLItem := FSDL.Add(isc_sdl_scalar);
230			SDLItem.AddByte(0);
231			SDLItem.AddByte(array_desc_dimensions);
232			for i := 0 to array_desc_dimensions - 1 do
233			begin
234			SDLItem := FSDL.Add(isc_sdl_variable);
235			SDLItem.AddByte(i);
236			end;
237			FSDL.Add(isc_sdl_eoc);
238			end;
239			end;
240
241			procedure TFB30Array.InternalGetSlice;
242			begin
243			with Firebird30ClientAPI do
244			begin
245			FAttachmentIntf.getSlice(StatusIntf,FTransactionIntf,
246			@FArrayID,
247			(FSDL as TSDLBlock).getDataLength,
248			BytePtr((FSDL as TSDLBlock).getBuffer),
249			0,nil,
250			FBufSize,BytePtr(FBuffer)
251			);
252			Check4DataBaseError;
253			end;
254			SignalActivity;
255			end;
256
257			procedure TFB30Array.InternalPutSlice(Force: boolean);
258			begin
259			with Firebird30ClientAPI do
260			begin
261			FAttachmentIntf.putSlice(StatusIntf,FTransactionIntf, @FArrayID,
262			(FSDL as TSDLBlock).getDataLength,
263			BytePtr((FSDL as TSDLBlock).getBuffer),
264			0,nil,
265			FBufSize,BytePtr(FBuffer)
266			);
267			if not Force then
268			Check4DataBaseError;
269			end;
270			SignalActivity;
271			end;
272
273			constructor TFB30Array.Create(aAttachment: TFB30Attachment;
274			aTransaction: TFB30Transaction; aField: IArrayMetaData);
275			begin
276			inherited Create(aAttachment,aTransaction,aField);
277			FAttachmentIntf := aAttachment.AttachmentIntf;
278			FTransactionIntf := aTransaction.TransactionIntf;
279			end;
280
281			constructor TFB30Array.Create(aAttachment: TFB30Attachment;
282			aTransaction: TFB30Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
283			begin
284			inherited Create(aAttachment,aTransaction,aField,ArrayID);
285			FAttachmentIntf := aAttachment.AttachmentIntf;
286			FTransactionIntf := aTransaction.TransactionIntf;
287			end;
288
289			{ TSDLBlock }
290
291			constructor TSDLBlock.Create;
292			begin
293			inherited Create;
294			FDataLength := 1;
295			FBuffer^ := char(isc_sdl_version1);
296			end;
297
298			end.
299