ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/client/FBArray.pas
Revision: 59
Committed: Mon Mar 13 09:51:56 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBArray.pas
File size: 28380 byte(s)
Log Message:

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