ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBArray.pas
Revision: 379
Committed: Mon Jan 10 10:08:03 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 35431 byte(s)
Log Message:
set line ending property

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: IFBNumeric); 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, FBNumeric;
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)^ := NumericFromRawValues(Value,getScale).getRawValue;
371 SQL_SHORT:
372 PShort(SQLData)^ := NumericFromRawValues(Value,getScale).getRawValue;
373 SQL_INT64:
374 PInt64(SQLData)^ := NumericFromRawValues(Value,getScale).getRawValue;
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(NumericFromRawValues(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)^ := SafeSmallInt(NewNumeric(Value,Scale).getRawValue)
478 else
479 IBError(ibxeInvalidDataConversion, [nil]);
480 SQL_LONG:
481 if Scale < 0 then
482 PLong(SQLData)^ := SafeInteger(NewNumeric(Value,Scale).getRawValue)
483 else
484 IBError(ibxeInvalidDataConversion, [nil]);
485 SQL_INT64:
486 if Scale < 0 then
487 PInt64(SQLData)^ := NewNumeric(Value,Scale).getRawValue
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)^ := NewNumeric(Value).clone(Scale).getRawValue;
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: IFBNumeric);
542 begin
543 CheckActive;
544 case GetSQLType of
545 SQL_LONG:
546 PLong(SQLData)^ := SafeInteger(Value.clone(Scale).getRawValue);
547 SQL_SHORT:
548 PShort(SQLData)^ := SafeSmallInt(Value.clone(Scale).getRawValue);
549 SQL_INT64:
550 PInt64(SQLData)^ := Value.clone(Scale).getRawValue;
551 SQL_TEXT, SQL_VARYING:
552 SetAsString(Value.getAsString);
553 SQL_D_FLOAT,
554 SQL_DOUBLE:
555 PDouble(SQLData)^ := Value.getAsDouble;
556 SQL_FLOAT:
557 PSingle(SQLData)^ := Value.getAsDouble;
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 FLoaded := true;
826 end;
827
828 function TFBArray.GetOffset(index: array of integer): PByte;
829 var i: integer;
830 Bounds: TArrayBounds;
831 FlatIndex: integer;
832 begin
833 if FMetaData.GetDimensions <> Length(index) then
834 IBError(ibxeInvalidArrayDimensions,[Length(index)]);
835
836 FlatIndex := 0;
837 Bounds := FMetaData.GetBounds;
838 for i := 0 to Length(index) - 1 do
839 begin
840 if (index[i] < Bounds[i].LowerBound) or (index[i] > Bounds[i].UpperBound) then
841 IBError(ibxeInvalidSubscript,[index[i],i]);
842
843 FlatIndex := FlatIndex + FOffsets[i]*(index[i] - Bounds[i].LowerBound);
844 end;
845 Result := FBuffer + FlatIndex*FElementSize;
846 end;
847
848 function TFBArray.GetDataLength: short;
849 begin
850 Result := FElementSize;
851 end;
852
853 function TFBArray.GetArrayDesc: PISC_ARRAY_DESC;
854 begin
855 Result := @((FMetaData as TFBArrayMetaData).FArrayDesc);
856 end;
857
858 constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction; aField: IArrayMetaData);
859 begin
860 inherited Create(aTransaction);
861 FMetaData := aField;
862 FAttachment := aAttachment;
863 FFirebirdClientAPI := aTransaction.FirebirdAPI;
864 FTransactionIntf := aTransaction;
865 FTransactionSeqNo := aTransaction.TransactionSeqNo;
866 FIsNew := true;
867 FModified := false;
868 FSQLDialect := aAttachment.GetSQLDialect;
869 AllocateBuffer;
870 FElement := TFBArrayElement.Create(self,FBuffer);
871 FElementIntf := FElement;
872 Setlength(FEventHandlers,0);
873 end;
874
875 constructor TFBArray.Create(aAttachment: IAttachment; aTransaction: TFBTransaction;
876 aField: IArrayMetaData; ArrayID: TISC_QUAD);
877 begin
878 inherited Create(aTransaction);
879 FMetaData := aField;
880 FArrayID := ArrayID;
881 FAttachment := aAttachment;
882 FFirebirdClientAPI := aTransaction.FirebirdAPI;
883 FTransactionIntf := aTransaction;
884 FTransactionSeqNo := aTransaction.TransactionSeqNo;
885 FIsNew := false;
886 FModified := false;
887 FSQLDialect := aAttachment.GetSQLDialect;
888 AllocateBuffer;
889 FElement := TFBArrayElement.Create(self,FBuffer);
890 FElementIntf := FElement;
891 Setlength(FEventHandlers,0);
892 end;
893
894 destructor TFBArray.Destroy;
895 begin
896 FreeMem(FBuffer);
897 inherited Destroy;
898 end;
899
900 function TFBArray.GetArrayID: TISC_QUAD;
901 begin
902 PutArraySlice;
903 Result := FArrayID;
904 end;
905
906 procedure TFBArray.Clear;
907 begin
908 FIsNew := true;
909 FModified := false;
910 FArrayID.gds_quad_high := 0;
911 FArrayID.gds_quad_low := 0;
912 AllocateBuffer;
913 end;
914
915 function TFBArray.IsEmpty: boolean;
916 begin
917 Result := FIsNew and not FModified;
918 end;
919
920 procedure TFBArray.PreLoad;
921 begin
922 GetArraySlice;
923 end;
924
925 procedure TFBArray.CancelChanges;
926 begin
927 FModified := false;
928 AllocateBuffer;
929 end;
930
931 procedure TFBArray.SaveChanges;
932 begin
933 PutArraySlice;
934 end;
935
936 function TFBArray.GetSQLDialect: integer;
937 begin
938 Result := FSQLDialect;
939 end;
940
941 procedure TFBArray.TransactionEnding(aTransaction: ITransaction; Force: boolean
942 );
943 begin
944 if ((aTransaction as TObject) = (FTransactionIntf as TObject)) and FModified and not FIsNew then
945 PutArraySlice(Force);
946 end;
947
948 function TFBArray.GetSQLType: cardinal;
949 begin
950 Result := FMetaData.GetSQLType;
951 end;
952
953 function TFBArray.GetSQLTypeName: AnsiString;
954 begin
955 Result := FMetaData.GetSQLTypeName;
956 end;
957
958 function TFBArray.GetScale: integer;
959 begin
960 Result := FMetaData.GetScale;
961 end;
962
963 function TFBArray.GetSize: cardinal;
964 begin
965 Result := FMetaData.GetSize;
966 end;
967
968 function TFBArray.GetCharSetID: cardinal;
969 begin
970 Result := FMetaData.GetCharSetID;
971 end;
972
973 function TFBArray.GetCharSetWidth: integer;
974 begin
975 Result := FMetaData.GetCharSetWidth;
976 end;
977
978 function TFBArray.GetTableName: AnsiString;
979 begin
980 Result := FMetaData.GetTableName;
981 end;
982
983 function TFBArray.GetColumnName: AnsiString;
984 begin
985 Result := FMetaData.GetColumnName;
986 end;
987
988 function TFBArray.GetDimensions: integer;
989 begin
990 Result := FMetaData.GetDimensions;
991 end;
992
993 function TFBArray.GetBounds: TArrayBounds;
994 begin
995 Result := FMetaData.GetBounds;
996 end;
997
998 function TFBArray.GetAsInteger(index: array of integer): integer;
999 begin
1000 GetArraySlice;
1001 FElement.FBufPtr := GetOffset(index);
1002 Result := FElement.GetAsLong;
1003 end;
1004
1005 function TFBArray.GetAsBoolean(index: array of integer): boolean;
1006 begin
1007 GetArraySlice;
1008 FElement.FBufPtr := GetOffset(index);
1009 Result := FElement.GetAsBoolean;
1010 end;
1011
1012 function TFBArray.GetAsCurrency(index: array of integer): Currency;
1013 begin
1014 GetArraySlice;
1015 FElement.FBufPtr := GetOffset(index);
1016 Result := FElement.GetAsCurrency;
1017 end;
1018
1019 function TFBArray.GetAsInt64(index: array of integer): Int64;
1020 begin
1021 GetArraySlice;
1022 FElement.FBufPtr := GetOffset(index);
1023 Result := FElement.GetAsInt64;
1024 end;
1025
1026 function TFBArray.GetAsDateTime(index: array of integer): TDateTime;
1027 begin
1028 GetArraySlice;
1029 FElement.FBufPtr := GetOffset(index);
1030 Result := FElement.GetAsDateTime;
1031 end;
1032
1033 procedure TFBArray.GetAsDateTime(index: array of integer;
1034 var aDateTime: TDateTime; var dstOffset: smallint;
1035 var aTimezoneID: TFBTimeZoneID);
1036 begin
1037 GetArraySlice;
1038 FElement.FBufPtr := GetOffset(index);
1039 FElement.GetAsDateTime(aDateTime,dstOffset,aTimezoneID);
1040 end;
1041
1042 procedure TFBArray.GetAsDateTime(index: array of integer;
1043 var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString);
1044 begin
1045 GetArraySlice;
1046 FElement.FBufPtr := GetOffset(index);
1047 FElement.GetAsDateTime(aDateTime,dstOffset,aTimezone);
1048 end;
1049
1050 procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1051 var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime);
1052 begin
1053 GetArraySlice;
1054 FElement.FBufPtr := GetOffset(index);
1055 FElement.GetAsTime(aTime,dstOffset,aTimezoneID,OnDate);
1056 end;
1057
1058 procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1059 var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime);
1060 begin
1061 GetArraySlice;
1062 FElement.FBufPtr := GetOffset(index);
1063 FElement.GetAsTime(aTime,dstOffset,aTimezone,OnDate);
1064 end;
1065
1066 function TFBArray.GetAsUTCDateTime(index: array of integer): TDateTime;
1067 begin
1068 GetArraySlice;
1069 FElement.FBufPtr := GetOffset(index);
1070 Result := FElement.GetAsUTCDateTime;
1071 end;
1072
1073 function TFBArray.GetAsDouble(index: array of integer): Double;
1074 begin
1075 GetArraySlice;
1076 FElement.FBufPtr := GetOffset(index);
1077 Result := FElement.GetAsDouble;
1078 end;
1079
1080 function TFBArray.GetAsFloat(index: array of integer): Float;
1081 begin
1082 GetArraySlice;
1083 FElement.FBufPtr := GetOffset(index);
1084 Result := FElement.GetAsFloat;
1085 end;
1086
1087 function TFBArray.GetAsLong(index: array of integer): Long;
1088 begin
1089 GetArraySlice;
1090 FElement.FBufPtr := GetOffset(index);
1091 Result := FElement.GetAsLong;
1092 end;
1093
1094 function TFBArray.GetAsShort(index: array of integer): Short;
1095 begin
1096 GetArraySlice;
1097 FElement.FBufPtr := GetOffset(index);
1098 Result := FElement.GetAsShort;
1099 end;
1100
1101 function TFBArray.GetAsString(index: array of integer): AnsiString;
1102 begin
1103 GetArraySlice;
1104 FElement.FBufPtr := GetOffset(index);
1105 Result := FElement.GetAsString;
1106 end;
1107
1108 function TFBArray.GetAsVariant(index: array of integer): Variant;
1109 begin
1110 GetArraySlice;
1111 FElement.FBufPtr := GetOffset(index);
1112 Result := FElement.GetAsVariant;
1113 end;
1114
1115 function TFBArray.GetAsBCD(index: array of integer): tBCD;
1116 begin
1117 GetArraySlice;
1118 FElement.FBufPtr := GetOffset(index);
1119 Result := FElement.GetAsBCD;
1120 end;
1121
1122 procedure TFBArray.SetAsInteger(index: array of integer; AValue: integer);
1123 begin
1124 FElement.FBufPtr := GetOffset(index);
1125 FElement.SetAsLong(AValue);
1126 end;
1127
1128 procedure TFBArray.SetAsBoolean(index: array of integer; AValue: boolean);
1129 begin
1130 FElement.FBufPtr := GetOffset(index);
1131 FElement.SetAsBoolean(AValue);
1132 end;
1133
1134 procedure TFBArray.SetAsCurrency(index: array of integer; Value: Currency);
1135 begin
1136 FElement.FBufPtr := GetOffset(index);
1137 FElement.SetAsCurrency(Value);
1138 end;
1139
1140 procedure TFBArray.SetAsInt64(index: array of integer; Value: Int64);
1141 begin
1142 FElement.FBufPtr := GetOffset(index);
1143 FElement.SetAsInt64(Value);
1144 end;
1145
1146 procedure TFBArray.SetAsDate(index: array of integer; Value: TDateTime);
1147 begin
1148 FElement.FBufPtr := GetOffset(index);
1149 FElement.SetAsDate(Value);
1150 end;
1151
1152 procedure TFBArray.SetAsLong(index: array of integer; Value: Long);
1153 begin
1154 FElement.FBufPtr := GetOffset(index);
1155 FElement.SetAsLong(Value);
1156 end;
1157
1158 procedure TFBArray.SetAsTime(index: array of integer; Value: TDateTime);
1159 begin
1160 FElement.FBufPtr := GetOffset(index);
1161 FElement.SetAsTime(Value);
1162 end;
1163
1164 procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1165 aTimeZoneID: TFBTimeZoneID);
1166 begin
1167 FElement.FBufPtr := GetOffset(index);
1168 FElement.SetAsTime(aValue,OnDate,aTimeZoneID);
1169 end;
1170
1171 procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1172 aTimeZone: AnsiString);
1173 begin
1174 FElement.FBufPtr := GetOffset(index);
1175 FElement.SetAsTime(aValue,OnDate, aTimeZone);
1176 end;
1177
1178 procedure TFBArray.SetAsDateTime(index: array of integer; Value: TDateTime);
1179 begin
1180 FElement.FBufPtr := GetOffset(index);
1181 FElement.SetAsDateTime(Value);
1182 end;
1183
1184 procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1185 aTimeZoneID: TFBTimeZoneID);
1186 begin
1187 FElement.FBufPtr := GetOffset(index);
1188 FElement.SetAsDateTime(aValue,aTimeZoneID);
1189 end;
1190
1191 procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1192 aTimeZone: AnsiString);
1193 begin
1194 FElement.FBufPtr := GetOffset(index);
1195 FElement.SetAsDateTime(aValue,aTimeZone);
1196 end;
1197
1198 procedure TFBArray.SetAsUTCDateTime(index: array of integer;
1199 aUTCTime: TDateTime);
1200 begin
1201 FElement.FBufPtr := GetOffset(index);
1202 FElement.SetAsUTCDateTime(aUTCTime);
1203 end;
1204
1205 procedure TFBArray.SetAsDouble(index: array of integer; Value: Double);
1206 begin
1207 FElement.FBufPtr := GetOffset(index);
1208 FElement.SetAsDouble(Value);
1209 end;
1210
1211 procedure TFBArray.SetAsFloat(index: array of integer; Value: Float);
1212 begin
1213 FElement.FBufPtr := GetOffset(index);
1214 FElement.SetAsFloat(Value);
1215 end;
1216
1217 procedure TFBArray.SetAsShort(index: array of integer; Value: Short);
1218 begin
1219 FElement.FBufPtr := GetOffset(index);
1220 FElement.SetAsShort(Value);
1221 end;
1222
1223 procedure TFBArray.SetAsString(index: array of integer; Value: AnsiString);
1224 begin
1225 FElement.FBufPtr := GetOffset(index);
1226 FElement.SetAsString(Value);
1227 end;
1228
1229 procedure TFBArray.SetAsVariant(index: array of integer; Value: Variant);
1230 begin
1231 FElement.FBufPtr := GetOffset(index);
1232 FElement.SetAsVariant(Value);
1233 end;
1234
1235 procedure TFBArray.SetAsBcd(index: array of integer; aValue: tBCD);
1236 begin
1237 FElement.FBufPtr := GetOffset(index);
1238 FElement.SetAsBcd(aValue);
1239 end;
1240
1241 procedure TFBArray.SetBounds(dim, UpperBound, LowerBound: integer);
1242 begin
1243 with (FMetaData as TFBArrayMetaData) do
1244 begin
1245 if (dim < 0) or (dim > GetDimensions) then
1246 IBError(ibxeInvalidArrayDimensions,[dim]);
1247
1248 if (UpperBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) or
1249 (LowerBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1250 (UpperBound < FArrayDesc.array_desc_bounds[dim].array_bound_lower) or
1251 (LowerBound > FArrayDesc.array_desc_bounds[dim].array_bound_upper) then
1252 IBError(ibxArrayBoundsCantIncrease,[nil]);
1253
1254 PutArraySlice; {Save any changes}
1255
1256 FArrayDesc.array_desc_bounds[dim].array_bound_upper := UpperBound;
1257 FArrayDesc.array_desc_bounds[dim].array_bound_lower := LowerBound;
1258 end;
1259 AllocateBuffer;
1260 end;
1261
1262 function TFBArray.GetAttachment: IAttachment;
1263 begin
1264 Result := FAttachment;
1265 end;
1266
1267 function TFBArray.GetTransaction: ITransaction;
1268 begin
1269 Result := FTransactionIntf;
1270 end;
1271
1272 procedure TFBArray.AddEventHandler(Handler: TArrayEventHandler);
1273 begin
1274 SetLength(FEventHandlers,Length(FEventHandlers)+1);
1275 FEventHandlers[Length(FEventHandlers)-1] := Handler;
1276 end;
1277
1278 procedure TFBArray.RemoveEventHandler(Handler: TArrayEventHandler);
1279 var i,j : integer;
1280 begin
1281 for i := Length(FEventHandlers) - 1 downto 0 do
1282 if (TMethod(FEventHandlers[i]).Code = TMethod(Handler).Code) and
1283 (TMethod(FEventHandlers[i]).Data = TMethod(Handler).Data) then
1284 begin
1285 for j := i to Length(FEventHandlers) - 2 do
1286 FEventHandlers[i] := FEventHandlers[i+1];
1287 SetLength(FEventHandlers,Length(FEventHandlers) - 1);
1288 end;
1289 end;
1290
1291 end.
1292

Properties

Name Value
svn:eol-style native