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: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 9398 byte(s)
Log Message:
Committing updates for Trunk

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