ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBArray.pas
Revision: 291
Committed: Fri Apr 17 10:26:08 2020 UTC (3 years, 11 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBArray.pas
File size: 28708 byte(s)
Log Message:
Changed for 2.3.4 merged into public 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     Classes, SysUtils, IB, IBHeader, FBTransaction,
42     FBSQLData, FBClientAPI, IBExternals, FBActivityMonitor;
43    
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     function GetSQLDialect: integer; override;
79     procedure Changing; override;
80     procedure Changed; override;
81 tony 56 function SQLData: PByte; override;
82 tony 45 function GetDataLength: cardinal; override;
83     function GetCodePage: TSystemCodePage; override;
84 tony 47 function getCharSetID: cardinal; override;
85 tony 45 procedure SetDataLength(len: cardinal); override;
86     procedure SetSQLType(aValue: cardinal); override;
87     public
88 tony 56 constructor Create(anArray: TFBArray; P: PByte);
89 tony 45 function GetSQLType: cardinal; override;
90 tony 56 function GetName: AnsiString; override;
91 tony 45 function GetScale: integer; override;
92     function GetSize: integer;
93 tony 56 function GetAsString: AnsiString; override;
94 tony 45 procedure SetAsLong(Value: Long); override;
95     procedure SetAsShort(Value: Short); override;
96     procedure SetAsInt64(Value: Int64); override;
97 tony 56 procedure SetAsString(Value: AnsiString); override;
98 tony 45 procedure SetAsDouble(Value: Double); override;
99     procedure SetAsFloat(Value: Float); override;
100     procedure SetAsCurrency(Value: Currency); override;
101     end;
102    
103     { TFBArrayMetaData }
104    
105     TFBArrayMetaData = class(TFBInterfacedObject,IArrayMetaData)
106 tony 47 private
107     function GetDType(SQLType: cardinal): UChar;
108 tony 45 protected
109     FArrayDesc: TISC_ARRAY_DESC;
110 tony 47 FCharSetID: integer;
111 tony 60 FAttachment: IAttachment;
112 tony 45 procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
113 tony 56 relationName, columnName: AnsiString); virtual; abstract;
114 tony 45 function NumOfElements: integer;
115     public
116     constructor Create(aAttachment: IAttachment; aTransaction: ITransaction;
117 tony 56 relationName, columnName: AnsiString); overload;
118 tony 60 constructor Create(aAttachment: IAttachment;SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
119 tony 47 Scale: integer; size: cardinal; charSetID: cardinal;
120     dimensions: cardinal; bounds: TArrayBounds); overload;
121 tony 45 function GetCodePage: TSystemCodePage; virtual; abstract;
122    
123     public
124     {IArrayMetaData}
125     function GetSQLType: cardinal;
126 tony 56 function GetSQLTypeName: AnsiString;
127 tony 45 function GetScale: integer;
128     function GetSize: cardinal;
129     function GetCharSetID: cardinal; virtual; abstract;
130 tony 56 function GetTableName: AnsiString;
131     function GetColumnName: AnsiString;
132 tony 45 function GetDimensions: integer;
133     function GetBounds: TArrayBounds;
134     end;
135    
136    
137     { TFBArray }
138    
139     TFBArray = class(TActivityReporter,IArray)
140     private
141 tony 263 FFirebirdClientAPI: TFBClientAPI;
142 tony 45 FMetaData: IArrayMetaData;
143     FIsNew: boolean;
144     FLoaded: boolean;
145     FModified: boolean;
146     FAttachment: IAttachment;
147     FTransactionIntf: ITransaction;
148     FTransactionSeqNo: integer;
149     FSQLDialect: integer;
150     FOffsets: array of integer;
151     FElement: TFBArrayElement;
152     FElementIntf: IUnknown;
153     FElementSize: integer;
154     FEventHandlers: array of TArrayEventHandler;
155     procedure GetArraySlice;
156     procedure PutArraySlice(Force: boolean=false);
157 tony 56 function GetOffset(index: array of integer): PByte;
158 tony 45 function GetDataLength: short;
159     protected
160 tony 56 FBuffer: PByte;
161 tony 45 FBufSize: ISC_LONG;
162     FArrayID: TISC_QUAD;
163     procedure AllocateBuffer; virtual;
164 tony 291 procedure Changing; virtual;
165     procedure Changed; virtual;
166 tony 45 function GetArrayDesc: PISC_ARRAY_DESC;
167     procedure InternalGetSlice; virtual; abstract;
168     procedure InternalPutSlice(Force: boolean); virtual; abstract;
169     public
170     constructor Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
171     aField: IArrayMetaData); overload;
172     constructor Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
173     aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
174     destructor Destroy; override;
175     function GetSQLDialect: integer;
176     procedure TransactionEnding(aTransaction: ITransaction; Force: boolean);
177    
178     public
179     {IArrayMetaData}
180     function GetSQLType: cardinal;
181 tony 56 function GetSQLTypeName: AnsiString;
182 tony 45 function GetScale: integer;
183     function GetSize: cardinal;
184     function GetCharSetID: cardinal;
185 tony 56 function GetTableName: AnsiString;
186     function GetColumnName: AnsiString;
187 tony 45 function GetDimensions: integer;
188     function GetBounds: TArrayBounds;
189     {IArray}
190     function GetArrayID: TISC_QUAD;
191     procedure Clear;
192     function IsEmpty: boolean;
193     procedure PreLoad;
194     procedure CancelChanges;
195     procedure SaveChanges;
196     function GetAsInteger(index: array of integer): integer;
197     function GetAsBoolean(index: array of integer): boolean;
198     function GetAsCurrency(index: array of integer): Currency;
199     function GetAsInt64(index: array of integer): Int64;
200     function GetAsDateTime(index: array of integer): TDateTime;
201     function GetAsDouble(index: array of integer): Double;
202     function GetAsFloat(index: array of integer): Float;
203     function GetAsLong(index: array of integer): Long;
204     function GetAsShort(index: array of integer): Short;
205 tony 56 function GetAsString(index: array of integer): AnsiString;
206 tony 45 function GetAsVariant(index: array of integer): Variant;
207     procedure SetAsInteger(index: array of integer; AValue: integer);
208     procedure SetAsBoolean(index: array of integer; AValue: boolean);
209     procedure SetAsCurrency(index: array of integer; Value: Currency);
210     procedure SetAsInt64(index: array of integer; Value: Int64);
211     procedure SetAsDate(index: array of integer; Value: TDateTime);
212     procedure SetAsLong(index: array of integer; Value: Long);
213     procedure SetAsTime(index: array of integer; Value: TDateTime);
214     procedure SetAsDateTime(index: array of integer; Value: TDateTime);
215     procedure SetAsDouble(index: array of integer; Value: Double);
216     procedure SetAsFloat(index: array of integer; Value: Float);
217     procedure SetAsShort(index: array of integer; Value: Short);
218 tony 56 procedure SetAsString(index: array of integer; Value: AnsiString);
219 tony 45 procedure SetAsVariant(index: array of integer; Value: Variant);
220     procedure SetBounds(dim, UpperBound, LowerBound: integer);
221     function GetAttachment: IAttachment;
222     function GetTransaction: ITransaction;
223     procedure AddEventHandler(Handler: TArrayEventHandler);
224     procedure RemoveEventHandler(Handler: TArrayEventHandler);
225     end;
226    
227     implementation
228    
229     uses FBMessages;
230    
231     { TFBArrayElement }
232    
233     function TFBArrayElement.GetSQLDialect: integer;
234     begin
235     Result := FArray.GetSQLDialect;
236     end;
237    
238     procedure TFBArrayElement.Changing;
239     begin
240     inherited Changing;
241     FArray.Changing;
242     end;
243    
244     procedure TFBArrayElement.Changed;
245     begin
246     inherited Changed;
247     FArray.Changed;
248     end;
249    
250 tony 56 function TFBArrayElement.SQLData: PByte;
251 tony 45 begin
252     Result := FBufPtr;
253     end;
254    
255     function TFBArrayElement.GetDataLength: cardinal;
256     begin
257     Result := FArray.GetDataLength
258     end;
259    
260     function TFBArrayElement.GetCodePage: TSystemCodePage;
261     begin
262     Result := (FArray.FMetaData as TFBArrayMetaData).GetCodePage;
263     end;
264    
265 tony 47 function TFBArrayElement.getCharSetID: cardinal;
266     begin
267     Result := (FArray.FMetaData as TFBArrayMetaData).GetCharSetID;
268     end;
269    
270 tony 45 procedure TFBArrayElement.SetDataLength(len: cardinal);
271     begin
272     if len > GetDataLength then
273     IBError(ibxeArrayElementOverFlow,[nil]);
274     end;
275    
276 tony 56 constructor TFBArrayElement.Create(anArray: TFBArray; P: PByte);
277 tony 45 begin
278 tony 263 inherited Create(anArray.FFirebirdClientAPI);
279 tony 45 FArray := anArray;
280     FBufPtr := P;
281     end;
282    
283     function TFBArrayElement.GetSQLType: cardinal;
284     begin
285     Result := FArray.FMetaData.GetSQLType;
286     end;
287    
288 tony 56 function TFBArrayElement.GetName: AnsiString;
289 tony 45 begin
290     Result := FArray.FMetaData.GetColumnName;
291     end;
292    
293     function TFBArrayElement.GetScale: integer;
294     begin
295     Result := FArray.FMetaData.GetScale;
296     end;
297    
298     function TFBArrayElement.GetSize: integer;
299     begin
300     Result := GetDataLength;
301     end;
302    
303 tony 56 function TFBArrayElement.GetAsString: AnsiString;
304 tony 45 var rs: RawByteString;
305     begin
306     case GetSQLType of
307     SQL_VARYING:
308     begin
309 tony 56 rs := strpas(PAnsiChar(FBufPtr));
310 tony 45 SetCodePage(rs,GetCodePage,false);
311     Result := rs;
312     end;
313     SQL_TEXT:
314     begin
315 tony 56 SetString(rs,PAnsiChar(FBufPtr),GetDataLength);
316 tony 45 SetCodePage(rs,GetCodePage,false);
317     Result := rs;
318     end
319     else
320     Result := inherited GetAsString;
321     end;
322     end;
323    
324     procedure TFBArrayElement.SetAsLong(Value: Long);
325     begin
326     AsInt64 := Value;
327     end;
328    
329     procedure TFBArrayElement.SetAsShort(Value: Short);
330     begin
331     AsInt64 := Value;
332     end;
333    
334     procedure TFBArrayElement.SetAsInt64(Value: Int64);
335     begin
336     CheckActive;
337     case GetSQLType of
338     SQL_LONG:
339     PLong(SQLData)^ := Value;
340     SQL_SHORT:
341     PShort(SQLData)^ := Value;
342     SQL_INT64:
343     PInt64(SQLData)^ := Value;
344     SQL_TEXT, SQL_VARYING:
345     SetAsString(IntToStr(Value));
346     SQL_D_FLOAT,
347     SQL_DOUBLE:
348     PDouble(SQLData)^ := Value;
349     SQL_FLOAT:
350     PSingle(SQLData)^ := Value;
351     else
352     IBError(ibxeInvalidDataConversion, [nil]);
353     end;
354     Changed;
355     end;
356    
357 tony 56 procedure TFBArrayElement.SetAsString(Value: AnsiString);
358 tony 45 var len: integer;
359     ElementSize: integer;
360     begin
361     CheckActive;
362     case GetSQLType of
363     SQL_BOOLEAN:
364 tony 56 if AnsiCompareText(Value,STrue) = 0 then
365 tony 45 AsBoolean := true
366     else
367 tony 56 if AnsiCompareText(Value,SFalse) = 0 then
368 tony 45 AsBoolean := false
369     else
370     IBError(ibxeInvalidDataConversion,[nil]);
371    
372     SQL_VARYING:
373     begin
374     Value := Transliterate(Value,GetCodePage);
375     len := Length(Value);
376     ElementSize := GetDataLength;
377     if len > ElementSize - 2 then
378     len := ElementSize - 2;
379     if Len > 0 then
380     Move(Value[1],FBufPtr^,len);
381     if Len < ElementSize - 2 then
382 tony 56 (FBufPtr+len)^ := 0;
383 tony 45 Changed;
384     end;
385    
386     SQL_TEXT:
387     begin
388     Value := Transliterate(Value,GetCodePage);
389     ElementSize := GetDataLength;
390     FillChar(FBufPtr^,ElementSize,' ');
391     len := Length(Value);
392     if len > ElementSize - 1 then len := ElementSize - 1;
393     Move(Value[1],FBufPtr^,len);
394     Changed;
395     end;
396    
397     SQL_SHORT,
398     SQL_LONG,
399     SQL_INT64:
400     if trim(Value) = '' then
401     SetAsInt64(0)
402     else
403 tony 59 SetAsInt64(AdjustScaleFromCurrency(StrToCurr(Value),GetScale));
404 tony 45
405     SQL_D_FLOAT,
406     SQL_DOUBLE,
407     SQL_FLOAT:
408     if trim(Value) = '' then
409     SetAsDouble(0)
410     else
411     SetAsDouble(StrToFloat(Value));
412    
413     SQL_TIMESTAMP:
414     SetAsDateTime(StrToDateTime(Value));
415    
416     SQL_TYPE_DATE:
417     SetAsDate(StrToDateTime(Value));
418    
419     SQL_TYPE_TIME:
420     SetAsTime(StrToDateTime(Value));
421    
422     else
423     IBError(ibxeInvalidDataConversion,[nil]);
424     end;
425     end;
426    
427     procedure TFBArrayElement.SetAsDouble(Value: Double);
428     begin
429     CheckActive;
430     case GetSQLType of
431     SQL_D_FLOAT,
432     SQL_DOUBLE:
433     PDouble(SQLData)^ := Value;
434     SQL_FLOAT:
435     PSingle(SQLData)^ := Value;
436     SQL_SHORT:
437     if Scale < 0 then
438     PShort(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
439     else
440     IBError(ibxeInvalidDataConversion, [nil]);
441     SQL_LONG:
442     if Scale < 0 then
443     PLong(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
444     else
445     IBError(ibxeInvalidDataConversion, [nil]);
446     SQL_INT64:
447     if Scale < 0 then
448     PInt64(SQLData)^ := AdjustScaleFromDouble(Value,Scale)
449     else
450     IBError(ibxeInvalidDataConversion, [nil]);
451     SQL_TEXT, SQL_VARYING:
452     AsString := FloatToStr(Value);
453     else
454     IBError(ibxeInvalidDataConversion, [nil]);
455     end;
456     Changed;
457     end;
458    
459     procedure TFBArrayElement.SetAsFloat(Value: Float);
460     begin
461     AsDouble := Value;
462     end;
463    
464     procedure TFBArrayElement.SetAsCurrency(Value: Currency);
465     begin
466     CheckActive;
467     if (GetSQLDialect < 3) or (SQLType <> SQL_INT64) then
468     AsDouble := Value
469     else
470     begin
471     if Scale = -4 then
472     PCurrency(SQLData)^ := Value
473     else
474     PInt64(SQLData)^ := AdjustScaleFromCurrency(Value,Scale);
475     Changed;
476     end
477     end;
478    
479     procedure TFBArrayElement.SetSQLType(aValue: cardinal);
480     begin
481     if aValue = GetSQLType then
482     IBError(ibxeInvalidDataConversion, [nil]);
483     end;
484    
485     {TFBArrayMetaData}
486    
487     constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
488 tony 56 aTransaction: ITransaction; relationName, columnName: AnsiString);
489 tony 45 begin
490     inherited Create;
491 tony 60 FAttachment := aAttachment;
492 tony 45 LoadMetaData(aAttachment,aTransaction,relationName, columnName);
493     end;
494    
495 tony 60 constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
496     SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
497     Scale: integer; size: cardinal; charSetID: cardinal; dimensions: cardinal;
498     bounds: TArrayBounds);
499 tony 47 var i: integer;
500     begin
501     inherited Create;
502 tony 60 FAttachment := aAttachment;
503 tony 47 with FArrayDesc do
504     begin
505     array_desc_dtype := GetDType(SQLType);
506 tony 56 array_desc_scale := Scale;
507 tony 47 array_desc_length := UShort(size);
508     StrPLCopy(array_desc_field_name,columnName,sizeof(array_desc_field_name));
509     StrPLCopy(array_desc_relation_name,tableName,sizeof(array_desc_relation_name));
510     array_desc_dimensions := dimensions;
511     array_desc_flags := 0;
512     FCharSetID := charSetID;
513     for i := 0 to Length(bounds) - 1 do
514     begin
515     array_desc_bounds[i].array_bound_lower := bounds[i].LowerBound;
516     array_desc_bounds[i].array_bound_upper := bounds[i].UpperBound;
517     end;
518     end;
519     end;
520    
521 tony 45 function TFBArrayMetaData.GetSQLType: cardinal;
522     begin
523     case FArrayDesc.array_desc_dtype of
524     blr_cstring,
525     blr_cstring2,
526     blr_text,blr_text2:
527     Result := SQL_TEXT;
528     blr_short:
529     Result := SQL_SHORT;
530     blr_long:
531     Result := SQL_LONG;
532     blr_quad, blr_blob_id:
533     Result := SQL_QUAD;
534     blr_float:
535     Result := SQL_FLOAT;
536     blr_double,blr_d_float:
537     Result := SQL_D_FLOAT;
538     blr_timestamp:
539     Result := SQL_TIMESTAMP;
540     blr_varying,blr_varying2:
541     Result := SQL_VARYING;
542     blr_sql_date:
543     Result := SQL_TYPE_DATE;
544     blr_sql_time:
545     Result := SQL_TYPE_TIME;
546     blr_int64:
547     Result := SQL_INT64;
548     end;
549     end;
550    
551 tony 56 function TFBArrayMetaData.GetSQLTypeName: AnsiString;
552 tony 45 begin
553     Result := TSQLDataItem.GetSQLTypeName(GetSQLType);
554     end;
555    
556     function TFBArrayMetaData.GetScale: integer;
557     begin
558     Result := byte(FArrayDesc.array_desc_scale);
559     end;
560    
561     function TFBArrayMetaData.GetSize: cardinal;
562     begin
563     Result := FArrayDesc.array_desc_length;
564     end;
565    
566 tony 56 function TFBArrayMetaData.GetTableName: AnsiString;
567 tony 45 begin
568     with FArrayDesc do
569 tony 56 SetString(Result,PAnsiChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
570 tony 45 Result := trim(Result);
571     end;
572    
573 tony 56 function TFBArrayMetaData.GetColumnName: AnsiString;
574 tony 45 begin
575     with FArrayDesc do
576 tony 56 SetString(Result,PAnsiChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
577 tony 45 Result := trim(Result);
578     end;
579    
580     function TFBArrayMetaData.GetDimensions: integer;
581     begin
582     Result := FArrayDesc.array_desc_dimensions;
583     end;
584    
585     function TFBArrayMetaData.GetBounds: TArrayBounds;
586     var i: integer;
587     begin
588     SetLength(Result,GetDimensions);
589     for i := 0 to GetDimensions - 1 do
590     begin
591     Result[i].UpperBound := FArrayDesc.array_desc_bounds[i].array_bound_upper;
592     Result[i].LowerBound := FArrayDesc.array_desc_bounds[i].array_bound_lower;
593     end;
594     end;
595    
596 tony 47 function TFBArrayMetaData.GetDType(SQLType: cardinal): UChar;
597     begin
598     case SQLType of
599     SQL_TEXT:
600     Result := blr_text;
601     SQL_SHORT:
602     Result := blr_short;
603     SQL_LONG:
604     Result := blr_long;
605     SQL_QUAD:
606     Result := blr_quad;
607     SQL_FLOAT:
608     Result := blr_float;
609     SQL_D_FLOAT:
610     Result := blr_double;
611     SQL_TIMESTAMP:
612     Result := blr_timestamp;
613     SQL_VARYING:
614     Result := blr_varying;
615     SQL_TYPE_DATE:
616     Result := blr_sql_date;
617     SQL_TYPE_TIME:
618     Result := blr_sql_time;
619     SQL_INT64:
620     Result := blr_int64;
621     end;
622     end;
623    
624 tony 45 function TFBArrayMetaData.NumOfElements: integer;
625     var i: integer;
626     Bounds: TArrayBounds;
627     begin
628     Result := 1;
629     Bounds := GetBounds;
630     for i := 0 to Length(Bounds) - 1 do
631 tony 56 Result := Result * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
632 tony 45 end;
633    
634    
635     { TFBArray }
636    
637     procedure TFBArray.AllocateBuffer;
638     var i: integer;
639     l: integer;
640     Bounds: TArrayBounds;
641     Dims: integer;
642     begin
643     SetLength(FOffsets,0);
644     FreeMem(FBuffer);
645     FBuffer := nil;
646     FLoaded := false;
647    
648     with FMetaData as TFBArrayMetaData do
649     begin
650     l := NumOfElements;
651     FElementSize := FArrayDesc.array_desc_length;
652     case GetSQLType of
653     SQL_VARYING:
654 tony 56 FElementSize := FElementSize + 2;
655 tony 45 SQL_TEXT:
656 tony 56 FElementSize := FElementSize + 1;
657 tony 45 end;
658     FBufSize := FElementSize * l;
659    
660 tony 263 with FFirebirdClientAPI do
661 tony 45 IBAlloc(FBuffer,0,FBufSize);
662    
663     Dims := GetDimensions;
664     SetLength(FOffsets,GetDimensions);
665     Bounds := GetBounds;
666     if FArrayDesc.array_desc_flags = 0 {row major} then
667     begin
668     FOffsets[0] := 1;
669     for i := 0 to Dims - 2 do
670     FOffsets[i+1] := FOffsets[i] * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
671     end
672     else
673     begin
674     {column major}
675     FOffsets[Dims-1] := 1;
676     for i := Dims - 1 downto 1 do
677     FOffsets[i-1] := FOffsets[i] * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
678     end;
679     end;
680     end;
681    
682     procedure TFBArray.Changing;
683     var i: integer;
684     begin
685     for i := 0 to Length(FEventHandlers) - 1 do
686     FEventHandlers[i](self,arChanging);
687     end;
688    
689     procedure TFBArray.Changed;
690     var i: integer;
691     begin
692     FModified := true;
693     for i := 0 to Length(FEventHandlers) - 1 do
694     FEventHandlers[i](self,arChanged);
695     end;
696    
697     procedure TFBArray.GetArraySlice;
698     begin
699     if FIsNew or FLoaded then Exit;
700     InternalGetSlice;
701     FLoaded := true;
702     end;
703    
704     procedure TFBArray.PutArraySlice(Force: boolean);
705     begin
706     if not FModified or not FTransactionIntf.InTransaction or
707     (FTransactionSeqNo < (FTransactionIntf as TFBTransaction).TransactionSeqNo) then Exit;
708    
709     InternalPutSlice(Force);
710     FModified := false;
711     FIsNew := false;
712     end;
713    
714 tony 56 function TFBArray.GetOffset(index: array of integer): PByte;
715 tony 45 var i: integer;
716     Bounds: TArrayBounds;
717     FlatIndex: integer;
718     begin
719     if FMetaData.GetDimensions <> Length(index) then
720     IBError(ibxeInvalidArrayDimensions,[Length(index)]);
721    
722     FlatIndex := 0;
723     Bounds := FMetaData.GetBounds;
724     for i := 0 to Length(index) - 1 do
725     begin
726     if (index[i] < Bounds[i].LowerBound) or (index[i] > Bounds[i].UpperBound) then
727     IBError(ibxeInvalidSubscript,[index[i],i]);
728    
729 tony 56 FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
730 tony 45 end;
731     Result := FBuffer + FlatIndex*FElementSize;
732     end;
733    
734     function TFBArray.GetDataLength: short;
735     begin
736     Result := FElementSize;
737     end;
738    
739     function TFBArray.GetArrayDesc: PISC_ARRAY_DESC;
740     begin
741     Result := @((FMetaData as TFBArrayMetaData).FArrayDesc);
742     end;
743    
744     constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction; aField: IArrayMetaData);
745     begin
746     inherited Create(aTransaction);
747     FMetaData := aField;
748     FAttachment := aAttachment;
749 tony 263 FFirebirdClientAPI := aTransaction.FirebirdAPI;
750 tony 45 FTransactionIntf := aTransaction;
751     FTransactionSeqNo := aTransaction.TransactionSeqNo;
752     FIsNew := true;
753     FModified := false;
754     FSQLDialect := aAttachment.GetSQLDialect;
755     AllocateBuffer;
756     FElement := TFBArrayElement.Create(self,FBuffer);
757     FElementIntf := FElement;
758     Setlength(FEventHandlers,0);
759     end;
760    
761     constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
762     aField: IArrayMetaData; ArrayID: TISC_QUAD);
763     begin
764     inherited Create(aTransaction);
765     FMetaData := aField;
766     FArrayID := ArrayID;
767     FAttachment := aAttachment;
768 tony 291 FFirebirdClientAPI := aTransaction.FirebirdAPI;
769 tony 45 FTransactionIntf := aTransaction;
770     FTransactionSeqNo := aTransaction.TransactionSeqNo;
771     FIsNew := false;
772     FModified := false;
773     FSQLDialect := aAttachment.GetSQLDialect;
774     AllocateBuffer;
775     FElement := TFBArrayElement.Create(self,FBuffer);
776     FElementIntf := FElement;
777     Setlength(FEventHandlers,0);
778     end;
779    
780     destructor TFBArray.Destroy;
781     begin
782     FreeMem(FBuffer);
783     inherited Destroy;
784     end;
785    
786     function TFBArray.GetArrayID: TISC_QUAD;
787     begin
788     PutArraySlice;
789     Result := FArrayID;
790     end;
791    
792     procedure TFBArray.Clear;
793     begin
794     FIsNew := true;
795     FModified := false;
796     FArrayID.gds_quad_high := 0;
797     FArrayID.gds_quad_low := 0;
798     AllocateBuffer;
799     end;
800    
801     function TFBArray.IsEmpty: boolean;
802     begin
803     Result := FIsNew and not FModified;
804     end;
805    
806     procedure TFBArray.PreLoad;
807     begin
808     GetArraySlice;
809     end;
810    
811     procedure TFBArray.CancelChanges;
812     begin
813     FModified := false;
814     AllocateBuffer;
815     end;
816    
817     procedure TFBArray.SaveChanges;
818     begin
819     PutArraySlice;
820     end;
821    
822     function TFBArray.GetSQLDialect: integer;
823     begin
824     Result := FSQLDialect;
825     end;
826    
827     procedure TFBArray.TransactionEnding(aTransaction: ITransaction; Force: boolean
828     );
829     begin
830     if (aTransaction = FTransactionIntf) and FModified and not FIsNew then
831     PutArraySlice(Force);
832     end;
833    
834     function TFBArray.GetSQLType: cardinal;
835     begin
836     Result := FMetaData.GetSQLType;
837     end;
838    
839 tony 56 function TFBArray.GetSQLTypeName: AnsiString;
840 tony 45 begin
841     Result := FMetaData.GetSQLTypeName;
842     end;
843    
844     function TFBArray.GetScale: integer;
845     begin
846     Result := FMetaData.GetScale;
847     end;
848    
849     function TFBArray.GetSize: cardinal;
850     begin
851     Result := FMetaData.GetSize;
852     end;
853    
854     function TFBArray.GetCharSetID: cardinal;
855     begin
856     Result := FMetaData.GetCharSetID;
857     end;
858    
859 tony 56 function TFBArray.GetTableName: AnsiString;
860 tony 45 begin
861     Result := FMetaData.GetTableName;
862     end;
863    
864 tony 56 function TFBArray.GetColumnName: AnsiString;
865 tony 45 begin
866     Result := FMetaData.GetColumnName;
867     end;
868    
869     function TFBArray.GetDimensions: integer;
870     begin
871     Result := FMetaData.GetDimensions;
872     end;
873    
874     function TFBArray.GetBounds: TArrayBounds;
875     begin
876     Result := FMetaData.GetBounds;
877     end;
878    
879     function TFBArray.GetAsInteger(index: array of integer): integer;
880     begin
881     GetArraySlice;
882     FElement.FBufPtr := GetOffset(index);
883     Result := FElement.GetAsLong;
884     end;
885    
886     function TFBArray.GetAsBoolean(index: array of integer): boolean;
887     begin
888     GetArraySlice;
889     FElement.FBufPtr := GetOffset(index);
890     Result := FElement.GetAsBoolean;
891     end;
892    
893     function TFBArray.GetAsCurrency(index: array of integer): Currency;
894     begin
895     GetArraySlice;
896     FElement.FBufPtr := GetOffset(index);
897     Result := FElement.GetAsCurrency;
898     end;
899    
900     function TFBArray.GetAsInt64(index: array of integer): Int64;
901     begin
902     GetArraySlice;
903     FElement.FBufPtr := GetOffset(index);
904     Result := FElement.GetAsInt64;
905     end;
906    
907     function TFBArray.GetAsDateTime(index: array of integer): TDateTime;
908     begin
909     GetArraySlice;
910     FElement.FBufPtr := GetOffset(index);
911     Result := FElement.GetAsDateTime;
912     end;
913    
914     function TFBArray.GetAsDouble(index: array of integer): Double;
915     begin
916     GetArraySlice;
917     FElement.FBufPtr := GetOffset(index);
918     Result := FElement.GetAsDouble;
919     end;
920    
921     function TFBArray.GetAsFloat(index: array of integer): Float;
922     begin
923     GetArraySlice;
924     FElement.FBufPtr := GetOffset(index);
925     Result := FElement.GetAsFloat;
926     end;
927    
928     function TFBArray.GetAsLong(index: array of integer): Long;
929     begin
930     GetArraySlice;
931     FElement.FBufPtr := GetOffset(index);
932     Result := FElement.GetAsLong;
933     end;
934    
935     function TFBArray.GetAsShort(index: array of integer): Short;
936     begin
937     GetArraySlice;
938     FElement.FBufPtr := GetOffset(index);
939     Result := FElement.GetAsShort;
940     end;
941    
942 tony 56 function TFBArray.GetAsString(index: array of integer): AnsiString;
943 tony 45 begin
944     GetArraySlice;
945     FElement.FBufPtr := GetOffset(index);
946     Result := FElement.GetAsString;
947     end;
948    
949     function TFBArray.GetAsVariant(index: array of integer): Variant;
950     begin
951     GetArraySlice;
952     FElement.FBufPtr := GetOffset(index);
953     Result := FElement.GetAsVariant;
954     end;
955    
956     procedure TFBArray.SetAsInteger(index: array of integer; AValue: integer);
957     begin
958     FElement.FBufPtr := GetOffset(index);
959     FElement.SetAsLong(AValue);
960     end;
961    
962     procedure TFBArray.SetAsBoolean(index: array of integer; AValue: boolean);
963     begin
964     FElement.FBufPtr := GetOffset(index);
965     FElement.SetAsBoolean(AValue);
966     end;
967    
968     procedure TFBArray.SetAsCurrency(index: array of integer; Value: Currency);
969     begin
970     FElement.FBufPtr := GetOffset(index);
971     FElement.SetAsCurrency(Value);
972     end;
973    
974     procedure TFBArray.SetAsInt64(index: array of integer; Value: Int64);
975     begin
976     FElement.FBufPtr := GetOffset(index);
977     FElement.SetAsInt64(Value);
978     end;
979    
980     procedure TFBArray.SetAsDate(index: array of integer; Value: TDateTime);
981     begin
982     FElement.FBufPtr := GetOffset(index);
983     FElement.SetAsDate(Value);
984     end;
985    
986     procedure TFBArray.SetAsLong(index: array of integer; Value: Long);
987     begin
988     FElement.FBufPtr := GetOffset(index);
989     FElement.SetAsLong(Value);
990     end;
991    
992     procedure TFBArray.SetAsTime(index: array of integer; Value: TDateTime);
993     begin
994     FElement.FBufPtr := GetOffset(index);
995     FElement.SetAsTime(Value);
996     end;
997    
998     procedure TFBArray.SetAsDateTime(index: array of integer; Value: TDateTime);
999     begin
1000     FElement.FBufPtr := GetOffset(index);
1001     FElement.SetAsDateTime(Value);
1002     end;
1003    
1004     procedure TFBArray.SetAsDouble(index: array of integer; Value: Double);
1005     begin
1006     FElement.FBufPtr := GetOffset(index);
1007     FElement.SetAsDouble(Value);
1008     end;
1009    
1010     procedure TFBArray.SetAsFloat(index: array of integer; Value: Float);
1011     begin
1012     FElement.FBufPtr := GetOffset(index);
1013     FElement.SetAsFloat(Value);
1014     end;
1015    
1016     procedure TFBArray.SetAsShort(index: array of integer; Value: Short);
1017     begin
1018     FElement.FBufPtr := GetOffset(index);
1019     FElement.SetAsShort(Value);
1020     end;
1021    
1022 tony 56 procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1023 tony 45 begin
1024     FElement.FBufPtr := GetOffset(index);
1025     FElement.SetAsString(Value);
1026     end;
1027    
1028     procedure TFBArray.SetAsVariant(index: array of integer; Value: Variant);
1029     begin
1030     FElement.FBufPtr := GetOffset(index);
1031     FElement.SetAsVariant(Value);
1032     end;
1033    
1034     procedure TFBArray.SetBounds(dim, UpperBound, LowerBound: integer);
1035     begin
1036     with (FMetaData as TFBArrayMetaData) do
1037     begin
1038     if (dim < 0) or (dim > GetDimensions) then
1039     IBError(ibxeInvalidArrayDimensions,[dim]);
1040    
1041     if (UpperBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) or
1042     (LowerBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1043     (UpperBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1044     (LowerBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) then
1045     IBError(ibxArrayBoundsCantIncrease,[nil]);
1046    
1047     PutArraySlice; {Save any changes}
1048    
1049     FArrayDesc.array_desc_bounds[dim].array_bound_upper := UpperBound;
1050     FArrayDesc.array_desc_bounds[dim].array_bound_lower := LowerBound;
1051     end;
1052     AllocateBuffer;
1053     end;
1054    
1055     function TFBArray.GetAttachment: IAttachment;
1056     begin
1057     Result := FAttachment;
1058     end;
1059    
1060     function TFBArray.GetTransaction: ITransaction;
1061     begin
1062     Result := FTransactionIntf;
1063     end;
1064    
1065     procedure TFBArray.AddEventHandler(Handler: TArrayEventHandler);
1066     begin
1067     SetLength(FEventHandlers,Length(FEventHandlers)+1);
1068     FEventHandlers[Length(FEventHandlers)-1] := Handler;
1069     end;
1070    
1071     procedure TFBArray.RemoveEventHandler(Handler: TArrayEventHandler);
1072     var i,j : integer;
1073     begin
1074     for i := Length(FEventHandlers) - 1 downto 0 do
1075 tony 56 if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1076     (TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1077 tony 45 begin
1078     for j := i to Length(FEventHandlers) - 2 do
1079     FEventHandlers[i] := FEventHandlers[i+1];
1080     SetLength(FEventHandlers,Length(FEventHandlers) - 1);
1081     end;
1082     end;
1083    
1084     end.
1085