ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBArray.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 34327 byte(s)
Log Message:
Updated for IBX 4 release

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 FBArray;
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 tony 315 Classes, SysUtils, IBHeader, IB, FBTransaction,
42     FBSQLData, FBClientAPI, IBExternals, FBActivityMonitor, FmtBCD;
43 tony 45
44     (*
45    
46     COMMENTS (copied from IBPP)
47    
48     1)
49     For an array column of type CHAR(X), the internal type returned or expected is blr_text.
50     In such case, the byte array received or submitted to get/put_slice is formatted in
51     elements of X bytes, which correspond to what is reported in array_desc_length.
52     The elements are not '\0' terminated but are right-padded with spaces ' '.
53    
54     2)
55     For an array column of type VARCHAR(X), the internal type is blr_varying.
56     The underlying format is rather curious and different than what is used in XSQLDA.
57     The element size is reported in array_desc_length as X.
58     Yet each element of the byte array is expected to be of size X+2 (just as if we were
59     to stuff a short in the first 2 bytes to store the length (as is done with XSQLDA).
60     No. The string of X characters maximum has to be stored in the chunks of X+2 bytes as
61     a zero-terminated c-string. Note that the buffer is indeed one byte too large.
62     Internally, the API probably convert in-place in these chunks the zero-terminated string
63     to a variable-size string with a short in front and the string data non zero-terminated
64     behind.
65    
66     *)
67    
68     type
69     TFBArray = class;
70    
71     { TFBArrayElement }
72    
73     TFBArrayElement = class(TSQLDataItem)
74     private
75 tony 56 FBufPtr: PByte;
76 tony 45 FArray: TFBArray;
77     protected
78 tony 315 function GetAttachment: IAttachment; override;
79 tony 45 function GetSQLDialect: integer; override;
80     procedure Changing; override;
81     procedure Changed; override;
82 tony 56 function SQLData: PByte; override;
83 tony 45 function GetDataLength: cardinal; override;
84     function GetCodePage: TSystemCodePage; override;
85 tony 47 function getCharSetID: cardinal; override;
86 tony 45 procedure SetDataLength(len: cardinal); override;
87     procedure SetSQLType(aValue: cardinal); override;
88     public
89 tony 56 constructor Create(anArray: TFBArray; P: PByte);
90 tony 45 function GetSQLType: cardinal; override;
91 tony 56 function GetName: AnsiString; override;
92 tony 45 function GetScale: integer; override;
93     function GetSize: integer;
94 tony 309 function GetCharSetWidth: integer; override;
95 tony 56 function GetAsString: AnsiString; override;
96 tony 45 procedure SetAsLong(Value: Long); override;
97     procedure SetAsShort(Value: Short); override;
98     procedure SetAsInt64(Value: Int64); override;
99 tony 56 procedure SetAsString(Value: AnsiString); override;
100 tony 45 procedure SetAsDouble(Value: Double); override;
101     procedure SetAsFloat(Value: Float); override;
102     procedure SetAsCurrency(Value: Currency); override;
103 tony 315 procedure SetAsBcd(aValue: tBCD); override;
104 tony 45 end;
105    
106     { TFBArrayMetaData }
107    
108     TFBArrayMetaData = class(TFBInterfacedObject,IArrayMetaData)
109 tony 47 private
110     function GetDType(SQLType: cardinal): UChar;
111 tony 45 protected
112     FArrayDesc: TISC_ARRAY_DESC;
113 tony 47 FCharSetID: integer;
114 tony 60 FAttachment: IAttachment;
115 tony 45 procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
116 tony 56 relationName, columnName: AnsiString); virtual; abstract;
117 tony 45 function NumOfElements: integer;
118     public
119     constructor Create(aAttachment: IAttachment; aTransaction: ITransaction;
120 tony 56 relationName, columnName: AnsiString); overload;
121 tony 60 constructor Create(aAttachment: IAttachment;SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
122 tony 47 Scale: integer; size: cardinal; charSetID: cardinal;
123     dimensions: cardinal; bounds: TArrayBounds); overload;
124 tony 45 function GetCodePage: TSystemCodePage; virtual; abstract;
125    
126     public
127     {IArrayMetaData}
128     function GetSQLType: cardinal;
129 tony 56 function GetSQLTypeName: AnsiString;
130 tony 45 function GetScale: integer;
131     function GetSize: cardinal;
132     function GetCharSetID: cardinal; virtual; abstract;
133 tony 309 function GetCharSetWidth: integer; virtual; abstract;
134 tony 56 function GetTableName: AnsiString;
135     function GetColumnName: AnsiString;
136 tony 45 function GetDimensions: integer;
137     function GetBounds: TArrayBounds;
138     end;
139    
140    
141     { TFBArray }
142    
143 tony 315 TFBArray = class(TActivityReporter,IArray,ITransactionUser)
144 tony 45 private
145 tony 263 FFirebirdClientAPI: TFBClientAPI;
146 tony 45 FMetaData: IArrayMetaData;
147     FIsNew: boolean;
148     FLoaded: boolean;
149     FModified: boolean;
150     FAttachment: IAttachment;
151     FTransactionIntf: ITransaction;
152     FTransactionSeqNo: integer;
153     FSQLDialect: integer;
154     FOffsets: array of integer;
155     FElement: TFBArrayElement;
156     FElementIntf: IUnknown;
157     FElementSize: integer;
158     FEventHandlers: array of TArrayEventHandler;
159     procedure GetArraySlice;
160     procedure PutArraySlice(Force: boolean=false);
161 tony 56 function GetOffset(index: array of integer): PByte;
162 tony 45 function GetDataLength: short;
163     protected
164 tony 56 FBuffer: PByte;
165 tony 45 FBufSize: ISC_LONG;
166     FArrayID: TISC_QUAD;
167     procedure AllocateBuffer; virtual;
168 tony 291 procedure Changing; virtual;
169     procedure Changed; virtual;
170 tony 45 function GetArrayDesc: PISC_ARRAY_DESC;
171     procedure InternalGetSlice; virtual; abstract;
172     procedure InternalPutSlice(Force: boolean); virtual; abstract;
173     public
174     constructor Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
175     aField: IArrayMetaData); overload;
176     constructor Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
177     aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
178     destructor Destroy; override;
179     function GetSQLDialect: integer;
180 tony 315
181     public
182     {ITransactionUser}
183 tony 45 procedure TransactionEnding(aTransaction: ITransaction; Force: boolean);
184    
185     public
186     {IArrayMetaData}
187     function GetSQLType: cardinal;
188 tony 56 function GetSQLTypeName: AnsiString;
189 tony 45 function GetScale: integer;
190     function GetSize: cardinal;
191     function GetCharSetID: cardinal;
192 tony 309 function GetCharSetWidth: integer;
193 tony 56 function GetTableName: AnsiString;
194     function GetColumnName: AnsiString;
195 tony 45 function GetDimensions: integer;
196     function GetBounds: TArrayBounds;
197     {IArray}
198     function GetArrayID: TISC_QUAD;
199     procedure Clear;
200     function IsEmpty: boolean;
201     procedure PreLoad;
202     procedure CancelChanges;
203     procedure SaveChanges;
204     function GetAsInteger(index: array of integer): integer;
205     function GetAsBoolean(index: array of integer): boolean;
206     function GetAsCurrency(index: array of integer): Currency;
207     function GetAsInt64(index: array of integer): Int64;
208 tony 315 function GetAsDateTime(index: array of integer): TDateTime; overload;
209     procedure GetAsDateTime(index: array of integer; var aDateTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID); overload;
210     procedure GetAsDateTime(index: array of integer; var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString); overload;
211     procedure GetAsTime(index: array of integer; var aTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime); overload;
212     procedure GetAsTime(index: array of integer; var aTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime); overload;
213     function GetAsUTCDateTime(index: array of integer): TDateTime;
214 tony 45 function GetAsDouble(index: array of integer): Double;
215     function GetAsFloat(index: array of integer): Float;
216     function GetAsLong(index: array of integer): Long;
217     function GetAsShort(index: array of integer): Short;
218 tony 56 function GetAsString(index: array of integer): AnsiString;
219 tony 45 function GetAsVariant(index: array of integer): Variant;
220 tony 315 function GetAsBCD(index: array of integer): tBCD;
221 tony 45 procedure SetAsInteger(index: array of integer; AValue: integer);
222     procedure SetAsBoolean(index: array of integer; AValue: boolean);
223     procedure SetAsCurrency(index: array of integer; Value: Currency);
224     procedure SetAsInt64(index: array of integer; Value: Int64);
225     procedure SetAsDate(index: array of integer; Value: TDateTime);
226     procedure SetAsLong(index: array of integer; Value: Long);
227 tony 315 procedure SetAsTime(index: array of integer; Value: TDateTime); overload;
228     procedure SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
229     procedure SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime; aTimeZone: AnsiString); overload;
230     procedure SetAsDateTime(index: array of integer; Value: TDateTime); overload;
231     procedure SetAsDateTime(index: array of integer; aValue: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
232     procedure SetAsDateTime(index: array of integer; aValue: TDateTime; aTimeZone: AnsiString); overload;
233     procedure SetAsUTCDateTime(index: array of integer; aUTCTime: TDateTime);
234 tony 45 procedure SetAsDouble(index: array of integer; Value: Double);
235     procedure SetAsFloat(index: array of integer; Value: Float);
236     procedure SetAsShort(index: array of integer; Value: Short);
237 tony 56 procedure SetAsString(index: array of integer; Value: AnsiString);
238 tony 45 procedure SetAsVariant(index: array of integer; Value: Variant);
239 tony 315 procedure SetAsBcd(index: array of integer; aValue: tBCD);
240 tony 45 procedure SetBounds(dim, UpperBound, LowerBound: integer);
241     function GetAttachment: IAttachment;
242     function GetTransaction: ITransaction;
243     procedure AddEventHandler(Handler: TArrayEventHandler);
244     procedure RemoveEventHandler(Handler: TArrayEventHandler);
245     end;
246    
247     implementation
248    
249     uses FBMessages;
250    
251     { TFBArrayElement }
252    
253 tony 315 function TFBArrayElement.GetAttachment: IAttachment;
254     begin
255     Result := FArray.GetAttachment;
256     end;
257    
258 tony 45 function TFBArrayElement.GetSQLDialect: integer;
259     begin
260     Result := FArray.GetSQLDialect;
261     end;
262    
263     procedure TFBArrayElement.Changing;
264     begin
265     inherited Changing;
266     FArray.Changing;
267     end;
268    
269     procedure TFBArrayElement.Changed;
270     begin
271     inherited Changed;
272     FArray.Changed;
273     end;
274    
275 tony 56 function TFBArrayElement.SQLData: PByte;
276 tony 45 begin
277     Result := FBufPtr;
278     end;
279    
280     function TFBArrayElement.GetDataLength: cardinal;
281     begin
282     Result := FArray.GetDataLength
283     end;
284    
285     function TFBArrayElement.GetCodePage: TSystemCodePage;
286     begin
287     Result := (FArray.FMetaData as TFBArrayMetaData).GetCodePage;
288     end;
289    
290 tony 47 function TFBArrayElement.getCharSetID: cardinal;
291     begin
292     Result := (FArray.FMetaData as TFBArrayMetaData).GetCharSetID;
293     end;
294    
295 tony 45 procedure TFBArrayElement.SetDataLength(len: cardinal);
296     begin
297     if len > GetDataLength then
298     IBError(ibxeArrayElementOverFlow,[nil]);
299     end;
300    
301 tony 56 constructor TFBArrayElement.Create(anArray: TFBArray; P: PByte);
302 tony 45 begin
303 tony 263 inherited Create(anArray.FFirebirdClientAPI);
304 tony 45 FArray := anArray;
305     FBufPtr := P;
306     end;
307    
308     function TFBArrayElement.GetSQLType: cardinal;
309     begin
310     Result := FArray.FMetaData.GetSQLType;
311     end;
312    
313 tony 56 function TFBArrayElement.GetName: AnsiString;
314 tony 45 begin
315     Result := FArray.FMetaData.GetColumnName;
316     end;
317    
318     function TFBArrayElement.GetScale: integer;
319     begin
320     Result := FArray.FMetaData.GetScale;
321     end;
322    
323     function TFBArrayElement.GetSize: integer;
324     begin
325     Result := GetDataLength;
326     end;
327    
328 tony 309 function TFBArrayElement.GetCharSetWidth: integer;
329     begin
330     Result := FArray.FMetaData.GetCharSetWidth;
331     end;
332    
333 tony 56 function TFBArrayElement.GetAsString: AnsiString;
334 tony 45 var rs: RawByteString;
335     begin
336     case GetSQLType of
337     SQL_VARYING:
338     begin
339 tony 56 rs := strpas(PAnsiChar(FBufPtr));
340 tony 45 SetCodePage(rs,GetCodePage,false);
341     Result := rs;
342     end;
343     SQL_TEXT:
344     begin
345 tony 56 SetString(rs,PAnsiChar(FBufPtr),GetDataLength);
346 tony 45 SetCodePage(rs,GetCodePage,false);
347     Result := rs;
348     end
349     else
350     Result := inherited GetAsString;
351     end;
352     end;
353    
354     procedure TFBArrayElement.SetAsLong(Value: Long);
355     begin
356     AsInt64 := Value;
357     end;
358    
359     procedure TFBArrayElement.SetAsShort(Value: Short);
360     begin
361     AsInt64 := Value;
362     end;
363    
364     procedure TFBArrayElement.SetAsInt64(Value: Int64);
365     begin
366     CheckActive;
367     case GetSQLType of
368     SQL_LONG:
369     PLong(SQLData)^ := Value;
370     SQL_SHORT:
371     PShort(SQLData)^ := Value;
372     SQL_INT64:
373     PInt64(SQLData)^ := Value;
374     SQL_TEXT, SQL_VARYING:
375     SetAsString(IntToStr(Value));
376     SQL_D_FLOAT,
377     SQL_DOUBLE:
378     PDouble(SQLData)^ := Value;
379     SQL_FLOAT:
380     PSingle(SQLData)^ := Value;
381     else
382     IBError(ibxeInvalidDataConversion, [nil]);
383     end;
384     Changed;
385     end;
386    
387 tony 56 procedure TFBArrayElement.SetAsString(Value: AnsiString);
388 tony 45 var len: integer;
389     ElementSize: integer;
390     begin
391     CheckActive;
392     case GetSQLType of
393     SQL_BOOLEAN:
394 tony 56 if AnsiCompareText(Value,STrue) = 0 then
395 tony 45 AsBoolean := true
396     else
397 tony 56 if AnsiCompareText(Value,SFalse) = 0 then
398 tony 45 AsBoolean := false
399     else
400     IBError(ibxeInvalidDataConversion,[nil]);
401    
402     SQL_VARYING:
403     begin
404     Value := Transliterate(Value,GetCodePage);
405     len := Length(Value);
406     ElementSize := GetDataLength;
407     if len > ElementSize - 2 then
408     len := ElementSize - 2;
409     if Len > 0 then
410     Move(Value[1],FBufPtr^,len);
411     if Len < ElementSize - 2 then
412 tony 56 (FBufPtr+len)^ := 0;
413 tony 45 Changed;
414     end;
415    
416     SQL_TEXT:
417     begin
418     Value := Transliterate(Value,GetCodePage);
419     ElementSize := GetDataLength;
420     FillChar(FBufPtr^,ElementSize,' ');
421     len := Length(Value);
422     if len > ElementSize - 1 then len := ElementSize - 1;
423     Move(Value[1],FBufPtr^,len);
424     Changed;
425     end;
426    
427     SQL_SHORT,
428     SQL_LONG,
429     SQL_INT64:
430     if trim(Value) = '' then
431     SetAsInt64(0)
432     else
433 tony 59 SetAsInt64(AdjustScaleFromCurrency(StrToCurr(Value),GetScale));
434 tony 45
435     SQL_D_FLOAT,
436     SQL_DOUBLE,
437     SQL_FLOAT:
438     if trim(Value) = '' then
439     SetAsDouble(0)
440     else
441     SetAsDouble(StrToFloat(Value));
442    
443     SQL_TIMESTAMP:
444     SetAsDateTime(StrToDateTime(Value));
445    
446     SQL_TYPE_DATE:
447     SetAsDate(StrToDateTime(Value));
448    
449     SQL_TYPE_TIME:
450     SetAsTime(StrToDateTime(Value));
451    
452     else
453     IBError(ibxeInvalidDataConversion,[nil]);
454     end;
455     end;
456    
457     procedure TFBArrayElement.SetAsDouble(Value: Double);
458     begin
459     CheckActive;
460     case GetSQLType of
461     SQL_D_FLOAT,
462     SQL_DOUBLE:
463     PDouble(SQLData)^ := Value;
464     SQL_FLOAT:
465     PSingle(SQLData)^ := Value;
466     SQL_SHORT:
467     if Scale < 0 then
468     PShort(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
469     else
470     IBError(ibxeInvalidDataConversion, [nil]);
471     SQL_LONG:
472     if Scale < 0 then
473     PLong(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
474     else
475     IBError(ibxeInvalidDataConversion, [nil]);
476     SQL_INT64:
477     if Scale < 0 then
478     PInt64(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
479     else
480     IBError(ibxeInvalidDataConversion, [nil]);
481     SQL_TEXT, SQL_VARYING:
482     AsString := FloatToStr(Value);
483     else
484     IBError(ibxeInvalidDataConversion, [nil]);
485     end;
486     Changed;
487     end;
488    
489     procedure TFBArrayElement.SetAsFloat(Value: Float);
490     begin
491     AsDouble := Value;
492     end;
493    
494     procedure TFBArrayElement.SetAsCurrency(Value: Currency);
495     begin
496     CheckActive;
497     if (GetSQLDialect < 3) or (SQLType <> SQL_INT64) then
498     AsDouble := Value
499     else
500     begin
501     if Scale = -4 then
502     PCurrency(SQLData)^ := Value
503     else
504     PInt64(SQLData)^ := AdjustScaleFromCurrency(Value,Scale);
505     Changed;
506     end
507     end;
508    
509 tony 315 procedure TFBArrayElement.SetAsBcd(aValue: tBCD);
510     var C: Currency;
511     begin
512     CheckActive;
513     with FirebirdClientAPI do
514     case SQLType of
515     SQL_DEC_FIXED,
516     SQL_DEC16,
517     SQL_DEC34:
518     SQLDecFloatEncode(aValue,SQLType,SQLData);
519    
520     SQL_INT128:
521     StrToInt128(Scale,BcdToStr(aValue),SQLData);
522    
523     else
524     begin
525     BCDToCurr(aValue,C);
526     SetAsCurrency(C);
527     end;
528     end;
529     Changed;
530     end;
531    
532 tony 45 procedure TFBArrayElement.SetSQLType(aValue: cardinal);
533     begin
534 tony 315 if aValue <> GetSQLType then
535 tony 45 IBError(ibxeInvalidDataConversion, [nil]);
536     end;
537    
538     {TFBArrayMetaData}
539    
540     constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
541 tony 56 aTransaction: ITransaction; relationName, columnName: AnsiString);
542 tony 45 begin
543     inherited Create;
544 tony 60 FAttachment := aAttachment;
545 tony 45 LoadMetaData(aAttachment,aTransaction,relationName, columnName);
546     end;
547    
548 tony 60 constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
549     SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
550     Scale: integer; size: cardinal; charSetID: cardinal; dimensions: cardinal;
551     bounds: TArrayBounds);
552 tony 47 var i: integer;
553     begin
554     inherited Create;
555 tony 60 FAttachment := aAttachment;
556 tony 47 with FArrayDesc do
557     begin
558     array_desc_dtype := GetDType(SQLType);
559 tony 56 array_desc_scale := Scale;
560 tony 47 array_desc_length := UShort(size);
561     StrPLCopy(array_desc_field_name,columnName,sizeof(array_desc_field_name));
562     StrPLCopy(array_desc_relation_name,tableName,sizeof(array_desc_relation_name));
563     array_desc_dimensions := dimensions;
564     array_desc_flags := 0;
565     FCharSetID := charSetID;
566     for i := 0 to Length(bounds) - 1 do
567     begin
568     array_desc_bounds[i].array_bound_lower := bounds[i].LowerBound;
569     array_desc_bounds[i].array_bound_upper := bounds[i].UpperBound;
570     end;
571     end;
572     end;
573    
574 tony 45 function TFBArrayMetaData.GetSQLType: cardinal;
575     begin
576     case FArrayDesc.array_desc_dtype of
577     blr_cstring,
578     blr_cstring2,
579     blr_text,blr_text2:
580     Result := SQL_TEXT;
581     blr_short:
582     Result := SQL_SHORT;
583     blr_long:
584     Result := SQL_LONG;
585     blr_quad, blr_blob_id:
586     Result := SQL_QUAD;
587     blr_float:
588     Result := SQL_FLOAT;
589     blr_double,blr_d_float:
590     Result := SQL_D_FLOAT;
591     blr_timestamp:
592     Result := SQL_TIMESTAMP;
593     blr_varying,blr_varying2:
594     Result := SQL_VARYING;
595     blr_sql_date:
596     Result := SQL_TYPE_DATE;
597     blr_sql_time:
598     Result := SQL_TYPE_TIME;
599     blr_int64:
600     Result := SQL_INT64;
601 tony 315 blr_sql_time_tz:
602     Result := SQL_TIME_TZ;
603     blr_timestamp_tz:
604     Result := SQL_TIMESTAMP_TZ;
605     blr_ex_time_tz:
606     Result := SQL_TIME_TZ_EX;
607     blr_ex_timestamp_tz:
608     Result := SQL_TIMESTAMP_TZ_EX;
609     blr_dec64:
610     Result := SQL_DEC16;
611     blr_dec128:
612     Result := SQL_DEC34;
613     blr_int128:
614     Result := SQL_INT128;
615 tony 45 end;
616     end;
617    
618 tony 56 function TFBArrayMetaData.GetSQLTypeName: AnsiString;
619 tony 45 begin
620     Result := TSQLDataItem.GetSQLTypeName(GetSQLType);
621     end;
622    
623     function TFBArrayMetaData.GetScale: integer;
624     begin
625 tony 315 Result := FArrayDesc.array_desc_scale;
626 tony 45 end;
627    
628     function TFBArrayMetaData.GetSize: cardinal;
629     begin
630     Result := FArrayDesc.array_desc_length;
631     end;
632    
633 tony 56 function TFBArrayMetaData.GetTableName: AnsiString;
634 tony 45 begin
635     with FArrayDesc do
636 tony 56 SetString(Result,PAnsiChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
637 tony 45 Result := trim(Result);
638     end;
639    
640 tony 56 function TFBArrayMetaData.GetColumnName: AnsiString;
641 tony 45 begin
642     with FArrayDesc do
643 tony 56 SetString(Result,PAnsiChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
644 tony 45 Result := trim(Result);
645     end;
646    
647     function TFBArrayMetaData.GetDimensions: integer;
648     begin
649     Result := FArrayDesc.array_desc_dimensions;
650     end;
651    
652     function TFBArrayMetaData.GetBounds: TArrayBounds;
653     var i: integer;
654     begin
655     SetLength(Result,GetDimensions);
656     for i := 0 to GetDimensions - 1 do
657     begin
658     Result[i].UpperBound := FArrayDesc.array_desc_bounds[i].array_bound_upper;
659     Result[i].LowerBound := FArrayDesc.array_desc_bounds[i].array_bound_lower;
660     end;
661     end;
662    
663 tony 47 function TFBArrayMetaData.GetDType(SQLType: cardinal): UChar;
664     begin
665     case SQLType of
666     SQL_TEXT:
667     Result := blr_text;
668     SQL_SHORT:
669     Result := blr_short;
670     SQL_LONG:
671     Result := blr_long;
672     SQL_QUAD:
673     Result := blr_quad;
674     SQL_FLOAT:
675     Result := blr_float;
676     SQL_D_FLOAT:
677     Result := blr_double;
678     SQL_TIMESTAMP:
679     Result := blr_timestamp;
680     SQL_VARYING:
681     Result := blr_varying;
682     SQL_TYPE_DATE:
683     Result := blr_sql_date;
684     SQL_TYPE_TIME:
685     Result := blr_sql_time;
686     SQL_INT64:
687     Result := blr_int64;
688 tony 315 SQL_TIME_TZ:
689     Result := blr_sql_time_tz;
690     SQL_TIMESTAMP_TZ:
691     Result := blr_timestamp_tz;
692     SQL_TIME_TZ_EX:
693     Result := blr_ex_time_tz;
694     SQL_TIMESTAMP_TZ_EX:
695     Result := blr_ex_timestamp_tz;
696     SQL_DEC16:
697     Result := blr_dec64;
698     SQL_DEC34:
699     Result := blr_dec128;
700     SQL_INT128:
701     Result := blr_int128;
702 tony 47 end;
703     end;
704    
705 tony 45 function TFBArrayMetaData.NumOfElements: integer;
706     var i: integer;
707     Bounds: TArrayBounds;
708     begin
709     Result := 1;
710     Bounds := GetBounds;
711     for i := 0 to Length(Bounds) - 1 do
712 tony 56 Result := Result * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
713 tony 45 end;
714    
715    
716     { TFBArray }
717    
718     procedure TFBArray.AllocateBuffer;
719     var i: integer;
720     l: integer;
721     Bounds: TArrayBounds;
722     Dims: integer;
723     begin
724     SetLength(FOffsets,0);
725     FreeMem(FBuffer);
726     FBuffer := nil;
727     FLoaded := false;
728    
729     with FMetaData as TFBArrayMetaData do
730     begin
731     l := NumOfElements;
732     FElementSize := FArrayDesc.array_desc_length;
733     case GetSQLType of
734     SQL_VARYING:
735 tony 56 FElementSize := FElementSize + 2;
736 tony 45 SQL_TEXT:
737 tony 56 FElementSize := FElementSize + 1;
738 tony 45 end;
739     FBufSize := FElementSize * l;
740    
741 tony 263 with FFirebirdClientAPI do
742 tony 45 IBAlloc(FBuffer,0,FBufSize);
743    
744     Dims := GetDimensions;
745     SetLength(FOffsets,GetDimensions);
746     Bounds := GetBounds;
747     if FArrayDesc.array_desc_flags = 0 {row major} then
748     begin
749     FOffsets[0] := 1;
750     for i := 0 to Dims - 2 do
751     FOffsets[i+1] := FOffsets[i] * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
752     end
753     else
754     begin
755     {column major}
756     FOffsets[Dims-1] := 1;
757     for i := Dims - 1 downto 1 do
758     FOffsets[i-1] := FOffsets[i] * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
759     end;
760     end;
761     end;
762    
763     procedure TFBArray.Changing;
764     var i: integer;
765     begin
766     for i := 0 to Length(FEventHandlers) - 1 do
767     FEventHandlers[i](self,arChanging);
768     end;
769    
770     procedure TFBArray.Changed;
771     var i: integer;
772     begin
773     FModified := true;
774     for i := 0 to Length(FEventHandlers) - 1 do
775     FEventHandlers[i](self,arChanged);
776     end;
777    
778     procedure TFBArray.GetArraySlice;
779     begin
780     if FIsNew or FLoaded then Exit;
781     InternalGetSlice;
782     FLoaded := true;
783     end;
784    
785     procedure TFBArray.PutArraySlice(Force: boolean);
786     begin
787     if not FModified or not FTransactionIntf.InTransaction or
788     (FTransactionSeqNo < (FTransactionIntf as TFBTransaction).TransactionSeqNo) then Exit;
789    
790     InternalPutSlice(Force);
791     FModified := false;
792     FIsNew := false;
793     end;
794    
795 tony 56 function TFBArray.GetOffset(index: array of integer): PByte;
796 tony 45 var i: integer;
797     Bounds: TArrayBounds;
798     FlatIndex: integer;
799     begin
800     if FMetaData.GetDimensions <> Length(index) then
801     IBError(ibxeInvalidArrayDimensions,[Length(index)]);
802    
803     FlatIndex := 0;
804     Bounds := FMetaData.GetBounds;
805     for i := 0 to Length(index) - 1 do
806     begin
807     if (index[i] < Bounds[i].LowerBound) or (index[i] > Bounds[i].UpperBound) then
808     IBError(ibxeInvalidSubscript,[index[i],i]);
809    
810 tony 56 FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
811 tony 45 end;
812     Result := FBuffer + FlatIndex*FElementSize;
813     end;
814    
815     function TFBArray.GetDataLength: short;
816     begin
817     Result := FElementSize;
818     end;
819    
820     function TFBArray.GetArrayDesc: PISC_ARRAY_DESC;
821     begin
822     Result := @((FMetaData as TFBArrayMetaData).FArrayDesc);
823     end;
824    
825     constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction; aField: IArrayMetaData);
826     begin
827     inherited Create(aTransaction);
828     FMetaData := aField;
829     FAttachment := aAttachment;
830 tony 263 FFirebirdClientAPI := aTransaction.FirebirdAPI;
831 tony 45 FTransactionIntf := aTransaction;
832     FTransactionSeqNo := aTransaction.TransactionSeqNo;
833     FIsNew := true;
834     FModified := false;
835     FSQLDialect := aAttachment.GetSQLDialect;
836     AllocateBuffer;
837     FElement := TFBArrayElement.Create(self,FBuffer);
838     FElementIntf := FElement;
839     Setlength(FEventHandlers,0);
840     end;
841    
842     constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
843     aField: IArrayMetaData; ArrayID: TISC_QUAD);
844     begin
845     inherited Create(aTransaction);
846     FMetaData := aField;
847     FArrayID := ArrayID;
848     FAttachment := aAttachment;
849 tony 291 FFirebirdClientAPI := aTransaction.FirebirdAPI;
850 tony 45 FTransactionIntf := aTransaction;
851     FTransactionSeqNo := aTransaction.TransactionSeqNo;
852     FIsNew := false;
853     FModified := false;
854     FSQLDialect := aAttachment.GetSQLDialect;
855     AllocateBuffer;
856     FElement := TFBArrayElement.Create(self,FBuffer);
857     FElementIntf := FElement;
858     Setlength(FEventHandlers,0);
859     end;
860    
861     destructor TFBArray.Destroy;
862     begin
863     FreeMem(FBuffer);
864     inherited Destroy;
865     end;
866    
867     function TFBArray.GetArrayID: TISC_QUAD;
868     begin
869     PutArraySlice;
870     Result := FArrayID;
871     end;
872    
873     procedure TFBArray.Clear;
874     begin
875     FIsNew := true;
876     FModified := false;
877     FArrayID.gds_quad_high := 0;
878     FArrayID.gds_quad_low := 0;
879     AllocateBuffer;
880     end;
881    
882     function TFBArray.IsEmpty: boolean;
883     begin
884     Result := FIsNew and not FModified;
885     end;
886    
887     procedure TFBArray.PreLoad;
888     begin
889     GetArraySlice;
890     end;
891    
892     procedure TFBArray.CancelChanges;
893     begin
894     FModified := false;
895     AllocateBuffer;
896     end;
897    
898     procedure TFBArray.SaveChanges;
899     begin
900     PutArraySlice;
901     end;
902    
903     function TFBArray.GetSQLDialect: integer;
904     begin
905     Result := FSQLDialect;
906     end;
907    
908     procedure TFBArray.TransactionEnding(aTransaction: ITransaction; Force: boolean
909     );
910     begin
911 tony 315 if ((aTransaction as TObject) = (FTransactionIntf as TObject)) and FModified and not FIsNew then
912 tony 45 PutArraySlice(Force);
913     end;
914    
915     function TFBArray.GetSQLType: cardinal;
916     begin
917     Result := FMetaData.GetSQLType;
918     end;
919    
920 tony 56 function TFBArray.GetSQLTypeName: AnsiString;
921 tony 45 begin
922     Result := FMetaData.GetSQLTypeName;
923     end;
924    
925     function TFBArray.GetScale: integer;
926     begin
927     Result := FMetaData.GetScale;
928     end;
929    
930     function TFBArray.GetSize: cardinal;
931     begin
932     Result := FMetaData.GetSize;
933     end;
934    
935     function TFBArray.GetCharSetID: cardinal;
936     begin
937     Result := FMetaData.GetCharSetID;
938     end;
939    
940 tony 309 function TFBArray.GetCharSetWidth: integer;
941     begin
942     Result := FMetaData.GetCharSetWidth;
943     end;
944    
945 tony 56 function TFBArray.GetTableName: AnsiString;
946 tony 45 begin
947     Result := FMetaData.GetTableName;
948     end;
949    
950 tony 56 function TFBArray.GetColumnName: AnsiString;
951 tony 45 begin
952     Result := FMetaData.GetColumnName;
953     end;
954    
955     function TFBArray.GetDimensions: integer;
956     begin
957     Result := FMetaData.GetDimensions;
958     end;
959    
960     function TFBArray.GetBounds: TArrayBounds;
961     begin
962     Result := FMetaData.GetBounds;
963     end;
964    
965     function TFBArray.GetAsInteger(index: array of integer): integer;
966     begin
967     GetArraySlice;
968     FElement.FBufPtr := GetOffset(index);
969     Result := FElement.GetAsLong;
970     end;
971    
972     function TFBArray.GetAsBoolean(index: array of integer): boolean;
973     begin
974     GetArraySlice;
975     FElement.FBufPtr := GetOffset(index);
976     Result := FElement.GetAsBoolean;
977     end;
978    
979     function TFBArray.GetAsCurrency(index: array of integer): Currency;
980     begin
981     GetArraySlice;
982     FElement.FBufPtr := GetOffset(index);
983     Result := FElement.GetAsCurrency;
984     end;
985    
986     function TFBArray.GetAsInt64(index: array of integer): Int64;
987     begin
988     GetArraySlice;
989     FElement.FBufPtr := GetOffset(index);
990     Result := FElement.GetAsInt64;
991     end;
992    
993     function TFBArray.GetAsDateTime(index: array of integer): TDateTime;
994     begin
995     GetArraySlice;
996     FElement.FBufPtr := GetOffset(index);
997     Result := FElement.GetAsDateTime;
998     end;
999    
1000 tony 315 procedure TFBArray.GetAsDateTime(index: array of integer;
1001     var aDateTime: TDateTime; var dstOffset: smallint;
1002     var aTimezoneID: TFBTimeZoneID);
1003     begin
1004     GetArraySlice;
1005     FElement.FBufPtr := GetOffset(index);
1006     FElement.GetAsDateTime(aDateTime,dstOffset,aTimezoneID);
1007     end;
1008    
1009     procedure TFBArray.GetAsDateTime(index: array of integer;
1010     var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString);
1011     begin
1012     GetArraySlice;
1013     FElement.FBufPtr := GetOffset(index);
1014     FElement.GetAsDateTime(aDateTime,dstOffset,aTimezone);
1015     end;
1016    
1017     procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1018     var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime);
1019     begin
1020     GetArraySlice;
1021     FElement.FBufPtr := GetOffset(index);
1022     FElement.GetAsTime(aTime,dstOffset,aTimezoneID,OnDate);
1023     end;
1024    
1025     procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1026     var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime);
1027     begin
1028     GetArraySlice;
1029     FElement.FBufPtr := GetOffset(index);
1030     FElement.GetAsTime(aTime,dstOffset,aTimezone,OnDate);
1031     end;
1032    
1033     function TFBArray.GetAsUTCDateTime(index: array of integer): TDateTime;
1034     begin
1035     GetArraySlice;
1036     FElement.FBufPtr := GetOffset(index);
1037     Result := FElement.GetAsUTCDateTime;
1038     end;
1039    
1040 tony 45 function TFBArray.GetAsDouble(index: array of integer): Double;
1041     begin
1042     GetArraySlice;
1043     FElement.FBufPtr := GetOffset(index);
1044     Result := FElement.GetAsDouble;
1045     end;
1046    
1047     function TFBArray.GetAsFloat(index: array of integer): Float;
1048     begin
1049     GetArraySlice;
1050     FElement.FBufPtr := GetOffset(index);
1051     Result := FElement.GetAsFloat;
1052     end;
1053    
1054     function TFBArray.GetAsLong(index: array of integer): Long;
1055     begin
1056     GetArraySlice;
1057     FElement.FBufPtr := GetOffset(index);
1058     Result := FElement.GetAsLong;
1059     end;
1060    
1061     function TFBArray.GetAsShort(index: array of integer): Short;
1062     begin
1063     GetArraySlice;
1064     FElement.FBufPtr := GetOffset(index);
1065     Result := FElement.GetAsShort;
1066     end;
1067    
1068 tony 56 function TFBArray.GetAsString(index: array of integer): AnsiString;
1069 tony 45 begin
1070     GetArraySlice;
1071     FElement.FBufPtr := GetOffset(index);
1072     Result := FElement.GetAsString;
1073     end;
1074    
1075     function TFBArray.GetAsVariant(index: array of integer): Variant;
1076     begin
1077     GetArraySlice;
1078     FElement.FBufPtr := GetOffset(index);
1079     Result := FElement.GetAsVariant;
1080     end;
1081    
1082 tony 315 function TFBArray.GetAsBCD(index: array of integer): tBCD;
1083     begin
1084     GetArraySlice;
1085     FElement.FBufPtr := GetOffset(index);
1086     Result := FElement.GetAsBCD;
1087     end;
1088    
1089 tony 45 procedure TFBArray.SetAsInteger(index: array of integer; AValue: integer);
1090     begin
1091     FElement.FBufPtr := GetOffset(index);
1092     FElement.SetAsLong(AValue);
1093     end;
1094    
1095     procedure TFBArray.SetAsBoolean(index: array of integer; AValue: boolean);
1096     begin
1097     FElement.FBufPtr := GetOffset(index);
1098     FElement.SetAsBoolean(AValue);
1099     end;
1100    
1101     procedure TFBArray.SetAsCurrency(index: array of integer; Value: Currency);
1102     begin
1103     FElement.FBufPtr := GetOffset(index);
1104     FElement.SetAsCurrency(Value);
1105     end;
1106    
1107     procedure TFBArray.SetAsInt64(index: array of integer; Value: Int64);
1108     begin
1109     FElement.FBufPtr := GetOffset(index);
1110     FElement.SetAsInt64(Value);
1111     end;
1112    
1113     procedure TFBArray.SetAsDate(index: array of integer; Value: TDateTime);
1114     begin
1115     FElement.FBufPtr := GetOffset(index);
1116     FElement.SetAsDate(Value);
1117     end;
1118    
1119     procedure TFBArray.SetAsLong(index: array of integer; Value: Long);
1120     begin
1121     FElement.FBufPtr := GetOffset(index);
1122     FElement.SetAsLong(Value);
1123     end;
1124    
1125     procedure TFBArray.SetAsTime(index: array of integer; Value: TDateTime);
1126     begin
1127     FElement.FBufPtr := GetOffset(index);
1128     FElement.SetAsTime(Value);
1129     end;
1130    
1131 tony 315 procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1132     aTimeZoneID: TFBTimeZoneID);
1133     begin
1134     FElement.FBufPtr := GetOffset(index);
1135     FElement.SetAsTime(aValue,OnDate,aTimeZoneID);
1136     end;
1137    
1138     procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1139     aTimeZone: AnsiString);
1140     begin
1141     FElement.FBufPtr := GetOffset(index);
1142     FElement.SetAsTime(aValue,OnDate, aTimeZone);
1143     end;
1144    
1145 tony 45 procedure TFBArray.SetAsDateTime(index: array of integer; Value: TDateTime);
1146     begin
1147     FElement.FBufPtr := GetOffset(index);
1148     FElement.SetAsDateTime(Value);
1149     end;
1150    
1151 tony 315 procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1152     aTimeZoneID: TFBTimeZoneID);
1153     begin
1154     FElement.FBufPtr := GetOffset(index);
1155     FElement.SetAsDateTime(aValue,aTimeZoneID);
1156     end;
1157    
1158     procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1159     aTimeZone: AnsiString);
1160     begin
1161     FElement.FBufPtr := GetOffset(index);
1162     FElement.SetAsDateTime(aValue,aTimeZone);
1163     end;
1164    
1165     procedure TFBArray.SetAsUTCDateTime(index: array of integer;
1166     aUTCTime: TDateTime);
1167     begin
1168     FElement.FBufPtr := GetOffset(index);
1169     FElement.SetAsUTCDateTime(aUTCTime);
1170     end;
1171    
1172 tony 45 procedure TFBArray.SetAsDouble(index: array of integer; Value: Double);
1173     begin
1174     FElement.FBufPtr := GetOffset(index);
1175     FElement.SetAsDouble(Value);
1176     end;
1177    
1178     procedure TFBArray.SetAsFloat(index: array of integer; Value: Float);
1179     begin
1180     FElement.FBufPtr := GetOffset(index);
1181     FElement.SetAsFloat(Value);
1182     end;
1183    
1184     procedure TFBArray.SetAsShort(index: array of integer; Value: Short);
1185     begin
1186     FElement.FBufPtr := GetOffset(index);
1187     FElement.SetAsShort(Value);
1188     end;
1189    
1190 tony 56 procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1191 tony 45 begin
1192     FElement.FBufPtr := GetOffset(index);
1193     FElement.SetAsString(Value);
1194     end;
1195    
1196     procedure TFBArray.SetAsVariant(index: array of integer; Value: Variant);
1197     begin
1198     FElement.FBufPtr := GetOffset(index);
1199     FElement.SetAsVariant(Value);
1200     end;
1201    
1202 tony 315 procedure TFBArray.SetAsBcd(index: array of integer; aValue: tBCD);
1203     begin
1204     FElement.FBufPtr := GetOffset(index);
1205     FElement.SetAsBcd(aValue);
1206     end;
1207    
1208 tony 45 procedure TFBArray.SetBounds(dim, UpperBound, LowerBound: integer);
1209     begin
1210     with (FMetaData as TFBArrayMetaData) do
1211     begin
1212     if (dim < 0) or (dim > GetDimensions) then
1213     IBError(ibxeInvalidArrayDimensions,[dim]);
1214    
1215     if (UpperBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) or
1216     (LowerBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1217     (UpperBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1218     (LowerBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) then
1219     IBError(ibxArrayBoundsCantIncrease,[nil]);
1220    
1221     PutArraySlice; {Save any changes}
1222    
1223     FArrayDesc.array_desc_bounds[dim].array_bound_upper := UpperBound;
1224     FArrayDesc.array_desc_bounds[dim].array_bound_lower := LowerBound;
1225     end;
1226     AllocateBuffer;
1227     end;
1228    
1229     function TFBArray.GetAttachment: IAttachment;
1230     begin
1231     Result := FAttachment;
1232     end;
1233    
1234     function TFBArray.GetTransaction: ITransaction;
1235     begin
1236     Result := FTransactionIntf;
1237     end;
1238    
1239     procedure TFBArray.AddEventHandler(Handler: TArrayEventHandler);
1240     begin
1241     SetLength(FEventHandlers,Length(FEventHandlers)+1);
1242     FEventHandlers[Length(FEventHandlers)-1] := Handler;
1243     end;
1244    
1245     procedure TFBArray.RemoveEventHandler(Handler: TArrayEventHandler);
1246     var i,j : integer;
1247     begin
1248     for i := Length(FEventHandlers) - 1 downto 0 do
1249 tony 56 if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1250     (TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1251 tony 45 begin
1252     for j := i to Length(FEventHandlers) - 2 do
1253     FEventHandlers[i] := FEventHandlers[i+1];
1254     SetLength(FEventHandlers,Length(FEventHandlers) - 1);
1255     end;
1256     end;
1257    
1258     end.
1259