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

File Contents

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