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: 113
Committed: Thu Jan 18 14:37:59 2018 UTC (6 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 10084 byte(s)
Log Message:
Fixes Merged

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