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

Comparing:
ibx/trunk/fbintf/client/FBSQLData.pas (file contents), Revision 345 by tony, Mon Aug 23 14:22:29 2021 UTC vs.
ibx/branches/udr/client/FBSQLData.pas (file contents), Revision 371 by tony, Wed Jan 5 15:21:22 2022 UTC

# Line 122 | Line 122 | type
122    private
123       FFirebirdClientAPI: TFBClientAPI;
124       FTimeZoneServices: IExTimeZoneServices;
125     function AdjustScale(Value: Int64; aScale: Integer): Double;
126     function AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
127     function AdjustScaleToCurrency(Value: Int64; aScale: Integer): Currency;
125       function GetDateFormatStr(IncludeTime: boolean): AnsiString;
126       function GetTimeFormatStr: AnsiString;
127       function GetTimestampFormatStr: AnsiString;
# Line 132 | Line 129 | type
129       procedure InternalGetAsDateTime(var aDateTime: TDateTime; var dstOffset: smallint;
130         var aTimezone: AnsiString; var aTimeZoneID: TFBTimeZoneID);
131    protected
135     function AdjustScaleFromCurrency(Value: Currency; aScale: Integer): Int64;
136     function AdjustScaleFromDouble(Value: Double; aScale: Integer): Int64;
132       procedure CheckActive; virtual;
133       procedure CheckTZSupport;
134       function GetAttachment: IAttachment; virtual; abstract;
135 +     function GetTransaction: ITransaction; virtual; abstract;
136       function GetSQLDialect: integer; virtual; abstract;
137       function GetTimeZoneServices: IExTimeZoneServices; virtual;
138       procedure Changed; virtual;
# Line 154 | Line 150 | type
150       property FirebirdClientAPI: TFBClientAPI read FFirebirdClientAPI;
151    public
152       constructor Create(api: TFBClientAPI);
153 <     function GetSQLType: cardinal; virtual; abstract;
153 >     function CanChangeMetaData: boolean; virtual;
154 >     function GetSQLType: cardinal; virtual; abstract; {Current Field Data SQL Type}
155       function GetSQLTypeName: AnsiString; overload;
156 <     class function GetSQLTypeName(SQLType: short): AnsiString; overload;
156 >     class function GetSQLTypeName(SQLType: cardinal): AnsiString; overload;
157       function GetStrDataLength: short;
158 +     function getColMetadata: IParamMetaData; virtual; abstract;
159       function GetName: AnsiString; virtual; abstract;
160 <     function GetScale: integer; virtual; abstract;
160 >     function GetScale: integer; virtual; abstract; {Current Field Data scale}
161       function GetAsBoolean: boolean;
162       function GetAsCurrency: Currency;
163       function GetAsInt64: Int64;
# Line 178 | Line 176 | type
176       function GetAsQuad: TISC_QUAD;
177       function GetAsShort: short;
178       function GetAsString: AnsiString; virtual;
179 +     function GetAsNumeric: IFBNumeric;
180       function GetIsNull: Boolean; virtual;
181       function GetIsNullable: boolean; virtual;
182       function GetAsVariant: Variant;
# Line 205 | Line 204 | type
204       procedure SetAsShort(Value: short); virtual;
205       procedure SetAsString(Value: AnsiString); virtual;
206       procedure SetAsVariant(Value: Variant);
207 <     procedure SetAsNumeric(Value: Int64; aScale: integer);
207 >     procedure SetAsNumeric(Value: IFBNumeric); virtual;
208       procedure SetAsBcd(aValue: tBCD); virtual;
209       procedure SetIsNull(Value: Boolean); virtual;
210       procedure SetIsNullable(Value: Boolean); virtual;
# Line 247 | Line 246 | type
246      FUniqueRelationName: AnsiString;
247      FColumnList: array of TSQLVarData;
248      function GetStatement: IStatement; virtual; abstract;
249 +    function GetAttachment: IAttachment; virtual;
250 +    function GetTransaction: ITransaction; virtual;
251      function GetPrepareSeqNo: integer; virtual; abstract;
252      function GetTransactionSeqNo: integer; virtual; abstract;
253      procedure SetCount(aValue: integer); virtual; abstract;
# Line 267 | Line 268 | type
268                                              write FCaseSensitiveParams; {Only used when IsInputDataArea true}
269      function CanChangeMetaData: boolean; virtual; abstract;
270      property Count: integer read GetCount;
271 <    property Column[index: integer]: TSQLVarData read GetColumn;
271 >    property Column[index: integer]: TSQLVarData read GetColumn; default;
272      property UniqueRelationName: AnsiString read FUniqueRelationName;
273      property Statement: IStatement read GetStatement;
274 +    property Attachment: IAttachment read GetAttachment;
275      property PrepareSeqNo: integer read GetPrepareSeqNo;
276 +    property Transaction: ITransaction read GetTransaction;
277      property TransactionSeqNo: integer read GetTransactionSeqNo;
278    end;
279  
# Line 284 | Line 287 | type
287      FModified: boolean;
288      FUniqueName: boolean;
289      FVarString: RawByteString;
290 +    FColMetaData: IParamMetaData;
291      function GetStatement: IStatement;
292      procedure SetName(AValue: AnsiString);
293    protected
294 <    function GetAttachment: IAttachment; virtual; abstract;
294 >    FArrayIntf: IArray;
295 >    function GetAttachment: IAttachment;
296 >    function GetTransaction: ITransaction;
297      function GetSQLType: cardinal; virtual; abstract;
298      function GetSubtype: integer; virtual; abstract;
299      function GetAliasName: AnsiString;  virtual; abstract;
# Line 296 | Line 302 | type
302      function GetRelationName: AnsiString;  virtual; abstract;
303      function GetScale: integer; virtual; abstract;
304      function GetCharSetID: cardinal; virtual; abstract;
305 <    function GetCharSetWidth: integer; virtual; abstract;
306 <    function GetCodePage: TSystemCodePage; virtual; abstract;
305 >    function GetCharSetWidth: integer;
306 >    function GetCodePage: TSystemCodePage;
307      function GetIsNull: Boolean;   virtual; abstract;
308      function GetIsNullable: boolean; virtual; abstract;
309      function GetSQLData: PByte;  virtual; abstract;
310      function GetDataLength: cardinal; virtual; abstract; {current field length}
311      function GetSize: cardinal; virtual; abstract; {field length as given by metadata}
312      function GetDefaultTextSQLType: cardinal; virtual; abstract;
313 +    procedure InternalSetSQLType(aValue: cardinal); virtual; abstract;
314 +    procedure InternalSetScale(aValue: integer); virtual; abstract;
315 +    procedure InternalSetDataLength(len: cardinal); virtual; abstract;
316      procedure SetIsNull(Value: Boolean); virtual; abstract;
317      procedure SetIsNullable(Value: Boolean);  virtual; abstract;
318      procedure SetSQLData(AValue: PByte; len: cardinal); virtual; abstract;
319 <    procedure SetScale(aValue: integer); virtual; abstract;
320 <    procedure SetDataLength(len: cardinal); virtual; abstract;
321 <    procedure SetSQLType(aValue: cardinal); virtual; abstract;
319 >    procedure SetScale(aValue: integer);
320 >    procedure SetDataLength(len: cardinal);
321 >    procedure SetSQLType(aValue: cardinal);
322      procedure SetCharSetID(aValue: cardinal); virtual; abstract;
323      procedure SetMetaSize(aValue: cardinal); virtual;
324    public
325      constructor Create(aParent: TSQLDataArea; aIndex: integer);
326 +    function CanChangeMetaData: boolean;
327      procedure SetString(aValue: AnsiString);
328      procedure Changed; virtual;
329      procedure RowChange; virtual;
330 <    function GetAsArray(Array_ID: TISC_QUAD): IArray; virtual; abstract;
330 >    function GetAsArray: IArray; virtual; abstract;
331      function GetAsBlob(Blob_ID: TISC_QUAD; BPB: IBPB): IBlob; virtual; abstract;
332      function CreateBlob: IBlob; virtual; abstract;
333      function GetArrayMetaData: IArrayMetaData; virtual; abstract;
334      function GetBlobMetaData: IBlobMetaData; virtual; abstract;
335 +    function getColMetadata: IParamMetaData;
336      procedure Initialize; virtual;
337 +    procedure SaveMetaData;
338 +    procedure SetArray(AValue: IArray);
339  
340    public
341      property AliasName: AnsiString read GetAliasName;
# Line 333 | Line 346 | type
346      property Index: integer read FIndex;
347      property Name: AnsiString read FName write SetName;
348      property CharSetID: cardinal read GetCharSetID write SetCharSetID;
349 +    property CodePage: TSystemCodePage read GetCodePage;
350      property SQLType: cardinal read GetSQLType write SetSQLType;
351      property SQLSubtype: integer read GetSubtype;
352      property SQLData: PByte read GetSQLData;
# Line 348 | Line 362 | type
362  
363    { TColumnMetaData }
364  
365 <  TColumnMetaData = class(TSQLDataItem,IColumnMetaData)
365 >  TColumnMetaData = class(TSQLDataItem,IColumnMetaData,IParamMetaData)
366    private
367      FIBXSQLVAR: TSQLVarData;
368      FOwner: IUnknown;         {Keep reference to ensure Metadata/statement not discarded}
# Line 356 | Line 370 | type
370      FChangeSeqNo: integer;
371    protected
372      procedure CheckActive; override;
359    function GetAttachment: IAttachment; override;
373      function SQLData: PByte; override;
374      function GetDataLength: cardinal; override;
375      function GetCodePage: TSystemCodePage; override;
# Line 365 | Line 378 | type
378      constructor Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
379      destructor Destroy; override;
380      function GetSQLDialect: integer; override;
381 +    function getColMetadata: IParamMetaData; override;
382  
383    public
384      {IColumnMetaData}
# Line 384 | Line 398 | type
398      function GetArrayMetaData: IArrayMetaData;
399      function GetBlobMetaData: IBlobMetaData;
400      function GetStatement: IStatement;
401 <    function GetTransaction: ITransaction; virtual;
401 >    function GetTransaction: ITransaction; override;
402 >    function GetAttachment: IAttachment; override;
403      property Name: AnsiString read GetName;
404      property Size: cardinal read GetSize;
405      property CharSetID: cardinal read getCharSetID;
# Line 397 | Line 412 | type
412    { TIBSQLData }
413  
414    TIBSQLData = class(TColumnMetaData,ISQLData)
400  private
401    FTransaction: ITransaction;
415    protected
416      procedure CheckActive; override;
417    public
405    function GetTransaction: ITransaction; override;
418      function GetIsNull: Boolean; override;
419      function GetAsArray: IArray;
420      function GetAsBlob: IBlob; overload;
# Line 411 | Line 423 | type
423      property AsBlob: IBlob read GetAsBlob;
424   end;
425  
426 +  { TSQLParamMetaData }
427 +
428 +  TSQLParamMetaData = class(TFBInterfacedObject,IParamMetaData)
429 +  private
430 +    FSQLType: cardinal;
431 +    FSQLSubType: integer;
432 +    FScale: integer;
433 +    FCharSetID: cardinal;
434 +    FNullable: boolean;
435 +    FSize: cardinal;
436 +    FCodePage: TSystemCodePage;
437 +  public
438 +    constructor Create(src: TSQLVarData);
439 +    {IParamMetaData}
440 +    function GetSQLType: cardinal;
441 +    function GetSQLTypeName: AnsiString;
442 +    function getSubtype: integer;
443 +    function getScale: integer;
444 +    function getCharSetID: cardinal;
445 +    function getCodePage: TSystemCodePage;
446 +    function getIsNullable: boolean;
447 +    function GetSize: cardinal;
448 +    property SQLType: cardinal read GetSQLType;
449 +  end;
450 +
451    { TSQLParam }
452  
453    TSQLParam = class(TIBSQLData,ISQLParam,ISQLData)
# Line 423 | Line 460 | type
460      procedure SetSQLType(aValue: cardinal); override;
461    public
462      procedure Clear;
463 +    function CanChangeMetaData: boolean; override;
464 +    function getColMetadata: IParamMetaData; override;
465      function GetModified: boolean; override;
466      function GetAsPointer: Pointer;
467      function GetAsString: AnsiString; override;
# Line 455 | Line 494 | type
494      procedure SetAsQuad(AValue: TISC_QUAD);
495      procedure SetCharSetID(aValue: cardinal);
496      procedure SetAsBcd(aValue: tBCD);
497 +    procedure SetAsNumeric(aValue: IFBNumeric);
498  
499      property AsBlob: IBlob read GetAsBlob write SetAsBlob;
500      property IsNullable: Boolean read GetIsNullable write SetIsNullable;
# Line 498 | Line 538 | type
538      function ByName(Idx: AnsiString): ISQLParam ;
539      function GetModified: Boolean;
540      function GetHasCaseSensitiveParams: Boolean;
541 +    function GetStatement: IStatement;
542 +    function GetTransaction: ITransaction;
543 +    function GetAttachment: IAttachment;
544 +    procedure Clear;
545    end;
546  
547    { TResults }
# Line 520 | Line 564 | type
564       function getSQLData(index: integer): ISQLData;
565       procedure GetData(index: integer; var IsNull:boolean; var len: short; var data: PByte);
566       function GetStatement: IStatement;
567 <     function GetTransaction: ITransaction; virtual;
567 >     function GetTransaction: ITransaction;
568 >     function GetAttachment: IAttachment;
569       procedure SetRetainInterfaces(aValue: boolean);
570   end;
571  
572   implementation
573  
574 < uses FBMessages, variants, IBUtils, FBTransaction, DateUtils;
574 > uses FBMessages, variants, IBUtils, FBTransaction, FBNumeric, DateUtils;
575 >
576 > { TSQLParamMetaData }
577 >
578 > constructor TSQLParamMetaData.Create(src: TSQLVarData);
579 > begin
580 >  inherited Create;
581 >  FSQLType := src.GetSQLType;
582 >  FSQLSubType := src.getSubtype;
583 >  FScale := src.GetScale;
584 >  FCharSetID := src.getCharSetID;
585 >  FNullable := src.GetIsNullable;
586 >  FSize := src.GetSize;
587 >  FCodePage := src.GetCodePage;
588 > end;
589 >
590 > function TSQLParamMetaData.GetSQLType: cardinal;
591 > begin
592 >  Result := FSQLType;
593 > end;
594 >
595 > function TSQLParamMetaData.GetSQLTypeName: AnsiString;
596 > begin
597 >  Result := TSQLDataItem.GetSQLTypeName(FSQLType);
598 > end;
599 >
600 > function TSQLParamMetaData.getSubtype: integer;
601 > begin
602 >  Result := FSQLSubType;
603 > end;
604 >
605 > function TSQLParamMetaData.getScale: integer;
606 > begin
607 >  Result := FScale;
608 > end;
609 >
610 > function TSQLParamMetaData.getCharSetID: cardinal;
611 > begin
612 >  Result := FCharSetID;
613 > end;
614 >
615 > function TSQLParamMetaData.getCodePage: TSystemCodePage;
616 > begin
617 >  Result :=  FCodePage;
618 > end;
619 >
620 > function TSQLParamMetaData.getIsNullable: boolean;
621 > begin
622 >  Result :=  FNullable;
623 > end;
624 >
625 > function TSQLParamMetaData.GetSize: cardinal;
626 > begin
627 >  Result := FSize;
628 > end;
629  
630   { TSQLDataArea }
631  
# Line 542 | Line 641 | begin
641    Result := Length(FColumnList);
642   end;
643  
644 + function TSQLDataArea.GetTransaction: ITransaction;
645 + begin
646 +  Result := GetStatement.GetTransaction;
647 + end;
648 +
649 + function TSQLDataArea.GetAttachment: IAttachment;
650 + begin
651 +  Result := GetStatement.GetAttachment;
652 + end;
653 +
654   procedure TSQLDataArea.SetUniqueRelationName;
655   var
656    i: Integer;
# Line 674 | Line 783 | begin
783      FName := AValue;
784   end;
785  
786 + function TSQLVarData.GetAttachment: IAttachment;
787 + begin
788 +  Result := Parent.Attachment;
789 + end;
790 +
791 + function TSQLVarData.GetTransaction: ITransaction;
792 + begin
793 +  Result := Parent.Transaction;
794 + end;
795 +
796 + function TSQLVarData.GetCharSetWidth: integer;
797 + begin
798 +  result := 1;
799 +  GetAttachment.CharSetWidth(GetCharSetID,result);
800 + end;
801 +
802 + function TSQLVarData.GetCodePage: TSystemCodePage;
803 + begin
804 +  result := CP_NONE;
805 +  GetAttachment.CharSetID2CodePage(GetCharSetID,result);
806 + end;
807 +
808 + procedure TSQLVarData.SetScale(aValue: integer);
809 + begin
810 +  if aValue = Scale then
811 +    Exit;
812 +  if not CanChangeMetaData  then
813 +    IBError(ibxeScaleCannotBeChanged,[]);
814 +  InternalSetScale(aValue);
815 + end;
816 +
817 + procedure TSQLVarData.SetDataLength(len: cardinal);
818 + begin
819 +  if len = DataLength then
820 +    Exit;
821 +  InternalSetDataLength(len);
822 + end;
823 +
824 + procedure TSQLVarData.SetSQLType(aValue: cardinal);
825 + begin
826 +  if aValue = SQLType then
827 +    Exit;
828 +  if not CanChangeMetaData then
829 +    IBError(ibxeSQLTypeUnchangeable,[TSQLDataItem.GetSQLTypeName(SQLType),
830 +                                          TSQLDataItem.GetSQLTypeName(aValue)]);
831 +  InternalSetSQLType(aValue);
832 + end;
833 +
834   procedure TSQLVarData.SetMetaSize(aValue: cardinal);
835   begin
836    //Ignore
837   end;
838  
839 + procedure TSQLVarData.SaveMetaData;
840 + begin
841 +  FColMetaData := TSQLParamMetaData.Create(self);
842 + end;
843 +
844 + procedure TSQLVarData.SetArray(AValue: IArray);
845 + begin
846 +  FArrayIntf := AValue;
847 + end;
848 +
849   constructor TSQLVarData.Create(aParent: TSQLDataArea; aIndex: integer);
850   begin
851    inherited Create;
# Line 687 | Line 854 | begin
854    FUniqueName := true;
855   end;
856  
857 + function TSQLVarData.CanChangeMetaData: boolean;
858 + begin
859 +  Result := Parent.CanChangeMetaData;
860 + end;
861 +
862   procedure TSQLVarData.SetString(aValue: AnsiString);
863   begin
864    {we take full advantage here of reference counted strings. When setting a string
# Line 697 | Line 869 | begin
869    FVarString := aValue;
870    if SQLType = SQL_BLOB then
871      SetMetaSize(GetAttachment.GetInlineBlobLimit);
872 <  SQLType := GetDefaultTextSQLType;
872 >  if CanChangeMetaData then
873 >    SQLType := GetDefaultTextSQLType;
874    Scale := 0;
875 +  if  (SQLType <> SQL_VARYING) and (SQLType <> SQL_TEXT) then
876 +    IBError(ibxeUnableTosetaTextType,[Index,Name,TSQLDataItem.GetSQLTypeName(SQLType)]);
877    SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
878   end;
879  
# Line 709 | Line 884 | end;
884  
885   procedure TSQLVarData.RowChange;
886   begin
887 +  FArrayIntf := nil;
888    FModified := false;
889    FVarString := '';
890   end;
891  
892 + function TSQLVarData.getColMetadata: IParamMetaData;
893 + begin
894 +  Result := FColMetaData;
895 + end;
896 +
897   procedure TSQLVarData.Initialize;
898  
899    function FindVarByName(idx: AnsiString; limit: integer): TSQLVarData;
# Line 772 | Line 953 | end;
953  
954   {TSQLDataItem}
955  
775 function TSQLDataItem.AdjustScale(Value: Int64; aScale: Integer): Double;
776 var
777  Scaling : Int64;
778  i: Integer;
779  Val: Double;
780 begin
781  Scaling := 1; Val := Value;
782  if aScale > 0 then
783  begin
784    for i := 1 to aScale do
785      Scaling := Scaling * 10;
786    result := Val * Scaling;
787  end
788  else
789    if aScale < 0 then
790    begin
791      for i := -1 downto aScale do
792        Scaling := Scaling * 10;
793      result := Val / Scaling;
794    end
795    else
796      result := Val;
797 end;
798
799 function TSQLDataItem.AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
800 var
801  Scaling : Int64;
802  i: Integer;
803  Val: Int64;
804 begin
805  Scaling := 1; Val := Value;
806  if aScale > 0 then begin
807    for i := 1 to aScale do Scaling := Scaling * 10;
808    result := Val * Scaling;
809  end else if aScale < 0 then begin
810    for i := -1 downto aScale do Scaling := Scaling * 10;
811    result := Val div Scaling;
812  end else
813    result := Val;
814 end;
815
816 function TSQLDataItem.AdjustScaleToCurrency(Value: Int64; aScale: Integer
817  ): Currency;
818 var
819  Scaling : Int64;
820  i : Integer;
821  FractionText, PadText, CurrText: AnsiString;
822 begin
823  Result := 0;
824  Scaling := 1;
825  PadText := '';
826  if aScale > 0 then
827  begin
828    for i := 1 to aScale do
829      Scaling := Scaling * 10;
830    result := Value * Scaling;
831  end
832  else
833    if aScale < 0 then
834    begin
835      for i := -1 downto aScale do
836        Scaling := Scaling * 10;
837      FractionText := IntToStr(abs(Value mod Scaling));
838      for i := Length(FractionText) to -aScale -1 do
839        PadText := '0' + PadText;
840      {$IF declared(DefaultFormatSettings)}
841      with DefaultFormatSettings do
842      {$ELSE}
843      {$IF declared(FormatSettings)}
844      with FormatSettings do
845      {$IFEND}
846      {$IFEND}
847      if Value < 0 then
848        CurrText := '-' + IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText
849      else
850        CurrText := IntToStr(Abs(Value div Scaling)) + DecimalSeparator + PadText + FractionText;
851      try
852        result := StrToCurr(CurrText);
853      except
854        on E: Exception do
855          IBError(ibxeInvalidDataConversion, [nil]);
856      end;
857    end
858    else
859      result := Value;
860 end;
861
956   function TSQLDataItem.GetDateFormatStr(IncludeTime: boolean): AnsiString;
957   begin
958    {$IF declared(DefaultFormatSettings)}
# Line 956 | Line 1050 | begin
1050      end;
1051   end;
1052  
959 function TSQLDataItem.AdjustScaleFromCurrency(Value: Currency; aScale: Integer
960  ): Int64;
961 var
962  Scaling : Int64;
963  i : Integer;
964 begin
965  Result := 0;
966  Scaling := 1;
967  if aScale < 0 then
968  begin
969    for i := -1 downto aScale do
970      Scaling := Scaling * 10;
971    result := trunc(Value * Scaling);
972  end
973  else
974  if aScale > 0 then
975  begin
976    for i := 1 to aScale do
977       Scaling := Scaling * 10;
978    result := trunc(Value / Scaling);
979  end
980  else
981    result := trunc(Value);
982 end;
983
984 function TSQLDataItem.AdjustScaleFromDouble(Value: Double; aScale: Integer
985  ): Int64;
986 var
987  Scaling : Int64;
988  i : Integer;
989 begin
990  Result := 0;
991  Scaling := 1;
992  if aScale < 0 then
993  begin
994    for i := -1 downto aScale do
995      Scaling := Scaling * 10;
996    result := trunc(Value * Scaling);
997  end
998  else
999  if aScale > 0 then
1000  begin
1001    for i := 1 to aScale do
1002       Scaling := Scaling * 10;
1003    result := trunc(Value / Scaling);
1004  end
1005  else
1006    result := trunc(Value);
1007 end;
1008
1053   procedure TSQLDataItem.CheckActive;
1054   begin
1055    //Do nothing by default
# Line 1072 | Line 1116 | begin
1116    FFirebirdClientAPI := api;
1117   end;
1118  
1119 + function TSQLDataItem.CanChangeMetaData: boolean;
1120 + begin
1121 +  Result := false;
1122 + end;
1123 +
1124   function TSQLDataItem.GetSQLTypeName: AnsiString;
1125   begin
1126    Result := GetSQLTypeName(GetSQLType);
1127   end;
1128  
1129 < class function TSQLDataItem.GetSQLTypeName(SQLType: short): AnsiString;
1129 > class function TSQLDataItem.GetSQLTypeName(SQLType: cardinal): AnsiString;
1130   begin
1131    Result := 'Unknown';
1132    case SQLType of
# Line 1147 | Line 1196 | begin
1196            end;
1197          end;
1198          SQL_SHORT:
1199 <          result := AdjustScaleToCurrency(Int64(PShort(SQLData)^),
1200 <                                      Scale);
1199 >          result := NumericFromRawValues(Int64(PShort(SQLData)^),
1200 >                                      Scale).getAsCurrency;
1201          SQL_LONG:
1202 <          result := AdjustScaleToCurrency(Int64(PLong(SQLData)^),
1203 <                                      Scale);
1202 >          result := NumericFromRawValues(Int64(PLong(SQLData)^),
1203 >                                      Scale).getAsCurrency;
1204          SQL_INT64:
1205 <          result := AdjustScaleToCurrency(PInt64(SQLData)^,
1206 <                                      Scale);
1205 >          result := NumericFromRawValues(PInt64(SQLData)^,
1206 >                                      Scale).getAsCurrency;
1207          SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1208            result := Round(AsDouble);
1209  
# Line 1185 | Line 1234 | begin
1234          end;
1235        end;
1236        SQL_SHORT:
1237 <        result := AdjustScaleToInt64(Int64(PShort(SQLData)^),
1238 <                                    Scale);
1237 >        result := NumericFromRawValues(Int64(PShort(SQLData)^),
1238 >                                    Scale).getAsInt64;
1239        SQL_LONG:
1240 <        result := AdjustScaleToInt64(Int64(PLong(SQLData)^),
1241 <                                    Scale);
1240 >        result := NumericFromRawValues(Int64(PLong(SQLData)^),
1241 >                                    Scale).getAsInt64;
1242        SQL_INT64:
1243 <        result := AdjustScaleToInt64(PInt64(SQLData)^,
1244 <                                    Scale);
1243 >        result := NumericFromRawValues(PInt64(SQLData)^,
1244 >                                    Scale).getAsInt64;
1245        SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1246          result := Round(AsDouble);
1247        else
# Line 1321 | Line 1370 | begin
1370          end;
1371        end;
1372        SQL_SHORT:
1373 <        result := AdjustScale(Int64(PShort(SQLData)^),
1374 <                              Scale);
1373 >        result := NumericFromRawValues(Int64(PShort(SQLData)^),
1374 >                              Scale).getAsDouble;
1375        SQL_LONG:
1376 <        result := AdjustScale(Int64(PLong(SQLData)^),
1377 <                              Scale);
1376 >        result := NumericFromRawValues(Int64(PLong(SQLData)^),
1377 >                              Scale).getAsDouble;
1378        SQL_INT64:
1379 <        result := AdjustScale(PInt64(SQLData)^, Scale);
1379 >        result := NumericFromRawValues(PInt64(SQLData)^, Scale).getAsDouble;
1380        SQL_FLOAT:
1381          result := PFloat(SQLData)^;
1382        SQL_DOUBLE, SQL_D_FLOAT:
# Line 1373 | Line 1422 | begin
1422          end;
1423        end;
1424        SQL_SHORT:
1425 <        result := Round(AdjustScale(Int64(PShort(SQLData)^),
1426 <                                    Scale));
1425 >        result := NumericFromRawValues(Int64(PShort(SQLData)^),
1426 >                                    Scale).getAsInteger;
1427        SQL_LONG:
1428 <        result := Round(AdjustScale(Int64(PLong(SQLData)^),
1429 <                                    Scale));
1428 >        result := NumericFromRawValues(Int64(PLong(SQLData)^),
1429 >                                    Scale).getAsInteger;
1430        SQL_INT64:
1431 <        result := Round(AdjustScale(PInt64(SQLData)^, Scale));
1431 >        result := NumericFromRawValues(PInt64(SQLData)^, Scale).getAsInteger;
1432 >
1433        SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1434          result := Round(AsDouble);
1435        SQL_DEC_FIXED,
# Line 1476 | Line 1526 | end;
1526   function GetStrLen(p: PAnsiChar; FieldWidth, MaxDataLength: cardinal): integer;
1527   var i: integer;
1528      cplen: integer;
1479    s: AnsiString;
1529   begin
1530    Result := 0;
1482  s := strpas(p);
1531    for i := 1 to FieldWidth do
1532    begin
1533      cplen := UTF8CodepointSizeFull(p);
# Line 1596 | Line 1644 | begin
1644          result := Int128ToStr(SQLData,scale);
1645  
1646        else
1647 <        IBError(ibxeInvalidDataConversion, [nil]);
1647 >        IBError(ibxeInvalidDataConversion, [GetSQLTypeName]);
1648      end;
1649   end;
1650  
1651 + function TSQLDataItem.GetAsNumeric: IFBNumeric;
1652 + var aValue: Int64;
1653 + begin
1654 +  case SQLType of
1655 +   SQL_TEXT, SQL_VARYING:
1656 +     Result := NewNumeric(GetAsString);
1657 +
1658 +   SQL_SHORT:
1659 +     Result := NumericFromRawValues(PShort(SQLData)^, Scale);
1660 +
1661 +   SQL_LONG:
1662 +     Result := NumericFromRawValues(PLong(SQLData)^, Scale);
1663 +
1664 +   SQL_INT64:
1665 +     Result := NumericFromRawValues(PInt64(SQLData)^, Scale);
1666 +
1667 +   SQL_DEC16,
1668 +   SQL_DEC34,
1669 +   SQL_DEC_FIXED,
1670 +   SQL_INT128:
1671 +     Result := NewNumeric(GetAsBCD);
1672 +
1673 +   else
1674 +     IBError(ibxeInvalidDataConversion, [nil]);
1675 +  end;
1676 + end;
1677 +
1678   function TSQLDataItem.GetIsNull: Boolean;
1679   begin
1680    CheckActive;
# Line 1738 | Line 1813 | begin
1813    if GetSQLDialect < 3 then
1814      AsDouble := Value
1815    else
1816 +  if not CanChangeMetaData and ((SQLType <> SQL_INT64) or (Scale <> -4)) then
1817 +    SetAsNumeric(NewNumeric(Value))
1818 +  else
1819    begin
1820      Changing;
1821      if IsNullable then
# Line 1753 | Line 1831 | end;
1831   procedure TSQLDataItem.SetAsInt64(Value: Int64);
1832   begin
1833    CheckActive;
1834 <  Changing;
1835 <  if IsNullable then
1836 <    IsNull := False;
1834 >  if not CanChangeMetaData and ((SQLType <> SQL_INT64) or (Scale <> 0)) then
1835 >    SetAsNumeric(NewNumeric(Value))
1836 >  else
1837 >  begin
1838 >    Changing;
1839 >    if IsNullable then
1840 >      IsNull := False;
1841  
1842 <  SQLType := SQL_INT64;
1843 <  Scale := 0;
1844 <  DataLength := SizeOf(Int64);
1845 <  PInt64(SQLData)^ := Value;
1846 <  Changed;
1842 >    SQLType := SQL_INT64;
1843 >    Scale := 0;
1844 >    DataLength := SizeOf(Int64);
1845 >    PInt64(SQLData)^ := Value;
1846 >    Changed;
1847 >  end;
1848   end;
1849  
1850   procedure TSQLDataItem.SetAsDate(Value: TDateTime);
# Line 1924 | Line 2007 | end;
2007   procedure TSQLDataItem.SetAsLong(Value: Long);
2008   begin
2009    CheckActive;
2010 <  if IsNullable then
2011 <    IsNull := False;
2010 >  if not CanChangeMetaData and ((SQLType <> SQL_LONG) or (Scale <> 0)) then
2011 >    SetAsNumeric(NewNumeric(Value))
2012 >  else
2013 >  begin
2014 >    if IsNullable then
2015 >      IsNull := False;
2016  
2017 <  Changing;
2018 <  SQLType := SQL_LONG;
2019 <  DataLength := SizeOf(Long);
2020 <  Scale := 0;
2021 <  PLong(SQLData)^ := Value;
2022 <  Changed;
2017 >    Changing;
2018 >    SQLType := SQL_LONG;
2019 >    DataLength := SizeOf(Long);
2020 >    Scale := 0;
2021 >    PLong(SQLData)^ := Value;
2022 >    Changed;
2023 >  end;
2024   end;
2025  
2026   procedure TSQLDataItem.SetAsPointer(Value: Pointer);
# Line 1967 | Line 2055 | end;
2055   procedure TSQLDataItem.SetAsShort(Value: short);
2056   begin
2057    CheckActive;
2058 <  Changing;
2059 <  if IsNullable then
2060 <    IsNull := False;
2058 >  if not CanChangeMetaData and ((SQLType <> SQL_SHORT) or (Scale <> 0)) then
2059 >    SetAsNumeric(NewNumeric(Value))
2060 >  else
2061 >  begin
2062 >    Changing;
2063 >    if IsNullable then
2064 >      IsNull := False;
2065  
2066 <  SQLType := SQL_SHORT;
2067 <  DataLength := SizeOf(Short);
2068 <  Scale := 0;
2069 <  PShort(SQLData)^ := Value;
2070 <  Changed;
2066 >    SQLType := SQL_SHORT;
2067 >    DataLength := SizeOf(Short);
2068 >    Scale := 0;
2069 >    PShort(SQLData)^ := Value;
2070 >    Changed;
2071 >  end;
2072   end;
2073  
2074   procedure TSQLDataItem.SetAsString(Value: AnsiString);
# Line 1995 | Line 2088 | begin
2088      varEmpty, varNull:
2089        IsNull := True;
2090      varSmallint, varInteger, varByte,
2091 <      varWord, varShortInt:
2092 <      AsLong := Value;
2000 <    varInt64:
2001 <      AsInt64 := Value;
2091 >      varWord, varShortInt, varInt64:
2092 >        SetAsNumeric(NewNumeric(Int64(Value)));
2093      varSingle, varDouble:
2094        AsDouble := Value;
2095      varCurrency:
2096 <      AsCurrency := Value;
2096 >      SetAsNumeric(NewNumeric(Currency(Value)));
2097      varBoolean:
2098        AsBoolean := Value;
2099      varDate:
# Line 2021 | Line 2112 | begin
2112    end;
2113   end;
2114  
2115 < procedure TSQLDataItem.SetAsNumeric(Value: Int64; aScale: integer);
2115 > procedure TSQLDataItem.SetAsNumeric(Value: IFBNumeric);
2116   begin
2117    CheckActive;
2118    Changing;
2119    if IsNullable then
2120      IsNull := False;
2121  
2122 <  SQLType := SQL_INT64;
2123 <  Scale := aScale;
2124 <  DataLength := SizeOf(Int64);
2125 <  PInt64(SQLData)^ := Value;
2122 >  if CanChangeMetadata then
2123 >  begin
2124 >    {Restore original values}
2125 >    SQLType := getColMetadata.GetSQLType;
2126 >    Scale := getColMetadata.getScale;
2127 >    SetDataLength(getColMetadata.GetSize);
2128 >  end;
2129 >
2130 >  with FFirebirdClientAPI do
2131 >  case GetSQLType of
2132 >  SQL_LONG:
2133 >      PLong(SQLData)^ := SafeInteger(Value.clone(Scale).getRawValue);
2134 >  SQL_SHORT:
2135 >    PShort(SQLData)^ := SafeSmallInt(Value.clone(Scale).getRawValue);
2136 >  SQL_INT64:
2137 >    PInt64(SQLData)^ := Value.clone(Scale).getRawValue;
2138 >  SQL_TEXT, SQL_VARYING:
2139 >   SetAsString(Value.getAsString);
2140 >  SQL_D_FLOAT,
2141 >  SQL_DOUBLE:
2142 >    PDouble(SQLData)^ := Value.getAsDouble;
2143 >  SQL_FLOAT:
2144 >    PSingle(SQLData)^ := Value.getAsDouble;
2145 >  SQL_DEC_FIXED,
2146 >  SQL_DEC16,
2147 >  SQL_DEC34:
2148 >     SQLDecFloatEncode(Value.getAsBCD,SQLType,SQLData);
2149 >  SQL_INT128:
2150 >    StrToInt128(Scale,Value.getAsString,SQLData);
2151 >  else
2152 >    IBError(ibxeInvalidDataConversion, [nil]);
2153 >  end;
2154    Changed;
2155   end;
2156  
2157   procedure TSQLDataItem.SetAsBcd(aValue: tBCD);
2039 var C: Currency;
2158   begin
2159    CheckActive;
2160    Changing;
2161    if IsNullable then
2162      IsNull := False;
2163  
2164 +  if not CanChangeMetaData then
2165 +  begin
2166 +    SetAsNumeric(NewNumeric(aValue));
2167 +    Exit;
2168 +  end;
2169  
2170    with FFirebirdClientAPI do
2171    if aValue.Precision <= 16 then
# Line 2112 | Line 2235 | end;
2235  
2236   function TColumnMetaData.GetAttachment: IAttachment;
2237   begin
2238 <  Result := GetStatement.GetAttachment;
2238 >  Result := FIBXSQLVAR.GetAttachment;
2239   end;
2240  
2241   function TColumnMetaData.SQLData: PByte;
# Line 2132 | Line 2255 | end;
2255  
2256   constructor TColumnMetaData.Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
2257   begin
2258 <  inherited Create(aIBXSQLVAR.GetStatement.GetAttachment.getFirebirdAPI as TFBClientAPI);
2258 >  inherited Create(aIBXSQLVAR.GetAttachment.getFirebirdAPI as TFBClientAPI);
2259    FIBXSQLVAR := aIBXSQLVAR;
2260    FOwner := aOwner;
2261    FPrepareSeqNo := FIBXSQLVAR.Parent.PrepareSeqNo;
# Line 2148 | Line 2271 | end;
2271  
2272   function TColumnMetaData.GetSQLDialect: integer;
2273   begin
2274 <  Result := FIBXSQLVAR.Statement.GetSQLDialect;
2274 >  Result := FIBXSQLVAR.GetAttachment.GetSQLDialect;
2275 > end;
2276 >
2277 > function TColumnMetaData.getColMetadata: IParamMetaData;
2278 > begin
2279 >  Result := self;
2280   end;
2281  
2282   function TColumnMetaData.GetIndex: integer;
# Line 2247 | Line 2375 | end;
2375  
2376   function TColumnMetaData.GetTransaction: ITransaction;
2377   begin
2378 <  Result := GetStatement.GetTransaction;
2378 >  Result := FIBXSQLVAR.GetTransaction;
2379   end;
2380  
2381   { TIBSQLData }
# Line 2269 | Line 2397 | begin
2397      IBError(ibxeBOF,[nil]);
2398   end;
2399  
2272 function TIBSQLData.GetTransaction: ITransaction;
2273 begin
2274  if FTransaction = nil then
2275    Result := inherited GetTransaction
2276  else
2277    Result := FTransaction;
2278 end;
2279
2400   function TIBSQLData.GetIsNull: Boolean;
2401   begin
2402    CheckActive;
# Line 2286 | Line 2406 | end;
2406   function TIBSQLData.GetAsArray: IArray;
2407   begin
2408    CheckActive;
2409 <  result := FIBXSQLVAR.GetAsArray(AsQuad);
2409 >  result := FIBXSQLVAR.GetAsArray;
2410   end;
2411  
2412   function TIBSQLData.GetAsBlob: IBlob;
# Line 2330 | Line 2450 | end;
2450  
2451   var b: IBlob;
2452      dt: TDateTime;
2333    CurrValue: Currency;
2334    FloatValue: single;
2453      timezone: AnsiString;
2454 +    Int64Value: Int64;
2455 +    BCDValue: TBCD;
2456 +    aScale: integer;
2457   begin
2458    CheckActive;
2459    if IsNullable then
# Line 2364 | Line 2485 | begin
2485    SQL_TEXT:
2486      DoSetString;
2487  
2488 <    SQL_SHORT,
2489 <    SQL_LONG,
2490 <    SQL_INT64:
2491 <      if TryStrToCurr(Value,CurrValue) then
2492 <        SetAsNumeric(AdjustScaleFromCurrency(CurrValue,GetScale),GetScale)
2493 <      else
2494 <        DoSetString;
2488 >  SQL_SHORT,
2489 >  SQL_LONG,
2490 >  SQL_INT64:
2491 >    if TryStrToNumeric(Value,Int64Value,aScale) then
2492 >      SetAsNumeric(NumericFromRawValues(Int64Value,aScale))
2493 >    else
2494 >      DoSetString;
2495  
2496 <    SQL_D_FLOAT,
2497 <    SQL_DOUBLE,
2498 <    SQL_FLOAT:
2499 <      if TryStrToFloat(Value,FloatValue) then
2500 <        SetAsDouble(FloatValue)
2501 <      else
2502 <        DoSetString;
2496 >  SQL_DEC_FIXED,
2497 >  SQL_DEC16,
2498 >  SQL_DEC34,
2499 >  SQL_INT128:
2500 >    if TryStrToBCD(Value,BCDValue) then
2501 >      SetAsNumeric(NewNumeric(BCDValue))
2502 >    else
2503 >      DoSetString;
2504  
2505 <    SQL_TIMESTAMP:
2505 >  SQL_D_FLOAT,
2506 >  SQL_DOUBLE,
2507 >  SQL_FLOAT:
2508 >    if TryStrToNumeric(Value,Int64Value,aScale) then
2509 >      SetAsNumeric(NumericFromRawValues(Int64Value,AScale))
2510 >    else
2511 >      DoSetString;
2512 >
2513 >  SQL_TIMESTAMP:
2514        if TryStrToDateTime(Value,dt) then
2515          SetAsDateTime(dt)
2516        else
2517          DoSetString;
2518  
2519 <    SQL_TYPE_DATE:
2519 >  SQL_TYPE_DATE:
2520        if TryStrToDateTime(Value,dt) then
2521          SetAsDate(dt)
2522        else
2523          DoSetString;
2524  
2525 <    SQL_TYPE_TIME:
2525 >  SQL_TYPE_TIME:
2526        if TryStrToDateTime(Value,dt) then
2527          SetAsTime(dt)
2528        else
2529          DoSetString;
2530  
2531 <    SQL_TIMESTAMP_TZ:
2531 >  SQL_TIMESTAMP_TZ,
2532 >  SQL_TIMESTAMP_TZ_EX:
2533        if ParseDateTimeTZString(value,dt,timezone) then
2534          SetAsDateTime(dt,timezone)
2535        else
2536          DoSetString;
2537  
2538 <    SQL_TIME_TZ:
2538 >  SQL_TIME_TZ,
2539 >  SQL_TIME_TZ_EX:
2540        if ParseDateTimeTZString(value,dt,timezone,true) then
2541          SetAsTime(dt,GetAttachment.GetTimeZoneServices.GetTimeTZDate,timezone)
2542        else
2543          DoSetString;
2544  
2545 <    SQL_DEC_FIXED,
2546 <    SQL_DEC16,
2415 <    SQL_DEC34,
2416 <    SQL_INT128:
2417 <      SetAsBCD(StrToBCD(Value));
2418 <
2419 <    else
2420 <      IBError(ibxeInvalidDataConversion,[GetSQLTypeName(SQLType)]);
2545 >  else
2546 >    IBError(ibxeInvalidDataConversion,[GetSQLTypeName(getColMetaData.SQLTYPE)]);
2547    end;
2548   end;
2549  
# Line 2455 | Line 2581 | begin
2581    IsNull := true;
2582   end;
2583  
2584 + function TSQLParam.CanChangeMetaData: boolean;
2585 + begin
2586 +  Result := FIBXSQLVAR.CanChangeMetaData;
2587 + end;
2588 +
2589 + function TSQLParam.getColMetadata: IParamMetaData;
2590 + begin
2591 +  Result := FIBXSQLVAR.getColMetadata;
2592 + end;
2593 +
2594   function TSQLParam.GetModified: boolean;
2595   begin
2596    CheckActive;
# Line 2529 | Line 2665 | begin
2665    if not FIBXSQLVAR.UniqueName then
2666      IBError(ibxeDuplicateParamName,[FIBXSQLVAR.Name]);
2667  
2668 +  FIBXSQLVAR.SetArray(anArray); {save array interface}
2669    SetAsQuad(AnArray.GetArrayID);
2670   end;
2671  
# Line 3004 | Line 3141 | begin
3141    end;
3142   end;
3143  
3144 + procedure TSQLParam.SetAsNumeric(aValue: IFBNumeric);
3145 + var i: integer;
3146 +    OldSQLVar: TSQLVarData;
3147 + begin
3148 +  if FIBXSQLVAR.UniqueName then
3149 +    inherited SetAsNumeric(AValue)
3150 +  else
3151 +  with FIBXSQLVAR.Parent do
3152 +  begin
3153 +    for i := 0 to Count - 1 do
3154 +      if Column[i].Name = Name then
3155 +      begin
3156 +        OldSQLVar := FIBXSQLVAR;
3157 +        FIBXSQLVAR := Column[i];
3158 +        try
3159 +          inherited SetAsNumeric(AValue);
3160 +        finally
3161 +          FIBXSQLVAR := OldSQLVar;
3162 +        end;
3163 +      end;
3164 +  end;
3165 + end;
3166 +
3167   { TMetaData }
3168  
3169   procedure TMetaData.CheckActive;
# Line 3025 | Line 3185 | end;
3185  
3186   destructor TMetaData.Destroy;
3187   begin
3188 <  (FStatement as TInterfaceOwner).Remove(self);
3188 >  if FStatement <> nil then
3189 >    (FStatement as TInterfaceOwner).Remove(self);
3190    inherited Destroy;
3191   end;
3192  
# Line 3091 | Line 3252 | end;
3252  
3253   destructor TSQLParams.Destroy;
3254   begin
3255 <  (FStatement as TInterfaceOwner).Remove(self);
3255 >  if FStatement <> nil then
3256 >    (FStatement as TInterfaceOwner).Remove(self);
3257    inherited Destroy;
3258   end;
3259  
# Line 3147 | Line 3309 | begin
3309    Result := FSQLParams.CaseSensitiveParams;
3310   end;
3311  
3312 + function TSQLParams.GetStatement: IStatement;
3313 + begin
3314 +  Result := FSQLParams.GetStatement;
3315 + end;
3316 +
3317 + function TSQLParams.GetTransaction: ITransaction;
3318 + begin
3319 +  Result := FSQLParams.GetTransaction;
3320 + end;
3321 +
3322 + function TSQLParams.GetAttachment: IAttachment;
3323 + begin
3324 +  Result := FSQLParams.GetAttachment;
3325 + end;
3326 +
3327 + procedure TSQLParams.Clear;
3328 + var i: integer;
3329 + begin
3330 +  for i := 0 to getCount - 1 do
3331 +    getSQLParam(i).Clear;
3332 + end;
3333 +
3334   { TResults }
3335  
3336   procedure TResults.CheckActive;
# Line 3171 | Line 3355 | begin
3355      IBError(ibxeInvalidColumnIndex,[nil]);
3356  
3357    if not HasInterface(aIBXSQLVAR.Index) then
3358 <    AddInterface(aIBXSQLVAR.Index, TIBSQLData.Create(self,aIBXSQLVAR));
3359 <  col := TIBSQLData(GetInterface(aIBXSQLVAR.Index));
3360 <  col.FTransaction := GetTransaction;
3358 >  begin
3359 >    col := TIBSQLData.Create(self,aIBXSQLVAR);
3360 >    AddInterface(aIBXSQLVAR.Index, col);
3361 >  end
3362 >  else
3363 >    col := TIBSQLData(GetInterface(aIBXSQLVAR.Index));
3364    Result := col;
3365   end;
3366  
# Line 3238 | Line 3425 | end;
3425  
3426   function TResults.GetTransaction: ITransaction;
3427   begin
3428 <  Result := FStatement.GetTransaction;
3428 >  Result := FResults.GetTransaction;
3429 > end;
3430 >
3431 > function TResults.GetAttachment: IAttachment;
3432 > begin
3433 >  Result := FResults.GetAttachment;
3434   end;
3435  
3436   procedure TResults.SetRetainInterfaces(aValue: boolean);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines