ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBArray.pas
(Generate patch)

Comparing ibx/trunk/fbintf/client/FBArray.pas (file contents):
Revision 291 by tony, Fri Apr 17 10:26:08 2020 UTC vs.
Revision 353 by tony, Sat Oct 23 14:11:37 2021 UTC

# Line 38 | Line 38 | unit FBArray;
38   interface
39  
40   uses
41 <  Classes, SysUtils, IB, IBHeader, FBTransaction,
42 <  FBSQLData,  FBClientAPI, IBExternals, FBActivityMonitor;
41 >  Classes, SysUtils, IBHeader, IB,  FBTransaction,
42 >  FBSQLData,  FBClientAPI, IBExternals, FBActivityMonitor, FmtBCD;
43  
44   (*
45  
# Line 75 | Line 75 | type
75     FBufPtr: PByte;
76     FArray: TFBArray;
77    protected
78 +   function GetAttachment: IAttachment; override;
79     function GetSQLDialect: integer; override;
80     procedure Changing; override;
81     procedure Changed; override;
# Line 90 | Line 91 | type
91     function GetName: AnsiString; override;
92     function GetScale: integer; override;
93     function GetSize: integer;
94 +   function GetCharSetWidth: integer; override;
95     function GetAsString: AnsiString; override;
96     procedure SetAsLong(Value: Long); override;
97     procedure SetAsShort(Value: Short); override;
# Line 98 | Line 100 | type
100     procedure SetAsDouble(Value: Double); override;
101     procedure SetAsFloat(Value: Float); override;
102     procedure SetAsCurrency(Value: Currency); override;
103 +   procedure SetAsBcd(aValue: tBCD); override;
104 +   procedure SetAsNumeric(Value: Int64; aScale: integer); override;
105    end;
106  
107    { TFBArrayMetaData }
# Line 127 | Line 131 | type
131     function GetScale: integer;
132     function GetSize: cardinal;
133     function GetCharSetID: cardinal; virtual; abstract;
134 +   function GetCharSetWidth: integer; virtual; abstract;
135     function GetTableName: AnsiString;
136     function GetColumnName: AnsiString;
137     function GetDimensions: integer;
# Line 136 | Line 141 | type
141  
142    { TFBArray }
143  
144 <  TFBArray = class(TActivityReporter,IArray)
144 >  TFBArray = class(TActivityReporter,IArray,ITransactionUser)
145    private
146      FFirebirdClientAPI: TFBClientAPI;
147      FMetaData: IArrayMetaData;
# Line 173 | Line 178 | type
178        aField: IArrayMetaData; ArrayID: TISC_QUAD); overload;
179      destructor Destroy; override;
180      function GetSQLDialect: integer;
181 +
182 +  public
183 +    {ITransactionUser}
184      procedure TransactionEnding(aTransaction: ITransaction; Force: boolean);
185  
186     public
# Line 182 | Line 190 | type
190      function GetScale: integer;
191      function GetSize: cardinal;
192      function GetCharSetID: cardinal;
193 +    function GetCharSetWidth: integer;
194      function GetTableName: AnsiString;
195      function GetColumnName: AnsiString;
196      function GetDimensions: integer;
# Line 197 | Line 206 | type
206      function GetAsBoolean(index: array of integer): boolean;
207      function GetAsCurrency(index: array of integer): Currency;
208      function GetAsInt64(index: array of integer): Int64;
209 <    function GetAsDateTime(index: array of integer): TDateTime;
209 >    function GetAsDateTime(index: array of integer): TDateTime; overload;
210 >    procedure GetAsDateTime(index: array of integer; var aDateTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID); overload;
211 >    procedure GetAsDateTime(index: array of integer; var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString); overload;
212 >    procedure GetAsTime(index: array of integer; var aTime: TDateTime; var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime); overload;
213 >    procedure GetAsTime(index: array of integer; var aTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime); overload;
214 >    function GetAsUTCDateTime(index: array of integer): TDateTime;
215      function GetAsDouble(index: array of integer): Double;
216      function GetAsFloat(index: array of integer): Float;
217      function GetAsLong(index: array of integer): Long;
218      function GetAsShort(index: array of integer): Short;
219      function GetAsString(index: array of integer): AnsiString;
220      function GetAsVariant(index: array of integer): Variant;
221 +    function GetAsBCD(index: array of integer): tBCD;
222      procedure SetAsInteger(index: array of integer; AValue: integer);
223      procedure SetAsBoolean(index: array of integer; AValue: boolean);
224      procedure SetAsCurrency(index: array of integer; Value: Currency);
225      procedure SetAsInt64(index: array of integer; Value: Int64);
226      procedure SetAsDate(index: array of integer; Value: TDateTime);
227      procedure SetAsLong(index: array of integer; Value: Long);
228 <    procedure SetAsTime(index: array of integer; Value: TDateTime);
229 <    procedure SetAsDateTime(index: array of integer; Value: TDateTime);
228 >    procedure SetAsTime(index: array of integer; Value: TDateTime); overload;
229 >    procedure SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
230 >    procedure SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime; aTimeZone: AnsiString); overload;
231 >    procedure SetAsDateTime(index: array of integer; Value: TDateTime); overload;
232 >    procedure SetAsDateTime(index: array of integer; aValue: TDateTime; aTimeZoneID: TFBTimeZoneID); overload;
233 >    procedure SetAsDateTime(index: array of integer; aValue: TDateTime; aTimeZone: AnsiString); overload;
234 >    procedure SetAsUTCDateTime(index: array of integer; aUTCTime: TDateTime);
235      procedure SetAsDouble(index: array of integer; Value: Double);
236      procedure SetAsFloat(index: array of integer; Value: Float);
237      procedure SetAsShort(index: array of integer; Value: Short);
238      procedure SetAsString(index: array of integer; Value: AnsiString);
239      procedure SetAsVariant(index: array of integer; Value: Variant);
240 +    procedure SetAsBcd(index: array of integer; aValue: tBCD);
241      procedure SetBounds(dim, UpperBound, LowerBound: integer);
242      function GetAttachment: IAttachment;
243      function GetTransaction: ITransaction;
# Line 226 | Line 247 | type
247  
248   implementation
249  
250 < uses FBMessages;
250 > uses FBMessages, IBUtils;
251  
252   { TFBArrayElement }
253  
254 + function TFBArrayElement.GetAttachment: IAttachment;
255 + begin
256 +  Result := FArray.GetAttachment;
257 + end;
258 +
259   function TFBArrayElement.GetSQLDialect: integer;
260   begin
261    Result := FArray.GetSQLDialect;
# Line 300 | Line 326 | begin
326    Result := GetDataLength;
327   end;
328  
329 + function TFBArrayElement.GetCharSetWidth: integer;
330 + begin
331 +  Result := FArray.FMetaData.GetCharSetWidth;
332 + end;
333 +
334   function TFBArrayElement.GetAsString: AnsiString;
335   var rs: RawByteString;
336   begin
# Line 336 | Line 367 | begin
367    CheckActive;
368    case GetSQLType of
369    SQL_LONG:
370 <    PLong(SQLData)^ := Value;
370 >    PLong(SQLData)^ := AdjustScaleToInt64(Value,getScale);
371    SQL_SHORT:
372 <    PShort(SQLData)^ := Value;
372 >    PShort(SQLData)^ := AdjustScaleToInt64(Value,getScale);
373    SQL_INT64:
374 <    PInt64(SQLData)^ := Value;
374 >    PInt64(SQLData)^ := AdjustScaleToInt64(Value,getScale);
375    SQL_TEXT, SQL_VARYING:
376      SetAsString(IntToStr(Value));
377    SQL_D_FLOAT,
# Line 357 | Line 388 | end;
388   procedure TFBArrayElement.SetAsString(Value: AnsiString);
389   var len: integer;
390      ElementSize: integer;
391 +    Int64Value: Int64;
392 +    aScale: integer;
393   begin
394    CheckActive;
395    case GetSQLType of
# Line 397 | Line 430 | begin
430    SQL_SHORT,
431    SQL_LONG,
432    SQL_INT64:
433 <    if trim(Value) = '' then
434 <      SetAsInt64(0)
433 >    if TryStrToNumeric(Value,Int64Value,aScale) then
434 >      SetAsNumeric(Int64Value,AScale)
435      else
436 <      SetAsInt64(AdjustScaleFromCurrency(StrToCurr(Value),GetScale));
436 >      SetAsCurrency(StrToCurr(Value));
437  
438    SQL_D_FLOAT,
439    SQL_DOUBLE,
440    SQL_FLOAT:
441 <  if trim(Value) = '' then
442 <    SetAsDouble(0)
443 <  else
444 <    SetAsDouble(StrToFloat(Value));
441 >    if TryStrToNumeric(Value,Int64Value,aScale) then
442 >      SetAsDouble(NumericToDouble(Int64Value,aScale))
443 >    else
444 >      IBError(ibxeInvalidDataConversion,[nil]);
445 >
446 >  SQL_DEC_FIXED,
447 >  SQL_DEC16,
448 >  SQL_DEC34,
449 >  SQL_INT128:
450 >    SetAsBCD(StrToBCD(Value));
451  
452    SQL_TIMESTAMP:
453      SetAsDateTime(StrToDateTime(Value));
# Line 476 | Line 515 | begin
515    end
516   end;
517  
518 + procedure TFBArrayElement.SetAsBcd(aValue: tBCD);
519 + var C: Currency;
520 + begin
521 +  CheckActive;
522 +  with FirebirdClientAPI do
523 +  case SQLType of
524 +  SQL_DEC_FIXED,
525 +  SQL_DEC16,
526 +  SQL_DEC34:
527 +    SQLDecFloatEncode(aValue,SQLType,SQLData);
528 +
529 +  SQL_INT128:
530 +    StrToInt128(Scale,BcdToStr(aValue),SQLData);
531 +
532 +  else
533 +    begin
534 +      BCDToCurr(aValue,C);
535 +      SetAsCurrency(C);
536 +    end;
537 +  end;
538 +  Changed;
539 + end;
540 +
541 + procedure TFBArrayElement.SetAsNumeric(Value: Int64; aScale: integer);
542 + begin
543 +  CheckActive;
544 +  case GetSQLType of
545 +  SQL_LONG:
546 +    PLong(SQLData)^ := AdjustScaleToInt64(Value,aScale - getScale);
547 +  SQL_SHORT:
548 +    PShort(SQLData)^ := AdjustScaleToInt64(Value,aScale - getScale);
549 +  SQL_INT64:
550 +    PInt64(SQLData)^ := AdjustScaleToInt64(Value,aScale - getScale);
551 +  SQL_TEXT, SQL_VARYING:
552 +   SetAsString(AdjustScaleToStr(Value,aScale));
553 +  SQL_D_FLOAT,
554 +  SQL_DOUBLE:
555 +    PDouble(SQLData)^ := AdjustScale(Value,aScale);
556 +  SQL_FLOAT:
557 +    PSingle(SQLData)^ := AdjustScale(Value,aScale);
558 +  else
559 +    IBError(ibxeInvalidDataConversion, [nil]);
560 +  end;
561 +  Changed;
562 + end;
563 +
564   procedure TFBArrayElement.SetSQLType(aValue: cardinal);
565   begin
566 <  if aValue = GetSQLType then
566 >  if aValue <> GetSQLType then
567      IBError(ibxeInvalidDataConversion, [nil]);
568   end;
569  
# Line 545 | Line 630 | begin
630      Result :=  SQL_TYPE_TIME;
631    blr_int64:
632      Result := SQL_INT64;
633 +  blr_sql_time_tz:
634 +    Result := SQL_TIME_TZ;
635 +  blr_timestamp_tz:
636 +    Result := SQL_TIMESTAMP_TZ;
637 +  blr_ex_time_tz:
638 +    Result := SQL_TIME_TZ_EX;
639 +  blr_ex_timestamp_tz:
640 +    Result := SQL_TIMESTAMP_TZ_EX;
641 +  blr_dec64:
642 +    Result := SQL_DEC16;
643 +  blr_dec128:
644 +    Result := SQL_DEC34;
645 +  blr_int128:
646 +    Result := SQL_INT128;
647    end;
648   end;
649  
# Line 555 | Line 654 | end;
654  
655   function TFBArrayMetaData.GetScale: integer;
656   begin
657 <  Result := byte(FArrayDesc.array_desc_scale);
657 >  Result := FArrayDesc.array_desc_scale;
658   end;
659  
660   function TFBArrayMetaData.GetSize: cardinal;
# Line 618 | Line 717 | begin
717      Result :=  blr_sql_time;
718    SQL_INT64:
719      Result := blr_int64;
720 +  SQL_TIME_TZ:
721 +    Result := blr_sql_time_tz;
722 +  SQL_TIMESTAMP_TZ:
723 +    Result := blr_timestamp_tz;
724 +  SQL_TIME_TZ_EX:
725 +    Result := blr_ex_time_tz;
726 +  SQL_TIMESTAMP_TZ_EX:
727 +    Result := blr_ex_timestamp_tz;
728 +  SQL_DEC16:
729 +    Result := blr_dec64;
730 +  SQL_DEC34:
731 +    Result := blr_dec128;
732 +  SQL_INT128:
733 +    Result := blr_int128;
734    end;
735   end;
736  
# Line 827 | Line 940 | end;
940   procedure TFBArray.TransactionEnding(aTransaction: ITransaction; Force: boolean
941    );
942   begin
943 <  if (aTransaction = FTransactionIntf) and FModified and not FIsNew then
943 >  if ((aTransaction as TObject) = (FTransactionIntf as TObject)) and FModified and not FIsNew then
944      PutArraySlice(Force);
945   end;
946  
# Line 856 | Line 969 | begin
969    Result := FMetaData.GetCharSetID;
970   end;
971  
972 + function TFBArray.GetCharSetWidth: integer;
973 + begin
974 +  Result := FMetaData.GetCharSetWidth;
975 + end;
976 +
977   function TFBArray.GetTableName: AnsiString;
978   begin
979    Result := FMetaData.GetTableName;
# Line 911 | Line 1029 | begin
1029    Result := FElement.GetAsDateTime;
1030   end;
1031  
1032 + procedure TFBArray.GetAsDateTime(index: array of integer;
1033 +  var aDateTime: TDateTime; var dstOffset: smallint;
1034 +  var aTimezoneID: TFBTimeZoneID);
1035 + begin
1036 +  GetArraySlice;
1037 +  FElement.FBufPtr := GetOffset(index);
1038 +  FElement.GetAsDateTime(aDateTime,dstOffset,aTimezoneID);
1039 + end;
1040 +
1041 + procedure TFBArray.GetAsDateTime(index: array of integer;
1042 +  var aDateTime: TDateTime; var dstOffset: smallint; var aTimezone: AnsiString);
1043 + begin
1044 +  GetArraySlice;
1045 +  FElement.FBufPtr := GetOffset(index);
1046 +  FElement.GetAsDateTime(aDateTime,dstOffset,aTimezone);
1047 + end;
1048 +
1049 + procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1050 +  var dstOffset: smallint; var aTimezoneID: TFBTimeZoneID; OnDate: TDateTime);
1051 + begin
1052 +  GetArraySlice;
1053 +  FElement.FBufPtr := GetOffset(index);
1054 +  FElement.GetAsTime(aTime,dstOffset,aTimezoneID,OnDate);
1055 + end;
1056 +
1057 + procedure TFBArray.GetAsTime(index: array of integer; var aTime: TDateTime;
1058 +  var dstOffset: smallint; var aTimezone: AnsiString; OnDate: TDateTime);
1059 + begin
1060 +  GetArraySlice;
1061 +  FElement.FBufPtr := GetOffset(index);
1062 +  FElement.GetAsTime(aTime,dstOffset,aTimezone,OnDate);
1063 + end;
1064 +
1065 + function TFBArray.GetAsUTCDateTime(index: array of integer): TDateTime;
1066 + begin
1067 +  GetArraySlice;
1068 +  FElement.FBufPtr := GetOffset(index);
1069 +  Result := FElement.GetAsUTCDateTime;
1070 + end;
1071 +
1072   function TFBArray.GetAsDouble(index: array of integer): Double;
1073   begin
1074    GetArraySlice;
# Line 953 | Line 1111 | begin
1111    Result := FElement.GetAsVariant;
1112   end;
1113  
1114 + function TFBArray.GetAsBCD(index: array of integer): tBCD;
1115 + begin
1116 +  GetArraySlice;
1117 +  FElement.FBufPtr := GetOffset(index);
1118 +  Result := FElement.GetAsBCD;
1119 + end;
1120 +
1121   procedure TFBArray.SetAsInteger(index: array of integer; AValue: integer);
1122   begin
1123    FElement.FBufPtr := GetOffset(index);
# Line 995 | Line 1160 | begin
1160    FElement.SetAsTime(Value);
1161   end;
1162  
1163 + procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1164 +  aTimeZoneID: TFBTimeZoneID);
1165 + begin
1166 +  FElement.FBufPtr := GetOffset(index);
1167 +  FElement.SetAsTime(aValue,OnDate,aTimeZoneID);
1168 + end;
1169 +
1170 + procedure TFBArray.SetAsTime(index: array of integer; aValue: TDateTime; OnDate: TDateTime;
1171 +  aTimeZone: AnsiString);
1172 + begin
1173 +  FElement.FBufPtr := GetOffset(index);
1174 +  FElement.SetAsTime(aValue,OnDate, aTimeZone);
1175 + end;
1176 +
1177   procedure TFBArray.SetAsDateTime(index: array of integer; Value: TDateTime);
1178   begin
1179    FElement.FBufPtr := GetOffset(index);
1180    FElement.SetAsDateTime(Value);
1181   end;
1182  
1183 + procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1184 +  aTimeZoneID: TFBTimeZoneID);
1185 + begin
1186 +  FElement.FBufPtr := GetOffset(index);
1187 +  FElement.SetAsDateTime(aValue,aTimeZoneID);
1188 + end;
1189 +
1190 + procedure TFBArray.SetAsDateTime(index: array of integer; aValue: TDateTime;
1191 +  aTimeZone: AnsiString);
1192 + begin
1193 +  FElement.FBufPtr := GetOffset(index);
1194 +  FElement.SetAsDateTime(aValue,aTimeZone);
1195 + end;
1196 +
1197 + procedure TFBArray.SetAsUTCDateTime(index: array of integer;
1198 +  aUTCTime: TDateTime);
1199 + begin
1200 +  FElement.FBufPtr := GetOffset(index);
1201 +  FElement.SetAsUTCDateTime(aUTCTime);
1202 + end;
1203 +
1204   procedure TFBArray.SetAsDouble(index: array of integer; Value: Double);
1205   begin
1206    FElement.FBufPtr := GetOffset(index);
# Line 1031 | Line 1231 | begin
1231    FElement.SetAsVariant(Value);
1232   end;
1233  
1234 + procedure TFBArray.SetAsBcd(index: array of integer; aValue: tBCD);
1235 + begin
1236 +  FElement.FBufPtr := GetOffset(index);
1237 +  FElement.SetAsBcd(aValue);
1238 + end;
1239 +
1240   procedure TFBArray.SetBounds(dim, UpperBound, LowerBound: integer);
1241   begin
1242    with (FMetaData as TFBArrayMetaData) do

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines