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