ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/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

# Content
1 (*
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 {$IFDEF MSWINDOWS}
29 {$DEFINE WINDOWS}
30 {$ENDIF}
31
32 {$IFDEF FPC}
33 {$mode delphi}
34 {$codepage UTF8}
35 {$interfaces COM}
36 {$ENDIF}
37
38 interface
39
40 uses
41 Classes, SysUtils, IBHeader, IB, FBTransaction,
42 FBSQLData, FBClientAPI, IBExternals, FBActivityMonitor, FmtBCD;
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 FBufPtr: PByte;
76 FArray: TFBArray;
77 protected
78 function GetAttachment: IAttachment; override;
79 function GetSQLDialect: integer; override;
80 procedure Changing; override;
81 procedure Changed; override;
82 function SQLData: PByte; override;
83 function GetDataLength: cardinal; override;
84 function GetCodePage: TSystemCodePage; override;
85 function getCharSetID: cardinal; override;
86 procedure SetDataLength(len: cardinal); override;
87 procedure SetSQLType(aValue: cardinal); override;
88 public
89 constructor Create(anArray: TFBArray; P: PByte);
90 function GetSQLType: cardinal; override;
91 function GetName: AnsiString; override;
92 function GetScale: integer; override;
93 function GetSize: integer;
94 function GetCharSetWidth: integer; override;
95 function GetAsString: AnsiString; override;
96 procedure SetAsLong(Value: Long); override;
97 procedure SetAsShort(Value: Short); override;
98 procedure SetAsInt64(Value: Int64); override;
99 procedure SetAsString(Value: AnsiString); override;
100 procedure SetAsDouble(Value: Double); override;
101 procedure SetAsFloat(Value: Float); override;
102 procedure SetAsCurrency(Value: Currency); override;
103 procedure SetAsBcd(aValue: tBCD); override;
104 end;
105
106 { TFBArrayMetaData }
107
108 TFBArrayMetaData = class(TFBInterfacedObject,IArrayMetaData)
109 private
110 function GetDType(SQLType: cardinal): UChar;
111 protected
112 FArrayDesc: TISC_ARRAY_DESC;
113 FCharSetID: integer;
114 FAttachment: IAttachment;
115 procedure LoadMetaData(aAttachment: IAttachment; aTransaction: ITransaction;
116 relationName, columnName: AnsiString); virtual; abstract;
117 function NumOfElements: integer;
118 public
119 constructor Create(aAttachment: IAttachment; aTransaction: ITransaction;
120 relationName, columnName: AnsiString); overload;
121 constructor Create(aAttachment: IAttachment;SQLType: cardinal; tableName: AnsiString; columnName: AnsiString;
122 Scale: integer; size: cardinal; charSetID: cardinal;
123 dimensions: cardinal; bounds: TArrayBounds); overload;
124 function GetCodePage: TSystemCodePage; virtual; abstract;
125
126 public
127 {IArrayMetaData}
128 function GetSQLType: cardinal;
129 function GetSQLTypeName: AnsiString;
130 function GetScale: integer;
131 function GetSize: cardinal;
132 function GetCharSetID: cardinal; virtual; abstract;
133 function GetCharSetWidth: integer; virtual; abstract;
134 function GetTableName: AnsiString;
135 function GetColumnName: AnsiString;
136 function GetDimensions: integer;
137 function GetBounds: TArrayBounds;
138 end;
139
140
141 { TFBArray }
142
143 TFBArray = class(TActivityReporter,IArray,ITransactionUser)
144 private
145 FFirebirdClientAPI: TFBClientAPI;
146 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 function GetOffset(index: array of integer): PByte;
162 function GetDataLength: short;
163 protected
164 FBuffer: PByte;
165 FBufSize: ISC_LONG;
166 FArrayID: TISC_QUAD;
167 procedure AllocateBuffer; virtual;
168 procedure Changing; virtual;
169 procedure Changed; virtual;
170 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
181 public
182 {ITransactionUser}
183 procedure TransactionEnding(aTransaction: ITransaction; Force: boolean);
184
185 public
186 {IArrayMetaData}
187 function GetSQLType: cardinal;
188 function GetSQLTypeName: AnsiString;
189 function GetScale: integer;
190 function GetSize: cardinal;
191 function GetCharSetID: cardinal;
192 function GetCharSetWidth: integer;
193 function GetTableName: AnsiString;
194 function GetColumnName: AnsiString;
195 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 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 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 function GetAsString(index: array of integer): AnsiString;
219 function GetAsVariant(index: array of integer): Variant;
220 function GetAsBCD(index: array of integer): tBCD;
221 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 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 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 procedure SetAsString(index: array of integer; Value: AnsiString);
238 procedure SetAsVariant(index: array of integer; Value: Variant);
239 procedure SetAsBcd(index: array of integer; aValue: tBCD);
240 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 function TFBArrayElement.GetAttachment: IAttachment;
254 begin
255 Result := FArray.GetAttachment;
256 end;
257
258 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 function TFBArrayElement.SQLData: PByte;
276 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 function TFBArrayElement.getCharSetID: cardinal;
291 begin
292 Result := (FArray.FMetaData as TFBArrayMetaData).GetCharSetID;
293 end;
294
295 procedure TFBArrayElement.SetDataLength(len: cardinal);
296 begin
297 if len > GetDataLength then
298 IBError(ibxeArrayElementOverFlow,[nil]);
299 end;
300
301 constructor TFBArrayElement.Create(anArray: TFBArray; P: PByte);
302 begin
303 inherited Create(anArray.FFirebirdClientAPI);
304 FArray := anArray;
305 FBufPtr := P;
306 end;
307
308 function TFBArrayElement.GetSQLType: cardinal;
309 begin
310 Result := FArray.FMetaData.GetSQLType;
311 end;
312
313 function TFBArrayElement.GetName: AnsiString;
314 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 function TFBArrayElement.GetCharSetWidth: integer;
329 begin
330 Result := FArray.FMetaData.GetCharSetWidth;
331 end;
332
333 function TFBArrayElement.GetAsString: AnsiString;
334 var rs: RawByteString;
335 begin
336 case GetSQLType of
337 SQL_VARYING:
338 begin
339 rs := strpas(PAnsiChar(FBufPtr));
340 SetCodePage(rs,GetCodePage,false);
341 Result := rs;
342 end;
343 SQL_TEXT:
344 begin
345 SetString(rs,PAnsiChar(FBufPtr),GetDataLength);
346 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 procedure TFBArrayElement.SetAsString(Value: AnsiString);
388 var len: integer;
389 ElementSize: integer;
390 Int64Value: Int64;
391 begin
392 CheckActive;
393 case GetSQLType of
394 SQL_BOOLEAN:
395 if AnsiCompareText(Value,STrue) = 0 then
396 AsBoolean := true
397 else
398 if AnsiCompareText(Value,SFalse) = 0 then
399 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 (FBufPtr+len)^ := 0;
414 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 if TryStrToInt64(Value,Int64Value) then
435 SetAsInt64(Int64Value)
436 else
437 SetAsCurrency(StrToCurr(Value));
438
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 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 procedure TFBArrayElement.SetSQLType(aValue: cardinal);
537 begin
538 if aValue <> GetSQLType then
539 IBError(ibxeInvalidDataConversion, [nil]);
540 end;
541
542 {TFBArrayMetaData}
543
544 constructor TFBArrayMetaData.Create(aAttachment: IAttachment;
545 aTransaction: ITransaction; relationName, columnName: AnsiString);
546 begin
547 inherited Create;
548 FAttachment := aAttachment;
549 LoadMetaData(aAttachment,aTransaction,relationName, columnName);
550 end;
551
552 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 var i: integer;
557 begin
558 inherited Create;
559 FAttachment := aAttachment;
560 with FArrayDesc do
561 begin
562 array_desc_dtype := GetDType(SQLType);
563 array_desc_scale := Scale;
564 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 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 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 end;
620 end;
621
622 function TFBArrayMetaData.GetSQLTypeName: AnsiString;
623 begin
624 Result := TSQLDataItem.GetSQLTypeName(GetSQLType);
625 end;
626
627 function TFBArrayMetaData.GetScale: integer;
628 begin
629 Result := FArrayDesc.array_desc_scale;
630 end;
631
632 function TFBArrayMetaData.GetSize: cardinal;
633 begin
634 Result := FArrayDesc.array_desc_length;
635 end;
636
637 function TFBArrayMetaData.GetTableName: AnsiString;
638 begin
639 with FArrayDesc do
640 SetString(Result,PAnsiChar(@array_desc_relation_name),sizeof(array_desc_relation_name));
641 Result := trim(Result);
642 end;
643
644 function TFBArrayMetaData.GetColumnName: AnsiString;
645 begin
646 with FArrayDesc do
647 SetString(Result,PAnsiChar(@FArrayDesc.array_desc_field_name),sizeof(array_desc_field_name));
648 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 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 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 end;
707 end;
708
709 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 Result := Result * (Bounds[i].UpperBound - Bounds[i].LowerBound + 1);
717 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 FElementSize := FElementSize + 2;
740 SQL_TEXT:
741 FElementSize := FElementSize + 1;
742 end;
743 FBufSize := FElementSize * l;
744
745 with FFirebirdClientAPI do
746 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 function TFBArray.GetOffset(index: array of integer): PByte;
800 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 FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
815 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 FFirebirdClientAPI := aTransaction.FirebirdAPI;
835 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 FFirebirdClientAPI := aTransaction.FirebirdAPI;
854 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 if ((aTransaction as TObject) = (FTransactionIntf as TObject)) and FModified and not FIsNew then
916 PutArraySlice(Force);
917 end;
918
919 function TFBArray.GetSQLType: cardinal;
920 begin
921 Result := FMetaData.GetSQLType;
922 end;
923
924 function TFBArray.GetSQLTypeName: AnsiString;
925 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 function TFBArray.GetCharSetWidth: integer;
945 begin
946 Result := FMetaData.GetCharSetWidth;
947 end;
948
949 function TFBArray.GetTableName: AnsiString;
950 begin
951 Result := FMetaData.GetTableName;
952 end;
953
954 function TFBArray.GetColumnName: AnsiString;
955 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 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 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 function TFBArray.GetAsString(index: array of integer): AnsiString;
1073 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 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 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 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 procedure TFBArray.SetAsDateTime(index: array of integer; Value: TDateTime);
1150 begin
1151 FElement.FBufPtr := GetOffset(index);
1152 FElement.SetAsDateTime(Value);
1153 end;
1154
1155 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 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 procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1195 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 procedure TFBArray.SetAsBcd(index: array of integer; aValue: tBCD);
1207 begin
1208 FElement.FBufPtr := GetOffset(index);
1209 FElement.SetAsBcd(aValue);
1210 end;
1211
1212 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 if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1254 (TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1255 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