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