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 59 by tony, Mon Mar 13 09:51:56 2017 UTC vs.
Revision 287 by tony, Thu Apr 11 08:51:23 2019 UTC

# Line 76 | Line 76 | unit FBSQLData;
76    methods are needed for SQL parameters only. The string getters and setters
77    are virtual as SQLVar and Array encodings of string data is different.}
78  
79 { $define ALLOWDIALECT3PARAMNAMES}
80
81 {$ifndef ALLOWDIALECT3PARAMNAMES}
82
83 { Note on SQL Dialects and SQL Parameter Names
84  --------------------------------------------
85
86  Even when dialect 3 quoted format parameter names are not supported, IBX still processes
87  parameter names case insensitive. This does result in some additional overhead
88  due to a call to "AnsiUpperCase". This can be avoided by undefining
89  "UseCaseInSensitiveParamName" below.
90
91  Note: do not define "UseCaseSensitiveParamName" when "ALLOWDIALECT3PARAMNAMES"
92  is defined. This will not give a useful result.
93 }
94 {$define UseCaseInSensitiveParamName}
95 {$endif}
79  
80   interface
81  
82   uses
83 <  Classes, SysUtils, IBExternals, IBHeader, IB,  FBActivityMonitor;
83 >  Classes, SysUtils, IBExternals, IBHeader, IB,  FBActivityMonitor, FBClientAPI;
84  
85   type
86  
# Line 105 | Line 88 | type
88  
89    TSQLDataItem = class(TFBInterfacedObject)
90    private
91 +     FFirebirdClientAPI: TFBClientAPI;
92       function AdjustScale(Value: Int64; aScale: Integer): Double;
93       function AdjustScaleToInt64(Value: Int64; aScale: Integer): Int64;
94       function AdjustScaleToCurrency(Value: Int64; aScale: Integer): Currency;
95 +     function GetTimestampFormatStr: AnsiString;
96 +     function GetDateFormatStr(IncludeTime: boolean): AnsiString;
97 +     function GetTimeFormatStr: AnsiString;
98       procedure SetAsInteger(AValue: Integer);
99    protected
100       function AdjustScaleFromCurrency(Value: Currency; aScale: Integer): Int64;
# Line 128 | Line 115 | type
115       property DataLength: cardinal read GetDataLength write SetDataLength;
116  
117    public
118 +     constructor Create(api: TFBClientAPI);
119       function GetSQLType: cardinal; virtual; abstract;
120       function GetSQLTypeName: AnsiString; overload;
121       class function GetSQLTypeName(SQLType: short): AnsiString; overload;
# Line 145 | Line 133 | type
133       function GetAsShort: short;
134       function GetAsString: AnsiString; virtual;
135       function GetIsNull: Boolean; virtual;
136 <     function getIsNullable: boolean; virtual;
136 >     function GetIsNullable: boolean; virtual;
137       function GetAsVariant: Variant;
138       function GetModified: boolean; virtual;
139 +     function GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats): integer;
140       procedure SetAsBoolean(AValue: boolean); virtual;
141       procedure SetAsCurrency(Value: Currency); virtual;
142       procedure SetAsInt64(Value: Int64); virtual;
# Line 196 | Line 185 | type
185  
186    TSQLDataArea = class
187    private
188 +    FCaseSensitiveParams: boolean;
189      function GetColumn(index: integer): TSQLVarData;
190      function GetCount: integer;
191    protected
# Line 218 | Line 208 | type
208        var data: PByte); virtual;
209      procedure RowChange;
210      function StateChanged(var ChangeSeqNo: integer): boolean; virtual; abstract;
211 +    property CaseSensitiveParams: boolean read FCaseSensitiveParams
212 +                                            write FCaseSensitiveParams; {Only used when IsInputDataArea true}
213      property Count: integer read GetCount;
214      property Column[index: integer]: TSQLVarData read GetColumn;
215      property UniqueRelationName: AnsiString read FUniqueRelationName;
# Line 429 | Line 421 | type
421      function getSQLParam(index: integer): ISQLParam;
422      function ByName(Idx: AnsiString): ISQLParam ;
423      function GetModified: Boolean;
424 +    function GetHasCaseSensitiveParams: Boolean;
425    end;
426  
427    { TResults }
# Line 456 | Line 449 | type
449  
450   implementation
451  
452 < uses FBMessages, FBClientAPI, variants, IBUtils, FBTransaction;
460 <
452 > uses FBMessages, variants, IBUtils, FBTransaction, DateUtils;
453  
454   { TSQLDataArea }
455  
# Line 510 | Line 502 | end;
502  
503   procedure TSQLDataArea.PreprocessSQL(sSQL: AnsiString; GenerateParamNames: boolean;
504    var sProcessedSQL: AnsiString);
513 var
514  cCurChar, cNextChar, cQuoteChar: AnsiChar;
515  sParamName: AnsiString;
516  j, i, iLenSQL, iSQLPos: Integer;
517  iCurState {$ifdef ALLOWDIALECT3PARAMNAMES}, iCurParamState {$endif}: Integer;
518  iParamSuffix: Integer;
519  slNames: TStrings;
520  StrBuffer: PByte;
521  found: boolean;
522
523 const
524  DefaultState = 0;
525  CommentState = 1;
526  QuoteState = 2;
527  ParamState = 3;
528  ArrayDimState = 4;
529 {$ifdef ALLOWDIALECT3PARAMNAMES}
530  ParamDefaultState = 0;
531  ParamQuoteState = 1;
532  {$endif}
505  
506 <  procedure AddToProcessedSQL(cChar: AnsiChar);
535 <  begin
536 <    StrBuffer[iSQLPos] := byte(cChar);
537 <    Inc(iSQLPos);
538 <  end;
539 <
540 < begin
541 <  if not IsInputDataArea then
542 <    IBError(ibxeNotPermitted,[nil]);
543 <
544 <  sParamName := '';
545 <  iLenSQL := Length(sSQL);
546 <  GetMem(StrBuffer,iLenSQL + 1);
547 <  slNames := TStringList.Create;
548 <  try
549 <    { Do some initializations of variables }
550 <    iParamSuffix := 0;
551 <    cQuoteChar := '''';
552 <    i := 1;
553 <    iSQLPos := 0;
554 <    iCurState := DefaultState;
555 <    {$ifdef ALLOWDIALECT3PARAMNAMES}
556 <    iCurParamState := ParamDefaultState;
557 <    {$endif}
558 <    { Now, traverse through the SQL string, character by character,
559 <     picking out the parameters and formatting correctly for InterBase }
560 <    while (i <= iLenSQL) do begin
561 <      { Get the current token and a look-ahead }
562 <      cCurChar := sSQL[i];
563 <      if i = iLenSQL then
564 <        cNextChar := #0
565 <      else
566 <        cNextChar := sSQL[i + 1];
567 <      { Now act based on the current state }
568 <      case iCurState of
569 <        DefaultState:
570 <        begin
571 <          case cCurChar of
572 <            '''', '"':
573 <            begin
574 <              cQuoteChar := cCurChar;
575 <              iCurState := QuoteState;
576 <            end;
577 <            '?', ':':
578 <            begin
579 <              iCurState := ParamState;
580 <              AddToProcessedSQL('?');
581 <            end;
582 <            '/': if (cNextChar = '*') then
583 <            begin
584 <              AddToProcessedSQL(cCurChar);
585 <              Inc(i);
586 <              iCurState := CommentState;
587 <            end;
588 <            '[':
589 <            begin
590 <              AddToProcessedSQL(cCurChar);
591 <              Inc(i);
592 <              iCurState := ArrayDimState;
593 <            end;
594 <          end;
595 <        end;
596 <
597 <        ArrayDimState:
598 <        begin
599 <          case cCurChar of
600 <          ':',',','0'..'9',' ',#9,#10,#13:
601 <            begin
602 <              AddToProcessedSQL(cCurChar);
603 <              Inc(i);
604 <            end;
605 <          else
606 <            begin
607 <              AddToProcessedSQL(cCurChar);
608 <              Inc(i);
609 <              iCurState := DefaultState;
610 <            end;
611 <          end;
612 <        end;
506 > var slNames: TStrings;
507  
508 <        CommentState:
509 <        begin
510 <          if (cNextChar = #0) then
511 <            IBError(ibxeSQLParseError, [SEOFInComment])
512 <          else if (cCurChar = '*') then begin
619 <            if (cNextChar = '/') then
620 <              iCurState := DefaultState;
621 <          end;
622 <        end;
623 <        QuoteState: begin
624 <          if cNextChar = #0 then
625 <            IBError(ibxeSQLParseError, [SEOFInString])
626 <          else if (cCurChar = cQuoteChar) then begin
627 <            if (cNextChar = cQuoteChar) then begin
628 <              AddToProcessedSQL(cCurChar);
629 <              Inc(i);
630 <            end else
631 <              iCurState := DefaultState;
632 <          end;
633 <        end;
634 <        ParamState:
635 <        begin
636 <          { collect the name of the parameter }
637 <          {$ifdef ALLOWDIALECT3PARAMNAMES}
638 <          if iCurParamState = ParamDefaultState then
639 <          begin
640 <            if cCurChar = '"' then
641 <              iCurParamState := ParamQuoteState
642 <            else
643 <            {$endif}
644 <            if (cCurChar in ['A'..'Z', 'a'..'z', '0'..'9', '_', '$']) then
645 <                sParamName := sParamName + cCurChar
646 <            else if GenerateParamNames then
647 <            begin
648 <              sParamName := 'IBXParam' + IntToStr(iParamSuffix); {do not localize}
649 <              Inc(iParamSuffix);
650 <              iCurState := DefaultState;
651 <              slNames.AddObject(sParamName,self); //Note local convention
652 <                                                  //add pointer to self to mark entry
653 <              sParamName := '';
654 <            end
655 <            else
656 <              IBError(ibxeSQLParseError, [SParamNameExpected]);
657 <          {$ifdef ALLOWDIALECT3PARAMNAMES}
658 <          end
659 <          else begin
660 <            { determine if Quoted parameter name is finished }
661 <            if cCurChar = '"' then
662 <            begin
663 <              Inc(i);
664 <              slNames.Add(sParamName);
665 <              SParamName := '';
666 <              iCurParamState := ParamDefaultState;
667 <              iCurState := DefaultState;
668 <            end
669 <            else
670 <              sParamName := sParamName + cCurChar
671 <          end;
672 <          {$endif}
673 <          { determine if the unquoted parameter name is finished }
674 <          if {$ifdef ALLOWDIALECT3PARAMNAMES}(iCurParamState <> ParamQuoteState) and {$endif}
675 <            (iCurState <> DefaultState) then
676 <          begin
677 <            if not (cNextChar in ['A'..'Z', 'a'..'z',
678 <                                  '0'..'9', '_', '$']) then begin
679 <              Inc(i);
680 <              iCurState := DefaultState;
681 <              slNames.Add(sParamName);
682 <              sParamName := '';
683 <            end;
684 <          end;
685 <        end;
686 <      end;
687 <      if (iCurState <> ParamState) and (i <= iLenSQL) then
688 <        AddToProcessedSQL(sSQL[i]);
689 <      Inc(i);
690 <    end;
691 <    AddToProcessedSQL(#0);
692 <    sProcessedSQL := strpas(PAnsiChar(StrBuffer));
508 >  procedure SetColumnNames(slNames: TStrings);
509 >  var i, j: integer;
510 >      found: boolean;
511 >  begin
512 >    found := false;
513      SetCount(slNames.Count);
514      for i := 0 to slNames.Count - 1 do
515      begin
# Line 710 | Line 530 | begin
530          Column[i].UniqueName := not found;
531        end;
532      end;
533 +  end;
534 +
535 + begin
536 +  if not IsInputDataArea then
537 +    IBError(ibxeNotPermitted,[nil]);
538 +
539 +  slNames := TStringList.Create;
540 +  try
541 +    sProcessedSQL := TSQLParamProcessor.Execute(sSQL,GenerateParamNames,slNames);
542 +    SetColumnNames(slNames);
543    finally
544      slNames.Free;
715    FreeMem(StrBuffer);
545    end;
546   end;
547  
# Line 726 | Line 555 | var
555    s: AnsiString;
556    i: Integer;
557   begin
558 <  {$ifdef UseCaseInSensitiveParamName}
559 <   s := AnsiUpperCase(Idx);
560 <  {$else}
558 >  if not IsInputDataArea or not CaseSensitiveParams then
559 >   s := AnsiUpperCase(Idx)
560 >  else
561     s := Idx;
562 <  {$endif}
562 >
563    for i := 0 to Count - 1 do
564      if Column[i].Name = s then
565      begin
# Line 762 | Line 591 | end;
591  
592   procedure TSQLVarData.SetName(AValue: AnsiString);
593   begin
594 <  if FName = AValue then Exit;
766 <  {$ifdef UseCaseInSensitiveParamName}
767 <  if Parent.IsInputDataArea then
594 >  if not Parent.IsInputDataArea or not Parent.CaseSensitiveParams then
595      FName := AnsiUpperCase(AValue)
596    else
770  {$endif}
597      FName := AValue;
598   end;
599  
# Line 788 | Line 614 | begin
614  
615    FVarString := aValue;
616    SQLType := SQL_TEXT;
617 +  Scale := 0;
618    SetSQLData(PByte(PAnsiChar(FVarString)),Length(aValue));
619   end;
620  
# Line 948 | Line 775 | begin
775        result := Value;
776   end;
777  
778 + function TSQLDataItem.GetDateFormatStr(IncludeTime: boolean): AnsiString;
779 + begin
780 +  {$IF declared(DefaultFormatSettings)}
781 +  with DefaultFormatSettings do
782 +  {$ELSE}
783 +  {$IF declared(FormatSettings)}
784 +  with FormatSettings do
785 +  {$IFEND}
786 +  {$IFEND}
787 +  case GetSQLDialect of
788 +    1:
789 +      if IncludeTime then
790 +        result := ShortDateFormat + ' ' + LongTimeFormat
791 +      else
792 +        result := ShortDateFormat;
793 +    3:
794 +      result := ShortDateFormat;
795 +  end;
796 + end;
797 +
798 + function TSQLDataItem.GetTimeFormatStr: AnsiString;
799 + begin
800 +  {$IF declared(DefaultFormatSettings)}
801 +  with DefaultFormatSettings do
802 +  {$ELSE}
803 +  {$IF declared(FormatSettings)}
804 +  with FormatSettings do
805 +  {$IFEND}
806 +  {$IFEND}
807 +    Result := LongTimeFormat;
808 + end;
809 +
810 + function TSQLDataItem.GetTimestampFormatStr: AnsiString;
811 + begin
812 +  {$IF declared(DefaultFormatSettings)}
813 +  with DefaultFormatSettings do
814 +  {$ELSE}
815 +  {$IF declared(FormatSettings)}
816 +  with FormatSettings do
817 +  {$IFEND}
818 +  {$IFEND}
819 +    Result := ShortDateFormat + ' ' +  LongTimeFormat + '.zzz';
820 + end;
821 +
822   procedure TSQLDataItem.SetAsInteger(AValue: Integer);
823   begin
824    SetAsLong(aValue);
# Line 1046 | Line 917 | begin
917     //Do nothing by default
918   end;
919  
920 + constructor TSQLDataItem.Create(api: TFBClientAPI);
921 + begin
922 +  inherited Create;
923 +  FFirebirdClientAPI := api;
924 + end;
925 +
926   function TSQLDataItem.GetSQLTypeName: AnsiString;
927   begin
928    Result := GetSQLTypeName(GetSQLType);
# Line 1152 | Line 1029 | begin
1029    CheckActive;
1030    result := 0;
1031    if not IsNull then
1032 <    with FirebirdClientAPI do
1032 >    with FFirebirdClientAPI do
1033      case SQLType of
1034        SQL_TEXT, SQL_VARYING: begin
1035          try
# Line 1292 | Line 1169 | begin
1169    result := '';
1170    { Check null, if so return a default string }
1171    if not IsNull then
1172 <  with FirebirdClientAPI do
1172 >  with FFirebirdClientAPI do
1173      case SQLType of
1174        SQL_BOOLEAN:
1175          if AsBoolean then
# Line 1317 | Line 1194 | begin
1194            Result := rs
1195        end;
1196        SQL_TYPE_DATE:
1197 <        case GetSQLDialect of
1321 <          1 : result := DateTimeToStr(AsDateTime);
1322 <          3 : result := DateToStr(AsDateTime);
1323 <        end;
1197 >        result := FormatDateTime(GetDateFormatStr(TimeOf(AsDateTime)<>0),AsDateTime);
1198        SQL_TYPE_TIME :
1199 <        result := TimeToStr(AsDateTime);
1199 >        result := FormatDateTime(GetTimeFormatStr,AsDateTime);
1200        SQL_TIMESTAMP:
1201 <      {$IF declared(DefaultFormatSettings)}
1328 <      with DefaultFormatSettings do
1329 <      {$ELSE}
1330 <      {$IF declared(FormatSettings)}
1331 <      with FormatSettings do
1332 <      {$IFEND}
1333 <      {$IFEND}
1334 <        result := FormatDateTime(ShortDateFormat + ' ' +
1335 <                            LongTimeFormat+'.zzz',AsDateTime);
1201 >        result := FormatDateTime(GetTimestampFormatStr,AsDateTime);
1202        SQL_SHORT, SQL_LONG:
1203          if Scale = 0 then
1204            result := IntToStr(AsLong)
# Line 1360 | Line 1226 | begin
1226    Result := false;
1227   end;
1228  
1229 < function TSQLDataItem.getIsNullable: boolean;
1229 > function TSQLDataItem.GetIsNullable: boolean;
1230   begin
1231    CheckActive;
1232    Result := false;
# Line 1408 | Line 1274 | begin
1274    Result := false;
1275   end;
1276  
1277 + function TSQLDataItem.GetDateTimeStrLength(DateTimeFormat: TIBDateTimeFormats
1278 +  ): integer;
1279 + begin
1280 +  case DateTimeFormat of
1281 +  dfTimestamp:
1282 +    Result := Length(GetTimestampFormatStr);
1283 +  dfDateTime:
1284 +    Result := Length(GetDateFormatStr(true));
1285 +  dfTime:
1286 +    Result := Length(GetTimeFormatStr);
1287 +  else
1288 +    Result := 0;
1289 +  end;
1290 + end;
1291 +
1292  
1293   procedure TSQLDataItem.SetIsNull(Value: Boolean);
1294   begin
# Line 1471 | Line 1352 | begin
1352  
1353    SQLType := SQL_TYPE_DATE;
1354    DataLength := SizeOf(ISC_DATE);
1355 <  with FirebirdClientAPI do
1355 >  with FFirebirdClientAPI do
1356      SQLEncodeDate(Value,SQLData);
1357    Changed;
1358   end;
# Line 1491 | Line 1372 | begin
1372  
1373    SQLType := SQL_TYPE_TIME;
1374    DataLength := SizeOf(ISC_TIME);
1375 <  with FirebirdClientAPI do
1375 >  with FFirebirdClientAPI do
1376      SQLEncodeTime(Value,SQLData);
1377    Changed;
1378   end;
# Line 1505 | Line 1386 | begin
1386    Changing;
1387    SQLType := SQL_TIMESTAMP;
1388    DataLength := SizeOf(ISC_TIME) + sizeof(ISC_DATE);
1389 <  with FirebirdClientAPI do
1389 >  with FFirebirdClientAPI do
1390      SQLEncodeDateTime(Value,SQLData);
1391    Changed;
1392   end;
# Line 1691 | Line 1572 | end;
1572  
1573   constructor TColumnMetaData.Create(aOwner: IUnknown; aIBXSQLVAR: TSQLVarData);
1574   begin
1575 <  inherited Create;
1575 >  inherited Create(aIBXSQLVAR.GetStatement.GetAttachment.getFirebirdAPI as TFBClientAPI);
1576    FIBXSQLVAR := aIBXSQLVAR;
1577    FOwner := aOwner;
1578    FPrepareSeqNo := FIBXSQLVAR.Parent.PrepareSeqNo;
# Line 1855 | Line 1736 | end;
1736   { TSQLParam }
1737  
1738   procedure TSQLParam.InternalSetAsString(Value: AnsiString);
1739 +
1740 + procedure DoSetString;
1741 + begin
1742 +  Changing;
1743 +  FIBXSQLVar.SetString(Transliterate(Value,GetCodePage));
1744 +  Changed;
1745 + end;
1746 +
1747   var b: IBlob;
1748      dt: TDateTime;
1749 +    CurrValue: Currency;
1750 +    FloatValue: single;
1751   begin
1752    CheckActive;
1753    if IsNullable then
# Line 1882 | Line 1773 | begin
1773  
1774    SQL_VARYING,
1775    SQL_TEXT:
1776 <    begin
1886 <      Changing;
1887 <      FIBXSQLVar.SetString(Transliterate(Value,GetCodePage));
1888 <      Changed;
1889 <    end;
1776 >    DoSetString;
1777  
1778      SQL_SHORT,
1779      SQL_LONG,
1780      SQL_INT64:
1781 <      SetAsNumeric(AdjustScaleFromCurrency(StrToCurr(Value),GetScale),GetScale);
1781 >      if TryStrToCurr(Value,CurrValue) then
1782 >        SetAsNumeric(AdjustScaleFromCurrency(CurrValue,GetScale),GetScale)
1783 >      else
1784 >        DoSetString;
1785  
1786      SQL_D_FLOAT,
1787      SQL_DOUBLE,
1788      SQL_FLOAT:
1789 <      SetAsDouble(StrToFloat(Value));
1789 >      if TryStrToFloat(Value,FloatValue) then
1790 >        SetAsDouble(FloatValue)
1791 >      else
1792 >        DoSetString;
1793  
1794      SQL_TIMESTAMP:
1795        if TryStrToDateTime(Value,dt) then
1796          SetAsDateTime(dt)
1797        else
1798 <        FIBXSQLVar.SetString(Value);
1798 >        DoSetString;
1799  
1800      SQL_TYPE_DATE:
1801        if TryStrToDateTime(Value,dt) then
1802          SetAsDate(dt)
1803        else
1804 <        FIBXSQLVar.SetString(Value);
1804 >        DoSetString;
1805  
1806      SQL_TYPE_TIME:
1807        if TryStrToDateTime(Value,dt) then
1808          SetAsTime(dt)
1809        else
1810 <        FIBXSQLVar.SetString(Value);
1810 >        DoSetString;
1811  
1812      else
1813        IBError(ibxeInvalidDataConversion,[nil]);
# Line 2500 | Line 2393 | begin
2393      end;
2394   end;
2395  
2396 + function TSQLParams.GetHasCaseSensitiveParams: Boolean;
2397 + begin
2398 +  Result := FSQLParams.CaseSensitiveParams;
2399 + end;
2400 +
2401   { TResults }
2402  
2403   procedure TResults.CheckActive;

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines