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: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 4 months ago) by tony
Content type: text/x-pascal
File size: 10329 byte(s)
Log Message:
Release 2.3.2 committed

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