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