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

Comparing:
ibx/trunk/fbintf/client/FBSQLData.pas (file contents), Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC vs.
ibx/branches/journaling/fbintf/client/FBSQLData.pas (file contents), Revision 362 by tony, Tue Dec 7 13:27:39 2021 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
132 +     function AdjustScale(Value: Int64; aScale: Integer): Double;
133 +     function AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
134 +     function AdjustScaleToStr(Value: Int64; aScale: Integer): AnsiString;
135 +     function AdjustScaleToCurrency(Value: Int64; aScale: Integer): Currency;
136       function AdjustScaleFromCurrency(Value: Currency; aScale: Integer): Int64;
137       function AdjustScaleFromDouble(Value: Double; aScale: Integer): Int64;
138       procedure CheckActive; virtual;
# Line 154 | Line 155 | type
155       property FirebirdClientAPI: TFBClientAPI read FFirebirdClientAPI;
156    public
157       constructor Create(api: TFBClientAPI);
158 <     function GetSQLType: cardinal; virtual; abstract;
158 >     function GetSQLType: cardinal; virtual; abstract; {Current Field Data SQL Type}
159       function GetSQLTypeName: AnsiString; overload;
160 <     class function GetSQLTypeName(SQLType: short): AnsiString; overload;
160 >     class function GetSQLTypeName(SQLType: cardinal): AnsiString; overload;
161       function GetStrDataLength: short;
162       function GetName: AnsiString; virtual; abstract;
163 <     function GetScale: integer; virtual; abstract;
163 >     function GetScale: integer; virtual; abstract; {Current Field Data scale}
164       function GetAsBoolean: boolean;
165       function GetAsCurrency: Currency;
166       function GetAsInt64: Int64;
# Line 205 | Line 206 | type
206       procedure SetAsShort(Value: short); virtual;
207       procedure SetAsString(Value: AnsiString); virtual;
208       procedure SetAsVariant(Value: Variant);
209 <     procedure SetAsNumeric(Value: Int64; aScale: integer);
209 >     procedure SetAsNumeric(Value: Int64; aScale: integer); virtual;
210       procedure SetAsBcd(aValue: tBCD); virtual;
211       procedure SetIsNull(Value: Boolean); virtual;
212       procedure SetIsNullable(Value: Boolean); virtual;
# Line 265 | Line 266 | type
266      function StateChanged(var ChangeSeqNo: integer): boolean; virtual; abstract;
267      property CaseSensitiveParams: boolean read FCaseSensitiveParams
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;
272      property UniqueRelationName: AnsiString read FUniqueRelationName;
# Line 283 | Line 285 | type
285      FModified: boolean;
286      FUniqueName: boolean;
287      FVarString: RawByteString;
288 +    FColMetaData: IParamMetaData;
289      function GetStatement: IStatement;
290      procedure SetName(AValue: AnsiString);
291    protected
292 +    function GetAttachment: IAttachment; virtual; abstract;
293      function GetSQLType: cardinal; virtual; abstract;
294      function GetSubtype: integer; virtual; abstract;
295      function GetAliasName: AnsiString;  virtual; abstract;
# Line 301 | Line 305 | type
305      function GetSQLData: PByte;  virtual; abstract;
306      function GetDataLength: cardinal; virtual; abstract; {current field length}
307      function GetSize: cardinal; virtual; abstract; {field length as given by metadata}
308 +    function GetDefaultTextSQLType: cardinal; virtual; abstract;
309      procedure SetIsNull(Value: Boolean); virtual; abstract;
310      procedure SetIsNullable(Value: Boolean);  virtual; abstract;
311      procedure SetSQLData(AValue: PByte; len: cardinal); virtual; abstract;
# Line 308 | Line 313 | type
313      procedure SetDataLength(len: cardinal); virtual; abstract;
314      procedure SetSQLType(aValue: cardinal); virtual; abstract;
315      procedure SetCharSetID(aValue: cardinal); virtual; abstract;
316 +    procedure SetMetaSize(aValue: cardinal); virtual;
317    public
318      constructor Create(aParent: TSQLDataArea; aIndex: integer);
319      procedure SetString(aValue: AnsiString);
# Line 318 | Line 324 | type
324      function CreateBlob: IBlob; virtual; abstract;
325      function GetArrayMetaData: IArrayMetaData; virtual; abstract;
326      function GetBlobMetaData: IBlobMetaData; virtual; abstract;
327 +    function getColMetadata: IParamMetaData;
328      procedure Initialize; virtual;
329 +    procedure SaveMetaData;
330  
331    public
332      property AliasName: AnsiString read GetAliasName;
# Line 407 | Line 415 | type
415      property AsBlob: IBlob read GetAsBlob;
416   end;
417  
418 +  { TSQLParamMetaData }
419 +
420 +  TSQLParamMetaData = class(TFBInterfacedObject,IParamMetaData)
421 +  private
422 +    FSQLType: cardinal;
423 +    FSQLSubType: integer;
424 +    FScale: integer;
425 +    FCharSetID: cardinal;
426 +    FNullable: boolean;
427 +    FSize: cardinal;
428 +    FCodePage: TSystemCodePage;
429 +  public
430 +    constructor Create(src: TSQLVarData);
431 +    {IParamMetaData}
432 +    function GetSQLType: cardinal;
433 +    function GetSQLTypeName: AnsiString;
434 +    function getSubtype: integer;
435 +    function getScale: integer;
436 +    function getCharSetID: cardinal;
437 +    function getCodePage: TSystemCodePage;
438 +    function getIsNullable: boolean;
439 +    function GetSize: cardinal;
440 +    property SQLType: cardinal read GetSQLType;
441 +  end;
442 +
443    { TSQLParam }
444  
445    TSQLParam = class(TIBSQLData,ISQLParam,ISQLData)
# Line 419 | Line 452 | type
452      procedure SetSQLType(aValue: cardinal); override;
453    public
454      procedure Clear;
455 +    function getColMetadata: IParamMetaData;
456      function GetModified: boolean; override;
457      function GetAsPointer: Pointer;
458 +    function GetAsString: AnsiString; override;
459      procedure SetName(Value: AnsiString); override;
460      procedure SetIsNull(Value: Boolean);  override;
461      procedure SetIsNullable(Value: Boolean); override;
# Line 523 | Line 558 | implementation
558  
559   uses FBMessages, variants, IBUtils, FBTransaction, DateUtils;
560  
561 + { TSQLParamMetaData }
562 +
563 + constructor TSQLParamMetaData.Create(src: TSQLVarData);
564 + begin
565 +  inherited Create;
566 +  FSQLType := src.GetSQLType;
567 +  FSQLSubType := src.getSubtype;
568 +  FScale := src.GetScale;
569 +  FCharSetID := src.getCharSetID;
570 +  FNullable := src.GetIsNullable;
571 +  FSize := src.GetSize;
572 +  FCodePage := src.GetCodePage;
573 + end;
574 +
575 + function TSQLParamMetaData.GetSQLType: cardinal;
576 + begin
577 +  Result := FSQLType;
578 + end;
579 +
580 + function TSQLParamMetaData.GetSQLTypeName: AnsiString;
581 + begin
582 +  Result := TSQLDataItem.GetSQLTypeName(FSQLType);
583 + end;
584 +
585 + function TSQLParamMetaData.getSubtype: integer;
586 + begin
587 +  Result := FSQLSubType;
588 + end;
589 +
590 + function TSQLParamMetaData.getScale: integer;
591 + begin
592 +  Result := FScale;
593 + end;
594 +
595 + function TSQLParamMetaData.getCharSetID: cardinal;
596 + begin
597 +  Result := FCharSetID;
598 + end;
599 +
600 + function TSQLParamMetaData.getCodePage: TSystemCodePage;
601 + begin
602 +  Result :=  FCodePage;
603 + end;
604 +
605 + function TSQLParamMetaData.getIsNullable: boolean;
606 + begin
607 +  Result :=  FNullable;
608 + end;
609 +
610 + function TSQLParamMetaData.GetSize: cardinal;
611 + begin
612 +  Result := FSize;
613 + end;
614 +
615   { TSQLDataArea }
616  
617   function TSQLDataArea.GetColumn(index: integer): TSQLVarData;
# Line 669 | Line 758 | begin
758      FName := AValue;
759   end;
760  
761 + procedure TSQLVarData.SetMetaSize(aValue: cardinal);
762 + begin
763 +  //Ignore
764 + end;
765 +
766 + procedure TSQLVarData.SaveMetaData;
767 + begin
768 +  FColMetaData := TSQLParamMetaData.Create(self);
769 + end;
770 +
771   constructor TSQLVarData.Create(aParent: TSQLDataArea; aIndex: integer);
772   begin
773    inherited Create;
# Line 685 | Line 784 | begin
784     a zero byte when the string is empty, neatly avoiding a nil pointer error.}
785  
786    FVarString := aValue;
787 <  SQLType := SQL_TEXT;
787 >  if SQLType = SQL_BLOB then
788 >    SetMetaSize(GetAttachment.GetInlineBlobLimit);
789 >  SQLType := GetDefaultTextSQLType;
790    Scale := 0;
791    SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
792   end;
# Line 701 | Line 802 | begin
802    FVarString := '';
803   end;
804  
805 + function TSQLVarData.getColMetadata: IParamMetaData;
806 + begin
807 +  Result := FColMetaData;
808 + end;
809 +
810   procedure TSQLVarData.Initialize;
811  
812    function FindVarByName(idx: AnsiString; limit: integer): TSQLVarData;
# Line 801 | Line 907 | begin
907      result := Val;
908   end;
909  
910 + function TSQLDataItem.AdjustScaleToStr(Value: Int64; aScale: Integer
911 +  ): AnsiString;
912 + var Scaling : AnsiString;
913 +    i: Integer;
914 + begin
915 +  Result := IntToStr(Value);
916 +  Scaling := '';
917 +  if aScale > 0 then
918 +  begin
919 +    for i := 1 to aScale do
920 +      Result := Result + '0';
921 +  end
922 +  else
923 +  if aScale < 0 then
924 +  {$IF declared(DefaultFormatSettings)}
925 +  with DefaultFormatSettings do
926 +  {$ELSE}
927 +  {$IF declared(FormatSettings)}
928 +  with FormatSettings do
929 +  {$IFEND}
930 +  {$IFEND}
931 +  begin
932 +    if Length(Result) > -aScale then
933 +      system.Insert(DecimalSeparator,Result,Length(Result) + aScale)
934 +    else
935 +    begin
936 +      Scaling := '0' + DecimalSeparator;
937 +      for i := -1 downto aScale + Length(Result) do
938 +        Scaling := Scaling + '0';
939 +      Result := Scaling + Result;
940 +    end;
941 +  end;
942 + end;
943 +
944   function TSQLDataItem.AdjustScaleToCurrency(Value: Int64; aScale: Integer
945    ): Currency;
946   var
# Line 992 | Line 1132 | begin
1132    end
1133    else
1134      result := trunc(Value);
1135 + //  writeln('Adjusted ',Value,' to ',Result);
1136   end;
1137  
1138   procedure TSQLDataItem.CheckActive;
# Line 1065 | Line 1206 | begin
1206    Result := GetSQLTypeName(GetSQLType);
1207   end;
1208  
1209 < class function TSQLDataItem.GetSQLTypeName(SQLType: short): AnsiString;
1209 > class function TSQLDataItem.GetSQLTypeName(SQLType: cardinal): AnsiString;
1210   begin
1211    Result := 'Unknown';
1212    case SQLType of
# Line 1144 | Line 1285 | begin
1285            result := AdjustScaleToCurrency(PInt64(SQLData)^,
1286                                        Scale);
1287          SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1288 <          result := Trunc(AsDouble);
1288 >          result := Round(AsDouble);
1289  
1290          SQL_DEC_FIXED,
1291          SQL_DEC16,
# Line 1182 | Line 1323 | begin
1323          result := AdjustScaleToInt64(PInt64(SQLData)^,
1324                                      Scale);
1325        SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1326 <        result := Trunc(AsDouble);
1326 >        result := Round(AsDouble);
1327        else
1328          IBError(ibxeInvalidDataConversion, [nil]);
1329      end;
# Line 1361 | Line 1502 | begin
1502          end;
1503        end;
1504        SQL_SHORT:
1505 <        result := Trunc(AdjustScale(Int64(PShort(SQLData)^),
1505 >        result := Round(AdjustScale(Int64(PShort(SQLData)^),
1506                                      Scale));
1507        SQL_LONG:
1508 <        result := Trunc(AdjustScale(Int64(PLong(SQLData)^),
1508 >        result := Round(AdjustScale(Int64(PLong(SQLData)^),
1509                                      Scale));
1510        SQL_INT64:
1511 <        result := Trunc(AdjustScale(PInt64(SQLData)^, Scale));
1511 >        result := Round(AdjustScale(PInt64(SQLData)^, Scale));
1512        SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
1513 <        result := Trunc(AsDouble);
1513 >        result := Round(AsDouble);
1514        SQL_DEC_FIXED,
1515        SQL_DEC16,
1516        SQL_DEC34,
# Line 2318 | Line 2459 | end;
2459  
2460   var b: IBlob;
2461      dt: TDateTime;
2321    CurrValue: Currency;
2322    FloatValue: single;
2462      timezone: AnsiString;
2463 +    Int64Value: Int64;
2464 +    BCDValue: TBCD;
2465 +    aScale: integer;
2466   begin
2467    CheckActive;
2468    if IsNullable then
2469      IsNull := False;
2470    with FFirebirdClientAPI do
2471 <  case SQLTYPE of
2471 >  case getColMetaData.SQLTYPE of
2472    SQL_BOOLEAN:
2473      if AnsiCompareText(Value,STrue) = 0 then
2474        AsBoolean := true
# Line 2337 | Line 2479 | begin
2479        IBError(ibxeInvalidDataConversion,[nil]);
2480  
2481    SQL_BLOB:
2482 +    if Length(Value) < GetAttachment.GetInlineBlobLimit then
2483 +      DoSetString
2484 +    else
2485      begin
2486        Changing;
2487        b := FIBXSQLVAR.CreateBlob;
# Line 2349 | Line 2494 | begin
2494    SQL_TEXT:
2495      DoSetString;
2496  
2497 <    SQL_SHORT,
2498 <    SQL_LONG,
2499 <    SQL_INT64:
2500 <      if TryStrToCurr(Value,CurrValue) then
2501 <        SetAsNumeric(AdjustScaleFromCurrency(CurrValue,GetScale),GetScale)
2502 <      else
2503 <        DoSetString;
2497 >  SQL_SHORT,
2498 >  SQL_LONG,
2499 >  SQL_INT64:
2500 >    if TryStrToNumeric(Value,Int64Value,aScale) then
2501 >      SetAsNumeric(Int64Value,aScale)
2502 >    else
2503 >      DoSetString;
2504  
2505 <    SQL_D_FLOAT,
2506 <    SQL_DOUBLE,
2507 <    SQL_FLOAT:
2508 <      if TryStrToFloat(Value,FloatValue) then
2509 <        SetAsDouble(FloatValue)
2510 <      else
2511 <        DoSetString;
2505 >  SQL_DEC_FIXED,
2506 >  SQL_DEC16,
2507 >  SQL_DEC34,
2508 >  SQL_INT128:
2509 >    if TryStrToBCD(Value,BCDValue) then
2510 >      SetAsBCD(BCDValue)
2511 >    else
2512 >      DoSetString;
2513 >
2514 >  SQL_D_FLOAT,
2515 >  SQL_DOUBLE,
2516 >  SQL_FLOAT:
2517 >    if TryStrToNumeric(Value,Int64Value,aScale) then
2518 >      SetAsDouble(NumericToDouble(Int64Value,aScale))
2519 >    else
2520 >      DoSetString;
2521  
2522 <    SQL_TIMESTAMP:
2522 >  SQL_TIMESTAMP:
2523        if TryStrToDateTime(Value,dt) then
2524          SetAsDateTime(dt)
2525        else
2526          DoSetString;
2527  
2528 <    SQL_TYPE_DATE:
2528 >  SQL_TYPE_DATE:
2529        if TryStrToDateTime(Value,dt) then
2530          SetAsDate(dt)
2531        else
2532          DoSetString;
2533  
2534 <    SQL_TYPE_TIME:
2534 >  SQL_TYPE_TIME:
2535        if TryStrToDateTime(Value,dt) then
2536          SetAsTime(dt)
2537        else
2538          DoSetString;
2539  
2540 <    SQL_TIMESTAMP_TZ:
2540 >  SQL_TIMESTAMP_TZ,
2541 >  SQL_TIMESTAMP_TZ_EX:
2542        if ParseDateTimeTZString(value,dt,timezone) then
2543          SetAsDateTime(dt,timezone)
2544        else
2545          DoSetString;
2546  
2547 <    SQL_TIME_TZ:
2547 >  SQL_TIME_TZ,
2548 >  SQL_TIME_TZ_EX:
2549        if ParseDateTimeTZString(value,dt,timezone,true) then
2550          SetAsTime(dt,GetAttachment.GetTimeZoneServices.GetTimeTZDate,timezone)
2551        else
2552          DoSetString;
2553  
2554 <    SQL_DEC_FIXED,
2555 <    SQL_DEC16,
2400 <    SQL_DEC34,
2401 <    SQL_INT128:
2402 <      SetAsBCD(StrToBCD(Value));
2403 <
2404 <    else
2405 <      IBError(ibxeInvalidDataConversion,[nil]);
2554 >  else
2555 >    IBError(ibxeInvalidDataConversion,[GetSQLTypeName(getColMetaData.SQLTYPE)]);
2556    end;
2557   end;
2558  
# Line 2440 | Line 2590 | begin
2590    IsNull := true;
2591   end;
2592  
2593 + function TSQLParam.getColMetadata: IParamMetaData;
2594 + begin
2595 +  Result := FIBXSQLVAR.getColMetadata;
2596 + end;
2597 +
2598   function TSQLParam.GetModified: boolean;
2599   begin
2600    CheckActive;
# Line 2453 | Line 2608 | begin
2608    Result := inherited GetAsPointer;
2609   end;
2610  
2611 + function TSQLParam.GetAsString: AnsiString;
2612 + var rs: RawByteString;
2613 + begin
2614 +  Result := '';
2615 +  if (SQLType = SQL_VARYING) and not IsNull then
2616 +  {SQLData points to start of string - default is to length word}
2617 +  begin
2618 +    CheckActive;
2619 +    SetString(rs,PAnsiChar(SQLData),DataLength);
2620 +    SetCodePage(rs,GetCodePage,false);
2621 +    Result := rs;
2622 +  end
2623 +  else
2624 +    Result := inherited GetAsString;
2625 + end;
2626 +
2627   procedure TSQLParam.SetName(Value: AnsiString);
2628   begin
2629    CheckActive;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines