ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/3.0/FB30Array.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 9892 byte(s)
Log Message:
Committing updates for Release R2-0-1

File Contents

# 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 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 FCodePage: TSystemCodePage;
73 protected
74 procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
75 relationName, columnName: string); override;
76 public
77 function GetCharSetID: cardinal; override;
78 function GetCodePage: TSystemCodePage; override;
79 end;
80
81 { TFB30Array }
82
83 TFB30Array = class(TFBArray,IArray)
84 private
85 FAttachmentIntf: Firebird.IAttachment;
86 FTransactionIntf: Firebird.ITransaction;
87 FSDL: ISDL;
88 protected
89 procedure AllocateBuffer; override;
90 procedure InternalGetSlice; override;
91 procedure InternalPutSlice(Force: boolean); override;
92 public
93 constructor Create(aAttachment: TFB30Attachment; aTransaction: TFB30Transaction; aField: IArrayMetaData); overload;
94 constructor Create(aAttachment: TFB30Attachment; aTransaction: TFB30Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
95 end;
96
97 TSDLItem = class(TParamBlockItem,ISDLItem);
98
99 { TSDLBlock }
100
101 TSDLBlock = class (specialize TCustomParamBlock<TSDLItem,ISDLItem>, ISDL)
102 public
103 constructor Create;
104 end;
105
106 implementation
107
108 uses FBAttachment, FB30ClientAPI, FB30Statement;
109
110 const
111 sGetArrayMetaData = 'Select F.RDB$FIELD_LENGTH, F.RDB$FIELD_SCALE, F.RDB$FIELD_TYPE, '+
112 'F.RDB$DIMENSIONS, FD.RDB$DIMENSION, FD.RDB$LOWER_BOUND, FD.RDB$UPPER_BOUND, '+
113 'F.RDB$CHARACTER_SET_ID '+
114 'From RDB$FIELDS F JOIN RDB$RELATION_FIELDS RF '+
115 'On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE JOIN RDB$FIELD_DIMENSIONS FD '+
116 'On FD.RDB$FIELD_NAME = F.RDB$FIELD_NAME ' +
117 'Where RF.RDB$RELATION_NAME = ? and RF.RDB$FIELD_NAME = ? Order by FD.RDB$DIMENSION asc';
118
119
120 { TFB30ArrayMetaData }
121
122 {Assemble the array descriptor from the System Tables}
123
124 procedure TFB30ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
125 aTransaction: ITransaction; relationName, columnName: string);
126 var stmt: IStatement;
127 CharWidth: integer;
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_relation_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 if (FArrayDesc.array_desc_dtype in [blr_text,blr_cstring, blr_varying]) and
155 (FCharSetID = 0) then {This really shouldn't be necessary - but it is :(}
156 with aAttachment as TFBAttachment do
157 begin
158 if HasDefaultCharSet and FirebirdClientAPI.CharSetWidth(CharSetID,CharWidth) then
159 FArrayDesc.array_desc_length *= CharWidth;
160 end;
161 repeat
162 with FArrayDesc.array_desc_bounds[Data[4].AsInteger] do
163 begin
164 array_bound_lower := Data[5].AsInteger;
165 array_bound_upper := Data[6].AsInteger;
166 end;
167 until not FetchNext;
168 end;
169 end;
170 end;
171
172 function TFB30ArrayMetaData.GetCharSetID: cardinal;
173 begin
174 Result := FCharSetID;
175 end;
176
177 function TFB30ArrayMetaData.GetCodePage: TSystemCodePage;
178 begin
179 Result := FCodePage;
180 end;
181
182 { TFB30Array }
183
184 procedure TFB30Array.AllocateBuffer;
185
186 procedure AddVarInteger(aValue: integer);
187 begin
188 if (aValue >= -128) and (aValue <= 127) then
189 FSDL.Add(isc_sdl_tiny_integer).SetAsTinyInteger(aValue)
190 else
191 if (aValue >= -32768) and (aValue <= 32767) then
192 FSDL.Add(isc_sdl_short_integer).SetAsShortInteger(aValue)
193 else
194 FSDL.Add(isc_sdl_long_integer).SetAsInteger(aValue);
195 end;
196
197 var i: integer;
198 SDLItem: ISDLItem;
199 begin
200 inherited AllocateBuffer;
201 {Now set up the SDL}
202
203 FSDL := TSDLBlock.Create;
204 with GetArrayDesc^ do
205 {The following is based on gen_SDL from Firebird src/dsql/array.cpp}
206 begin
207 SDLItem := FSDL.Add(isc_sdl_struct);
208 SDLItem.SetAsByte(array_desc_dtype);
209
210 case array_desc_dtype of
211 blr_short,blr_long,
212 blr_int64,blr_quad:
213 SDLItem.AddByte(byte(array_desc_scale));
214
215 blr_text,blr_cstring, blr_varying:
216 SDLItem.addShortInteger(array_desc_length);
217 end;
218
219 FSDL.Add(isc_sdl_relation).SetAsString(array_desc_relation_name);
220 FSDL.Add(isc_sdl_field).SetAsString(array_desc_field_name);
221
222 for i := 0 to array_desc_dimensions - 1 do
223 begin
224 if array_desc_bounds[i].array_bound_lower = 1 then
225 FSDL.Add(isc_sdl_do1).SetAsTinyInteger(i)
226 else
227 begin
228 FSDL.Add(isc_sdl_do2).SetAsTinyInteger(i);
229 AddVarInteger(array_desc_bounds[i].array_bound_lower);
230 end;
231 AddVarInteger(array_desc_bounds[i].array_bound_upper);
232 end;
233
234 SDLItem := FSDL.Add(isc_sdl_element);
235 SDLItem.AddByte(1);
236 SDLItem := FSDL.Add(isc_sdl_scalar);
237 SDLItem.AddByte(0);
238 SDLItem.AddByte(array_desc_dimensions);
239 for i := 0 to array_desc_dimensions - 1 do
240 begin
241 SDLItem := FSDL.Add(isc_sdl_variable);
242 SDLItem.AddByte(i);
243 end;
244 FSDL.Add(isc_sdl_eoc);
245 end;
246 end;
247
248 procedure TFB30Array.InternalGetSlice;
249 begin
250 with Firebird30ClientAPI do
251 begin
252 FAttachmentIntf.getSlice(StatusIntf,FTransactionIntf,
253 @FArrayID,
254 (FSDL as TSDLBlock).getDataLength,
255 BytePtr((FSDL as TSDLBlock).getBuffer),
256 0,nil,
257 FBufSize,BytePtr(FBuffer)
258 );
259 Check4DataBaseError;
260 end;
261 SignalActivity;
262 end;
263
264 procedure TFB30Array.InternalPutSlice(Force: boolean);
265 begin
266 with Firebird30ClientAPI do
267 begin
268 FAttachmentIntf.putSlice(StatusIntf,FTransactionIntf, @FArrayID,
269 (FSDL as TSDLBlock).getDataLength,
270 BytePtr((FSDL as TSDLBlock).getBuffer),
271 0,nil,
272 FBufSize,BytePtr(FBuffer)
273 );
274 if not Force then
275 Check4DataBaseError;
276 end;
277 SignalActivity;
278 end;
279
280 constructor TFB30Array.Create(aAttachment: TFB30Attachment;
281 aTransaction: TFB30Transaction; aField: IArrayMetaData);
282 begin
283 inherited Create(aAttachment,aTransaction,aField);
284 FAttachmentIntf := aAttachment.AttachmentIntf;
285 FTransactionIntf := aTransaction.TransactionIntf;
286 end;
287
288 constructor TFB30Array.Create(aAttachment: TFB30Attachment;
289 aTransaction: TFB30Transaction; aField: IArrayMetaData; ArrayID: TISC_QUAD);
290 begin
291 inherited Create(aAttachment,aTransaction,aField,ArrayID);
292 FAttachmentIntf := aAttachment.AttachmentIntf;
293 FTransactionIntf := aTransaction.TransactionIntf;
294 end;
295
296 { TSDLBlock }
297
298 constructor TSDLBlock.Create;
299 begin
300 inherited Create;
301 FDataLength := 1;
302 FBuffer^ := char(isc_sdl_version1);
303 end;
304
305 end.
306