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

# User Rev Content
1 tony 45 (*
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 tony 56 {$IFDEF MSWINDOWS}
29     {$DEFINE WINDOWS}
30     {$ENDIF}
31 tony 45
32     {$IFDEF FPC}
33 tony 56 {$mode delphi}
34 tony 45 {$codepage UTF8}
35     {$interfaces COM}
36     {$ENDIF}
37    
38     interface
39    
40     uses
41     Classes, SysUtils, Firebird, IB, FBArray, IBHeader, FB30Attachment, FBClientAPI,
42 tony 263 FB30Transaction, FBParamBlock, FB30ClientAPI;
43 tony 45
44     type
45    
46 tony 56 ISDLItem = interface(IParameterBlockItem)
47     ['{a34b6064-5ae9-4fc1-85c3-f145f069b607}']
48 tony 45 procedure addByte(aValue: byte);
49     procedure addShortInteger(aValue: integer);
50     procedure SetAsShortInteger(aValue: integer);
51     procedure SetAsTinyInteger(aValue: integer);
52     end;
53    
54 tony 56 ISDL = interface(IParameterBlock<ISDLItem>)
55     ['{52ae1f5f-657b-4b14-81aa-7b3658454f4c}']
56 tony 45 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 tony 56 relationName, columnName: AnsiString); override;
66 tony 45 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 tony 263 FFirebird30ClientAPI: TFB30ClientAPI;
78 tony 45 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 tony 56 TSDLBlock = class (TCustomParamBlock<TSDLItem,ISDLItem>, ISDL)
93 tony 45 public
94 tony 263 constructor Create(api: TFBClientAPI);
95 tony 45 end;
96    
97     implementation
98    
99 tony 263 uses FBAttachment, FB30Statement;
100 tony 45
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 tony 113 '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 tony 45
119    
120     { TFB30ArrayMetaData }
121    
122     {Assemble the array descriptor from the System Tables}
123    
124     procedure TFB30ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
125 tony 56 aTransaction: ITransaction; relationName, columnName: AnsiString);
126 tony 45 var stmt: IStatement;
127 tony 47 CharWidth: integer;
128 tony 45 begin
129 tony 263 CharWidth := 0;
130 tony 45 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 tony 113 SQLParams[2].AsString := RelationName;
139     SQLParams[3].AsString := ColumnName;
140 tony 45 with OpenCursor do
141     if FetchNext then
142     begin
143     FillChar(FArrayDesc.array_desc_field_name,sizeof(FArrayDesc.array_desc_field_name),' ');
144 tony 47 FillChar(FArrayDesc.array_desc_relation_name,sizeof(FArrayDesc.array_desc_relation_name),' ');
145 tony 45 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 tony 56 FArrayDesc.array_desc_scale := Data[1].AsInteger;
149 tony 45 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 tony 60 FAttachment.CharSetID2CodePage(FCharSetID,FCodePage);
157 tony 47 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 tony 60 if HasDefaultCharSet and FAttachment.CharSetWidth(CharSetID,CharWidth) then
162 tony 56 FArrayDesc.array_desc_length := FArrayDesc.array_desc_length * CharWidth;
163 tony 47 end;
164 tony 45 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 tony 263 FSDL := TSDLBlock.Create(FFirebird30ClientAPI);
207 tony 45 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 tony 47 FSDL.Add(isc_sdl_relation).SetAsString(array_desc_relation_name);
223     FSDL.Add(isc_sdl_field).SetAsString(array_desc_field_name);
224 tony 45
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 tony 263 with FFirebird30ClientAPI do
254 tony 45 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 tony 263 with FFirebird30ClientAPI do
270 tony 45 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 tony 263 FFirebird30ClientAPI := aAttachment.Firebird30ClientAPI;
290 tony 45 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 tony 263 FFirebird30ClientAPI := aAttachment.Firebird30ClientAPI;
299 tony 45 end;
300    
301     { TSDLBlock }
302    
303 tony 263 constructor TSDLBlock.Create(api: TFBClientAPI);
304 tony 45 begin
305 tony 263 inherited Create(api);
306 tony 45 FDataLength := 1;
307 tony 56 FBuffer^ := isc_sdl_version1;
308 tony 45 end;
309    
310     end.
311