ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBArray.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 4 months ago) by tony
Content type: text/x-pascal
File size: 28639 byte(s)
Log Message:
Release 2.3.2 committed

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