ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/3.0/FB30Array.pas
Revision: 379
Committed: Mon Jan 10 10:08:03 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 10731 byte(s)
Log Message:
set line ending property

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

Properties

Name Value
svn:eol-style native