ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBArray.pas
Revision: 349
Committed: Mon Oct 18 08:39:40 2021 UTC (2 years, 5 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBArray.pas
File size: 34401 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 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 tony 349 Int64Value: Int64;
391 tony 45 begin
392     CheckActive;
393     case GetSQLType of
394     SQL_BOOLEAN:
395 tony 56 if AnsiCompareText(Value,STrue) = 0 then
396 tony 45 AsBoolean := true
397     else
398 tony 56 if AnsiCompareText(Value,SFalse) = 0 then
399 tony 45 AsBoolean := false
400     else
401     IBError(ibxeInvalidDataConversion,[nil]);
402    
403     SQL_VARYING:
404     begin
405     Value := Transliterate(Value,GetCodePage);
406     len := Length(Value);
407     ElementSize := GetDataLength;
408     if len > ElementSize - 2 then
409     len := ElementSize - 2;
410     if Len > 0 then
411     Move(Value[1],FBufPtr^,len);
412     if Len < ElementSize - 2 then
413 tony 56 (FBufPtr+len)^ := 0;
414 tony 45 Changed;
415     end;
416    
417     SQL_TEXT:
418     begin
419     Value := Transliterate(Value,GetCodePage);
420     ElementSize := GetDataLength;
421     FillChar(FBufPtr^,ElementSize,' ');
422     len := Length(Value);
423     if len > ElementSize - 1 then len := ElementSize - 1;
424     Move(Value[1],FBufPtr^,len);
425     Changed;
426     end;
427    
428     SQL_SHORT,
429     SQL_LONG,
430     SQL_INT64:
431     if trim(Value) = '' then
432     SetAsInt64(0)
433     else
434 tony 349 if TryStrToInt64(Value,Int64Value) then
435     SetAsInt64(Int64Value)
436     else
437     SetAsCurrency(StrToCurr(Value));
438 tony 45
439     SQL_D_FLOAT,
440     SQL_DOUBLE,
441     SQL_FLOAT:
442     if trim(Value) = '' then
443     SetAsDouble(0)
444     else
445     SetAsDouble(StrToFloat(Value));
446    
447     SQL_TIMESTAMP:
448     SetAsDateTime(StrToDateTime(Value));
449    
450     SQL_TYPE_DATE:
451     SetAsDate(StrToDateTime(Value));
452    
453     SQL_TYPE_TIME:
454     SetAsTime(StrToDateTime(Value));
455    
456     else
457     IBError(ibxeInvalidDataConversion,[nil]);
458     end;
459     end;
460    
461     procedure TFBArrayElement.SetAsDouble(Value: Double);
462     begin
463     CheckActive;
464     case GetSQLType of
465     SQL_D_FLOAT,
466     SQL_DOUBLE:
467     PDouble(SQLData)^ := Value;
468     SQL_FLOAT:
469     PSingle(SQLData)^ := Value;
470     SQL_SHORT:
471     if Scale < 0 then
472     PShort(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
473     else
474     IBError(ibxeInvalidDataConversion, [nil]);
475     SQL_LONG:
476     if Scale < 0 then
477     PLong(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
478     else
479     IBError(ibxeInvalidDataConversion, [nil]);
480     SQL_INT64:
481     if Scale < 0 then
482     PInt64(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
483     else
484     IBError(ibxeInvalidDataConversion, [nil]);
485     SQL_TEXT, SQL_VARYING:
486     AsString := FloatToStr(Value);
487     else
488     IBError(ibxeInvalidDataConversion, [nil]);
489     end;
490     Changed;
491     end;
492    
493     procedure TFBArrayElement.SetAsFloat(Value: Float);
494     begin
495     AsDouble := Value;
496     end;
497    
498     procedure TFBArrayElement.SetAsCurrency(Value: Currency);
499     begin
500     CheckActive;
501     if (GetSQLDialect < 3) or (SQLType <> SQL_INT64) then
502     AsDouble := Value
503     else
504     begin
505     if Scale = -4 then
506     PCurrency(SQLData)^ := Value
507     else
508     PInt64(SQLData)^ := AdjustScaleFromCurrency(Value,Scale);
509     Changed;
510     end
511     end;
512    
513 tony 315 procedure TFBArrayElement.SetAsBcd(aValue: tBCD);
514     var C: Currency;
515     begin
516     CheckActive;
517     with FirebirdClientAPI do
518     case SQLType of
519     SQL_DEC_FIXED,
520     SQL_DEC16,
521     SQL_DEC34:
522     SQLDecFloatEncode(aValue,SQLType,SQLData);
523    
524     SQL_INT128:
525     StrToInt128(Scale,BcdToStr(aValue),SQLData);
526    
527     else
528     begin
529     BCDToCurr(aValue,C);
530     SetAsCurrency(C);
531     end;
532     end;
533     Changed;
534     end;
535    
536 tony 45 procedure TFBArrayElement.SetSQLType(aValue: cardinal);
537     begin
538 tony 315 if aValue <> GetSQLType then
539 tony 45 IBError(ibxeInvalidDataConversion, [nil]);
540     end;
541    
542     {TFBArrayMetaData}
543    
544     constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
545 tony 56 aTransaction: ITransaction; relationName, columnName: AnsiString);
546 tony 45 begin
547     inherited Create;
548 tony 60 FAttachment := aAttachment;
549 tony 45 LoadMetaData(aAttachment,aTransaction,relationName, columnName);
550     end;
551    
552 tony 60 constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
553     SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
554     Scale: integer; size: cardinal; charSetID: cardinal; dimensions: cardinal;
555     bounds: TArrayBounds);
556 tony 47 var i: integer;
557     begin
558     inherited Create;
559 tony 60 FAttachment := aAttachment;
560 tony 47 with FArrayDesc do
561     begin
562     array_desc_dtype := GetDType(SQLType);
563 tony 56 array_desc_scale := Scale;
564 tony 47 array_desc_length := UShort(size);
565     StrPLCopy(array_desc_field_name,columnName,sizeof(array_desc_field_name));
566     StrPLCopy(array_desc_relation_name,tableName,sizeof(array_desc_relation_name));
567     array_desc_dimensions := dimensions;
568     array_desc_flags := 0;
569     FCharSetID := charSetID;
570     for i := 0 to Length(bounds) - 1 do
571     begin
572     array_desc_bounds[i].array_bound_lower := bounds[i].LowerBound;
573     array_desc_bounds[i].array_bound_upper := bounds[i].UpperBound;
574     end;
575     end;
576     end;
577    
578 tony 45 function TFBArrayMetaData.GetSQLType: cardinal;
579     begin
580     case FArrayDesc.array_desc_dtype of
581     blr_cstring,
582     blr_cstring2,
583     blr_text,blr_text2:
584     Result := SQL_TEXT;
585     blr_short:
586     Result := SQL_SHORT;
587     blr_long:
588     Result := SQL_LONG;
589     blr_quad, blr_blob_id:
590     Result := SQL_QUAD;
591     blr_float:
592     Result := SQL_FLOAT;
593     blr_double,blr_d_float:
594     Result := SQL_D_FLOAT;
595     blr_timestamp:
596     Result := SQL_TIMESTAMP;
597     blr_varying,blr_varying2:
598     Result := SQL_VARYING;
599     blr_sql_date:
600     Result := SQL_TYPE_DATE;
601     blr_sql_time:
602     Result := SQL_TYPE_TIME;
603     blr_int64:
604     Result := SQL_INT64;
605 tony 315 blr_sql_time_tz:
606     Result := SQL_TIME_TZ;
607     blr_timestamp_tz:
608     Result := SQL_TIMESTAMP_TZ;
609     blr_ex_time_tz:
610     Result := SQL_TIME_TZ_EX;
611     blr_ex_timestamp_tz:
612     Result := SQL_TIMESTAMP_TZ_EX;
613     blr_dec64:
614     Result := SQL_DEC16;
615     blr_dec128:
616     Result := SQL_DEC34;
617     blr_int128:
618     Result := SQL_INT128;
619 tony 45 end;
620     end;
621    
622 tony 56 function TFBArrayMetaData.GetSQLTypeName: AnsiString;
623 tony 45 begin
624     Result := TSQLDataItem.GetSQLTypeName(GetSQLType);
625     end;
626    
627     function TFBArrayMetaData.GetScale: integer;
628     begin
629 tony 315 Result := FArrayDesc.array_desc_scale;
630 tony 45 end;
631    
632     function TFBArrayMetaData.GetSize: cardinal;
633     begin
634     Result := FArrayDesc.array_desc_length;
635     end;
636    
637 tony 56 function TFBArrayMetaData.GetTableName: AnsiString;
638 tony 45 begin
639     with FArrayDesc do
640 tony 56 SetString(Result,PAnsiChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
641 tony 45 Result := trim(Result);
642     end;
643    
644 tony 56 function TFBArrayMetaData.GetColumnName: AnsiString;
645 tony 45 begin
646     with FArrayDesc do
647 tony 56 SetString(Result,PAnsiChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
648 tony 45 Result := trim(Result);
649     end;
650    
651     function TFBArrayMetaData.GetDimensions: integer;
652     begin
653     Result := FArrayDesc.array_desc_dimensions;
654     end;
655    
656     function TFBArrayMetaData.GetBounds: TArrayBounds;
657     var i: integer;
658     begin
659     SetLength(Result,GetDimensions);
660     for i := 0 to GetDimensions - 1 do
661     begin
662     Result[i].UpperBound := FArrayDesc.array_desc_bounds[i].array_bound_upper;
663     Result[i].LowerBound := FArrayDesc.array_desc_bounds[i].array_bound_lower;
664     end;
665     end;
666    
667 tony 47 function TFBArrayMetaData.GetDType(SQLType: cardinal): UChar;
668     begin
669     case SQLType of
670     SQL_TEXT:
671     Result := blr_text;
672     SQL_SHORT:
673     Result := blr_short;
674     SQL_LONG:
675     Result := blr_long;
676     SQL_QUAD:
677     Result := blr_quad;
678     SQL_FLOAT:
679     Result := blr_float;
680     SQL_D_FLOAT:
681     Result := blr_double;
682     SQL_TIMESTAMP:
683     Result := blr_timestamp;
684     SQL_VARYING:
685     Result := blr_varying;
686     SQL_TYPE_DATE:
687     Result := blr_sql_date;
688     SQL_TYPE_TIME:
689     Result := blr_sql_time;
690     SQL_INT64:
691     Result := blr_int64;
692 tony 315 SQL_TIME_TZ:
693     Result := blr_sql_time_tz;
694     SQL_TIMESTAMP_TZ:
695     Result := blr_timestamp_tz;
696     SQL_TIME_TZ_EX:
697     Result := blr_ex_time_tz;
698     SQL_TIMESTAMP_TZ_EX:
699     Result := blr_ex_timestamp_tz;
700     SQL_DEC16:
701     Result := blr_dec64;
702     SQL_DEC34:
703     Result := blr_dec128;
704     SQL_INT128:
705     Result := blr_int128;
706 tony 47 end;
707     end;
708    
709 tony 45 function TFBArrayMetaData.NumOfElements: integer;
710     var i: integer;
711     Bounds: TArrayBounds;
712     begin
713     Result := 1;
714     Bounds := GetBounds;
715     for i := 0 to Length(Bounds) - 1 do
716 tony 56 Result := Result * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
717 tony 45 end;
718    
719    
720     { TFBArray }
721    
722     procedure TFBArray.AllocateBuffer;
723     var i: integer;
724     l: integer;
725     Bounds: TArrayBounds;
726     Dims: integer;
727     begin
728     SetLength(FOffsets,0);
729     FreeMem(FBuffer);
730     FBuffer := nil;
731     FLoaded := false;
732    
733     with FMetaData as TFBArrayMetaData do
734     begin
735     l := NumOfElements;
736     FElementSize := FArrayDesc.array_desc_length;
737     case GetSQLType of
738     SQL_VARYING:
739 tony 56 FElementSize := FElementSize + 2;
740 tony 45 SQL_TEXT:
741 tony 56 FElementSize := FElementSize + 1;
742 tony 45 end;
743     FBufSize := FElementSize * l;
744    
745 tony 263 with FFirebirdClientAPI do
746 tony 45 IBAlloc(FBuffer,0,FBufSize);
747    
748     Dims := GetDimensions;
749     SetLength(FOffsets,GetDimensions);
750     Bounds := GetBounds;
751     if FArrayDesc.array_desc_flags = 0 {row major} then
752     begin
753     FOffsets[0] := 1;
754     for i := 0 to Dims - 2 do
755     FOffsets[i+1] := FOffsets[i] * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
756     end
757     else
758     begin
759     {column major}
760     FOffsets[Dims-1] := 1;
761     for i := Dims - 1 downto 1 do
762     FOffsets[i-1] := FOffsets[i] * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
763     end;
764     end;
765     end;
766    
767     procedure TFBArray.Changing;
768     var i: integer;
769     begin
770     for i := 0 to Length(FEventHandlers) - 1 do
771     FEventHandlers[i](self,arChanging);
772     end;
773    
774     procedure TFBArray.Changed;
775     var i: integer;
776     begin
777     FModified := true;
778     for i := 0 to Length(FEventHandlers) - 1 do
779     FEventHandlers[i](self,arChanged);
780     end;
781    
782     procedure TFBArray.GetArraySlice;
783     begin
784     if FIsNew or FLoaded then Exit;
785     InternalGetSlice;
786     FLoaded := true;
787     end;
788    
789     procedure TFBArray.PutArraySlice(Force: boolean);
790     begin
791     if not FModified or not FTransactionIntf.InTransaction or
792     (FTransactionSeqNo < (FTransactionIntf as TFBTransaction).TransactionSeqNo) then Exit;
793    
794     InternalPutSlice(Force);
795     FModified := false;
796     FIsNew := false;
797     end;
798    
799 tony 56 function TFBArray.GetOffset(index: array of integer): PByte;
800 tony 45 var i: integer;
801     Bounds: TArrayBounds;
802     FlatIndex: integer;
803     begin
804     if FMetaData.GetDimensions <> Length(index) then
805     IBError(ibxeInvalidArrayDimensions,[Length(index)]);
806    
807     FlatIndex := 0;
808     Bounds := FMetaData.GetBounds;
809     for i := 0 to Length(index) - 1 do
810     begin
811     if (index[i] < Bounds[i].LowerBound) or (index[i] > Bounds[i].UpperBound) then
812     IBError(ibxeInvalidSubscript,[index[i],i]);
813    
814 tony 56 FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
815 tony 45 end;
816     Result := FBuffer + FlatIndex*FElementSize;
817     end;
818    
819     function TFBArray.GetDataLength: short;
820     begin
821     Result := FElementSize;
822     end;
823    
824     function TFBArray.GetArrayDesc: PISC_ARRAY_DESC;
825     begin
826     Result := @((FMetaData as TFBArrayMetaData).FArrayDesc);
827     end;
828    
829     constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction; aField: IArrayMetaData);
830     begin
831     inherited Create(aTransaction);
832     FMetaData := aField;
833     FAttachment := aAttachment;
834 tony 263 FFirebirdClientAPI := aTransaction.FirebirdAPI;
835 tony 45 FTransactionIntf := aTransaction;
836     FTransactionSeqNo := aTransaction.TransactionSeqNo;
837     FIsNew := true;
838     FModified := false;
839     FSQLDialect := aAttachment.GetSQLDialect;
840     AllocateBuffer;
841     FElement := TFBArrayElement.Create(self,FBuffer);
842     FElementIntf := FElement;
843     Setlength(FEventHandlers,0);
844     end;
845    
846     constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
847     aField: IArrayMetaData; ArrayID: TISC_QUAD);
848     begin
849     inherited Create(aTransaction);
850     FMetaData := aField;
851     FArrayID := ArrayID;
852     FAttachment := aAttachment;
853 tony 291 FFirebirdClientAPI := aTransaction.FirebirdAPI;
854 tony 45 FTransactionIntf := aTransaction;
855     FTransactionSeqNo := aTransaction.TransactionSeqNo;
856     FIsNew := false;
857     FModified := false;
858     FSQLDialect := aAttachment.GetSQLDialect;
859     AllocateBuffer;
860     FElement := TFBArrayElement.Create(self,FBuffer);
861     FElementIntf := FElement;
862     Setlength(FEventHandlers,0);
863     end;
864    
865     destructor TFBArray.Destroy;
866     begin
867     FreeMem(FBuffer);
868     inherited Destroy;
869     end;
870    
871     function TFBArray.GetArrayID: TISC_QUAD;
872     begin
873     PutArraySlice;
874     Result := FArrayID;
875     end;
876    
877     procedure TFBArray.Clear;
878     begin
879     FIsNew := true;
880     FModified := false;
881     FArrayID.gds_quad_high := 0;
882     FArrayID.gds_quad_low := 0;
883     AllocateBuffer;
884     end;
885    
886     function TFBArray.IsEmpty: boolean;
887     begin
888     Result := FIsNew and not FModified;
889     end;
890    
891     procedure TFBArray.PreLoad;
892     begin
893     GetArraySlice;
894     end;
895    
896     procedure TFBArray.CancelChanges;
897     begin
898     FModified := false;
899     AllocateBuffer;
900     end;
901    
902     procedure TFBArray.SaveChanges;
903     begin
904     PutArraySlice;
905     end;
906    
907     function TFBArray.GetSQLDialect: integer;
908     begin
909     Result := FSQLDialect;
910     end;
911    
912     procedure TFBArray.TransactionEnding(aTransaction: ITransaction; Force: boolean
913     );
914     begin
915 tony 315 if ((aTransaction as TObject) = (FTransactionIntf as TObject)) and FModified and not FIsNew then
916 tony 45 PutArraySlice(Force);
917     end;
918    
919     function TFBArray.GetSQLType: cardinal;
920     begin
921     Result := FMetaData.GetSQLType;
922     end;
923    
924 tony 56 function TFBArray.GetSQLTypeName: AnsiString;
925 tony 45 begin
926     Result := FMetaData.GetSQLTypeName;
927     end;
928    
929     function TFBArray.GetScale: integer;
930     begin
931     Result := FMetaData.GetScale;
932     end;
933    
934     function TFBArray.GetSize: cardinal;
935     begin
936     Result := FMetaData.GetSize;
937     end;
938    
939     function TFBArray.GetCharSetID: cardinal;
940     begin
941     Result := FMetaData.GetCharSetID;
942     end;
943    
944 tony 309 function TFBArray.GetCharSetWidth: integer;
945     begin
946     Result := FMetaData.GetCharSetWidth;
947     end;
948    
949 tony 56 function TFBArray.GetTableName: AnsiString;
950 tony 45 begin
951     Result := FMetaData.GetTableName;
952     end;
953    
954 tony 56 function TFBArray.GetColumnName: AnsiString;
955 tony 45 begin
956     Result := FMetaData.GetColumnName;
957     end;
958    
959     function TFBArray.GetDimensions: integer;
960     begin
961     Result := FMetaData.GetDimensions;
962     end;
963    
964     function TFBArray.GetBounds: TArrayBounds;
965     begin
966     Result := FMetaData.GetBounds;
967     end;
968    
969     function TFBArray.GetAsInteger(index: array of integer): integer;
970     begin
971     GetArraySlice;
972     FElement.FBufPtr := GetOffset(index);
973     Result := FElement.GetAsLong;
974     end;
975    
976     function TFBArray.GetAsBoolean(index: array of integer): boolean;
977     begin
978     GetArraySlice;
979     FElement.FBufPtr := GetOffset(index);
980     Result := FElement.GetAsBoolean;
981     end;
982    
983     function TFBArray.GetAsCurrency(index: array of integer): Currency;
984     begin
985     GetArraySlice;
986     FElement.FBufPtr := GetOffset(index);
987     Result := FElement.GetAsCurrency;
988     end;
989    
990     function TFBArray.GetAsInt64(index: array of integer): Int64;
991     begin
992     GetArraySlice;
993     FElement.FBufPtr := GetOffset(index);
994     Result := FElement.GetAsInt64;
995     end;
996    
997     function TFBArray.GetAsDateTime(index: array of integer): TDateTime;
998     begin
999     GetArraySlice;
1000     FElement.FBufPtr := GetOffset(index);
1001     Result := FElement.GetAsDateTime;
1002     end;
1003    
1004 tony 315 procedure TFBArray.GetAsDateTime(index: array of integer;
1005     var aDateTime: TDateTime; var dstOffset: smallint;
1006     var aTimezoneID: TFBTimeZoneID);
1007     begin
1008     GetArraySlice;
1009     FElement.FBufPtr := GetOffset(index);
1010     FElement.GetAsDateTime(aDateTime,dstOffset,aTimezoneID);
1011     end;
1012    
1013     procedure TFBArray.GetAsDateTime(index: array of integer;
1014     var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString);
1015     begin
1016     GetArraySlice;
1017     FElement.FBufPtr := GetOffset(index);
1018     FElement.GetAsDateTime(aDateTime,dstOffset,aTimezone);
1019     end;
1020    
1021     procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1022     var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime);
1023     begin
1024     GetArraySlice;
1025     FElement.FBufPtr := GetOffset(index);
1026     FElement.GetAsTime(aTime,dstOffset,aTimezoneID,OnDate);
1027     end;
1028    
1029     procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1030     var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime);
1031     begin
1032     GetArraySlice;
1033     FElement.FBufPtr := GetOffset(index);
1034     FElement.GetAsTime(aTime,dstOffset,aTimezone,OnDate);
1035     end;
1036    
1037     function TFBArray.GetAsUTCDateTime(index: array of integer): TDateTime;
1038     begin
1039     GetArraySlice;
1040     FElement.FBufPtr := GetOffset(index);
1041     Result := FElement.GetAsUTCDateTime;
1042     end;
1043    
1044 tony 45 function TFBArray.GetAsDouble(index: array of integer): Double;
1045     begin
1046     GetArraySlice;
1047     FElement.FBufPtr := GetOffset(index);
1048     Result := FElement.GetAsDouble;
1049     end;
1050    
1051     function TFBArray.GetAsFloat(index: array of integer): Float;
1052     begin
1053     GetArraySlice;
1054     FElement.FBufPtr := GetOffset(index);
1055     Result := FElement.GetAsFloat;
1056     end;
1057    
1058     function TFBArray.GetAsLong(index: array of integer): Long;
1059     begin
1060     GetArraySlice;
1061     FElement.FBufPtr := GetOffset(index);
1062     Result := FElement.GetAsLong;
1063     end;
1064    
1065     function TFBArray.GetAsShort(index: array of integer): Short;
1066     begin
1067     GetArraySlice;
1068     FElement.FBufPtr := GetOffset(index);
1069     Result := FElement.GetAsShort;
1070     end;
1071    
1072 tony 56 function TFBArray.GetAsString(index: array of integer): AnsiString;
1073 tony 45 begin
1074     GetArraySlice;
1075     FElement.FBufPtr := GetOffset(index);
1076     Result := FElement.GetAsString;
1077     end;
1078    
1079     function TFBArray.GetAsVariant(index: array of integer): Variant;
1080     begin
1081     GetArraySlice;
1082     FElement.FBufPtr := GetOffset(index);
1083     Result := FElement.GetAsVariant;
1084     end;
1085    
1086 tony 315 function TFBArray.GetAsBCD(index: array of integer): tBCD;
1087     begin
1088     GetArraySlice;
1089     FElement.FBufPtr := GetOffset(index);
1090     Result := FElement.GetAsBCD;
1091     end;
1092    
1093 tony 45 procedure TFBArray.SetAsInteger(index: array of integer; AValue: integer);
1094     begin
1095     FElement.FBufPtr := GetOffset(index);
1096     FElement.SetAsLong(AValue);
1097     end;
1098    
1099     procedure TFBArray.SetAsBoolean(index: array of integer; AValue: boolean);
1100     begin
1101     FElement.FBufPtr := GetOffset(index);
1102     FElement.SetAsBoolean(AValue);
1103     end;
1104    
1105     procedure TFBArray.SetAsCurrency(index: array of integer; Value: Currency);
1106     begin
1107     FElement.FBufPtr := GetOffset(index);
1108     FElement.SetAsCurrency(Value);
1109     end;
1110    
1111     procedure TFBArray.SetAsInt64(index: array of integer; Value: Int64);
1112     begin
1113     FElement.FBufPtr := GetOffset(index);
1114     FElement.SetAsInt64(Value);
1115     end;
1116    
1117     procedure TFBArray.SetAsDate(index: array of integer; Value: TDateTime);
1118     begin
1119     FElement.FBufPtr := GetOffset(index);
1120     FElement.SetAsDate(Value);
1121     end;
1122    
1123     procedure TFBArray.SetAsLong(index: array of integer; Value: Long);
1124     begin
1125     FElement.FBufPtr := GetOffset(index);
1126     FElement.SetAsLong(Value);
1127     end;
1128    
1129     procedure TFBArray.SetAsTime(index: array of integer; Value: TDateTime);
1130     begin
1131     FElement.FBufPtr := GetOffset(index);
1132     FElement.SetAsTime(Value);
1133     end;
1134    
1135 tony 315 procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1136     aTimeZoneID: TFBTimeZoneID);
1137     begin
1138     FElement.FBufPtr := GetOffset(index);
1139     FElement.SetAsTime(aValue,OnDate,aTimeZoneID);
1140     end;
1141    
1142     procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1143     aTimeZone: AnsiString);
1144     begin
1145     FElement.FBufPtr := GetOffset(index);
1146     FElement.SetAsTime(aValue,OnDate, aTimeZone);
1147     end;
1148    
1149 tony 45 procedure TFBArray.SetAsDateTime(index: array of integer; Value: TDateTime);
1150     begin
1151     FElement.FBufPtr := GetOffset(index);
1152     FElement.SetAsDateTime(Value);
1153     end;
1154    
1155 tony 315 procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1156     aTimeZoneID: TFBTimeZoneID);
1157     begin
1158     FElement.FBufPtr := GetOffset(index);
1159     FElement.SetAsDateTime(aValue,aTimeZoneID);
1160     end;
1161    
1162     procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1163     aTimeZone: AnsiString);
1164     begin
1165     FElement.FBufPtr := GetOffset(index);
1166     FElement.SetAsDateTime(aValue,aTimeZone);
1167     end;
1168    
1169     procedure TFBArray.SetAsUTCDateTime(index: array of integer;
1170     aUTCTime: TDateTime);
1171     begin
1172     FElement.FBufPtr := GetOffset(index);
1173     FElement.SetAsUTCDateTime(aUTCTime);
1174     end;
1175    
1176 tony 45 procedure TFBArray.SetAsDouble(index: array of integer; Value: Double);
1177     begin
1178     FElement.FBufPtr := GetOffset(index);
1179     FElement.SetAsDouble(Value);
1180     end;
1181    
1182     procedure TFBArray.SetAsFloat(index: array of integer; Value: Float);
1183     begin
1184     FElement.FBufPtr := GetOffset(index);
1185     FElement.SetAsFloat(Value);
1186     end;
1187    
1188     procedure TFBArray.SetAsShort(index: array of integer; Value: Short);
1189     begin
1190     FElement.FBufPtr := GetOffset(index);
1191     FElement.SetAsShort(Value);
1192     end;
1193    
1194 tony 56 procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1195 tony 45 begin
1196     FElement.FBufPtr := GetOffset(index);
1197     FElement.SetAsString(Value);
1198     end;
1199    
1200     procedure TFBArray.SetAsVariant(index: array of integer; Value: Variant);
1201     begin
1202     FElement.FBufPtr := GetOffset(index);
1203     FElement.SetAsVariant(Value);
1204     end;
1205    
1206 tony 315 procedure TFBArray.SetAsBcd(index: array of integer; aValue: tBCD);
1207     begin
1208     FElement.FBufPtr := GetOffset(index);
1209     FElement.SetAsBcd(aValue);
1210     end;
1211    
1212 tony 45 procedure TFBArray.SetBounds(dim, UpperBound, LowerBound: integer);
1213     begin
1214     with (FMetaData as TFBArrayMetaData) do
1215     begin
1216     if (dim < 0) or (dim > GetDimensions) then
1217     IBError(ibxeInvalidArrayDimensions,[dim]);
1218    
1219     if (UpperBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) or
1220     (LowerBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1221     (UpperBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1222     (LowerBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) then
1223     IBError(ibxArrayBoundsCantIncrease,[nil]);
1224    
1225     PutArraySlice; {Save any changes}
1226    
1227     FArrayDesc.array_desc_bounds[dim].array_bound_upper := UpperBound;
1228     FArrayDesc.array_desc_bounds[dim].array_bound_lower := LowerBound;
1229     end;
1230     AllocateBuffer;
1231     end;
1232    
1233     function TFBArray.GetAttachment: IAttachment;
1234     begin
1235     Result := FAttachment;
1236     end;
1237    
1238     function TFBArray.GetTransaction: ITransaction;
1239     begin
1240     Result := FTransactionIntf;
1241     end;
1242    
1243     procedure TFBArray.AddEventHandler(Handler: TArrayEventHandler);
1244     begin
1245     SetLength(FEventHandlers,Length(FEventHandlers)+1);
1246     FEventHandlers[Length(FEventHandlers)-1] := Handler;
1247     end;
1248    
1249     procedure TFBArray.RemoveEventHandler(Handler: TArrayEventHandler);
1250     var i,j : integer;
1251     begin
1252     for i := Length(FEventHandlers) - 1 downto 0 do
1253 tony 56 if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1254     (TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1255 tony 45 begin
1256     for j := i to Length(FEventHandlers) - 2 do
1257     FEventHandlers[i] := FEventHandlers[i+1];
1258     SetLength(FEventHandlers,Length(FEventHandlers) - 1);
1259     end;
1260     end;
1261    
1262     end.
1263