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

# 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     FB30Transaction, FBParamBlock;
43    
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     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 tony 56 TSDLBlock = class (TCustomParamBlock<TSDLItem,ISDLItem>, ISDL)
92 tony 45 public
93     constructor Create;
94     end;
95    
96     implementation
97    
98 tony 47 uses FBAttachment, FB30ClientAPI, FB30Statement;
99 tony 45
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 tony 113 '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 tony 45
118    
119     { TFB30ArrayMetaData }
120    
121     {Assemble the array descriptor from the System Tables}
122    
123     procedure TFB30ArrayMetaData.LoadMetaData(aAttachment: IAttachment;
124 tony 56 aTransaction: ITransaction; relationName, columnName: AnsiString);
125 tony 45 var stmt: IStatement;
126 tony 47 CharWidth: integer;
127 tony 45 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 tony 113 SQLParams[2].AsString := RelationName;
137     SQLParams[3].AsString := ColumnName;
138 tony 45 with OpenCursor do
139     if FetchNext then
140     begin
141     FillChar(FArrayDesc.array_desc_field_name,sizeof(FArrayDesc.array_desc_field_name),' ');
142 tony 47 FillChar(FArrayDesc.array_desc_relation_name,sizeof(FArrayDesc.array_desc_relation_name),' ');
143 tony 45 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 tony 56 FArrayDesc.array_desc_scale := Data[1].AsInteger;
147 tony 45 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 tony 60 FAttachment.CharSetID2CodePage(FCharSetID,FCodePage);
155 tony 47 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 tony 60 if HasDefaultCharSet and FAttachment.CharSetWidth(CharSetID,CharWidth) then
160 tony 56 FArrayDesc.array_desc_length := FArrayDesc.array_desc_length * CharWidth;
161 tony 47 end;
162 tony 45 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 tony 47 FSDL.Add(isc_sdl_relation).SetAsString(array_desc_relation_name);
221     FSDL.Add(isc_sdl_field).SetAsString(array_desc_field_name);
222 tony 45
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 tony 56 FBuffer^ := isc_sdl_version1;
304 tony 45 end;
305    
306     end.
307