dbparsers.pas

FIBPlus version 6-96. This is somewhat usefull interbase database components. TFIBDatabase, TFIBTab

{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ InterBase databases                                           }
{                                                               }
{    FIBPlus is based in part on the product                    }
{    Free IB Components, written by Gregory H. Deatz for        }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.            }
{    mailto:[e-mail]                                    }
{                                                               }
{    Copyright (c) 1998-2007 Devrace Ltd.                       }
{    Written by Serge Buzadzhy ([e-mail])               }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page: http://www.fibplus.com/                 }
{    FIBPlus support  : http://www.devrace.com/support/         }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}
unit DBParsers;

interface
{$I FIBPlus.inc}
 uses SysUtils,Classes,DB,DBCommon,DbConsts
  {$IFNDEF LINUX}  ,Windows  {$ENDIF}
  {$IFDEF D6+}  ,Variants,FMTBcd{$ENDIF}
 ;

 type

  TStrToDateFmt = function (const ADate,Fmt:string):TDateTime;
  TMatchesMask  = function (const S1, Mask: string): Boolean;

  TExpressionParser = class(TExprParser)
  private
    FExpressionText  :string;
    FDataSet:TDataSet;
    FStrToDateFmt    :TStrToDateFmt;
    FMatchesMask     :TMatchesMask;
    FFilteredFields  :TStringList;
    function  FieldByName(const FieldName:string):TField;
    function  VarResult :Boolean;
  public
    constructor Create(DataSet: TDataSet; const Text: string;
      Options: TFilterOptions; ParserOptions: TParserOptions;
      const FieldName: string; DepFields: TBits; FieldMap: TFieldMap;
     aStrToDateFmt:TStrToDateFmt=nil;
     aMatchesMask :TMatchesMask=nil
    );
    destructor Destroy; override;
    procedure ResetFields;
    function  BooleanResult: Boolean;
    property  StrToDateFmt:TStrToDateFmt read FStrToDateFmt write FStrToDateFmt;
    property  MatchesMask :TMatchesMask read FMatchesMask write FMatchesMask;
    property  ExpressionText :string read FExpressionText;
  end;



implementation

{ TExpressionParser}
 uses StrUtil {$IFDEF D6+} ,StdFuncs {$ENDIF};


constructor TExpressionParser.Create(DataSet: TDataSet; const Text: string;
  Options: TFilterOptions; ParserOptions: TParserOptions;
  const FieldName: string; DepFields: TBits; FieldMap: TFieldMap;
  aStrToDateFmt:TStrToDateFmt=nil;
  aMatchesMask :TMatchesMask=nil
);
begin
 try
  inherited Create(DataSet,Text,  Options,ParserOptions,  FieldName,DepFields,FieldMap);
 except
  on e: Exception do
  begin
    e.Message:='Can''t parse Filter for: '#13#10+e.Message;
    raise;
  end;
 end;
 FExpressionText  :=Text; 
 FDataSet:=DataSet;
 FStrToDateFmt:=aStrToDateFmt;
 FMatchesMask :=aMatchesMask;
 FFilteredFields  :=TStringList.Create;
 with FFilteredFields do
 begin
   Sorted:=true;
   Duplicates:=dupIgnore
 end;    // with
end;

destructor TExpressionParser.Destroy;
begin
  FFilteredFields.Free;
  inherited;
end;


function  TExpressionParser.FieldByName(const FieldName:string):TField;
var
 i:integer;
begin
 if FFilteredFields.Find(FieldName,i) then
  Result:=TField(FFilteredFields.Objects[i])
 else
 begin
  Result:=FDataSet.FieldByName(FieldName);
  FFilteredFields.AddObject(FieldName,Result)
 end;
end;

{$WARNINGS OFF}
function  TExpressionParser.VarResult :Boolean;
var
  iLiteralStart: Word;
  
  function ParseNode(pfdStart, pfd: PAnsiChar): Variant;
  var
    I, Z,AD: Integer;
    Year, Mon, Day, Hour, Min, Sec, MSec: Word;
    iClass: NODEClass;
    iOperator: TCANOperator;
    pArg1,pArg2: PAnsiChar;
    Arg1,Arg2: Variant;
    FieldName: String;
    DataType: TFieldType;
    DataOfs: integer;
    ts: TTimeStamp;
    Cur: Currency;
    PartLength: Word;
    IgnoreCase: Word;
    S1,S2: Variant;
    S :string;
    null1,null2:boolean;
    p,p1:integer;
  type
    PWordBool = ^WordBool;
  begin
    iClass := NODEClass(PInteger(@pfd[0])^);
    iOperator := TCANOperator(PInteger(@pfd[4])^);
    Inc(pfd, CANHDRSIZE);

    case iClass of
      nodeFIELD:
        case iOperator of
          coFIELD2:
            begin
              DataOfs := iLiteralStart + PWord(@pfd[2])^;
              pArg1 := pfdStart;
              Inc(pArg1, DataOfs);
              FieldName := string(pArg1);
              with FieldByName(FieldName) do
               {$IFNDEF D6+}
                   Result := FieldByName(FieldName).Value               
               {$ELSE}
                 case DataType of
                  ftBCD:
                   if IsNull then
                    Result:=Null
                   else
                    Result:=FieldByName(FieldName).Value
                 else
                   Result := FieldByName(FieldName).Value
                 end
               {$ENDIF}
            end;
        else
            DatabaseError(SExprIncorrect);
        end;
      nodeCONST:
        case iOperator of
          coCONST2:
            begin
              DataType := TFieldType(PWord(@pfd[0])^);
              DataOfs := iLiteralStart + PWord(@pfd[4])^;
              pArg1 := pfdStart;
              Inc(pArg1, DataOfs);
              case DataType of
                ftSmallInt, ftWord:
                  Result := PWord(pArg1)^;
                ftInteger, ftAutoInc:
                  Result := PInteger(pArg1)^;
                ftFloat, ftCurrency:
                  Result := PDouble(pArg1)^;
                ftString, ftFixedChar:
                  Result := string(pArg1);
                ftDate:
                  begin
                    ts.Date := PInteger(pArg1)^;
                    ts.Time := 0;
                   {$IFDEF D6+}
                    Result := HookTimeStampToDateTime(ts);
                   {$ELSE}
                    Result := TimeStampToDateTime(ts);
                   {$ENDIF}
                  end;
                ftTime:
                  begin
                    ts.Date := 0;
                    ts.Time := PInteger(pArg1)^;;
                   {$IFDEF D6+}
                    Result := HookTimeStampToDateTime(ts);
                   {$ELSE}
                    Result := TimeStampToDateTime(ts);
                   {$ENDIF}
                  end;
                ftDateTime:
                begin
                  ts  :=MSecsToTimeStamp(PDouble(pArg1)^);
                 {$IFDEF D6+}
                    Result := HookTimeStampToDateTime(ts);
                 {$ELSE}
                    Result := TimeStampToDateTime(ts);
                 {$ENDIF}
                end;
                ftBoolean:
                  Result := PWordBool(pArg1)^;
                ftBCD:
                  begin
                    BCDToCurr(PBCD(pArg1)^, Cur);
                    Result := Cur;
                  end;
                {$IFDEF D6+}
                ftLargeInt:
                  Result := PInt64(pArg1)^;
                {$ENDIF}  
              else
                  DatabaseError(SExprIncorrect);
              end;
            end;
        end;
      nodeUNARY:
        begin
          pArg1 := pfdStart;
          Inc(pArg1, CANEXPRSIZE + PWord(@pfd[0])^);

          case iOperator of
            coISBLANK,coNOTBLANK:
              begin
                Arg1 := ParseNode(pfdStart, pArg1);
                Result := VarIsEmpty(Arg1) or VarIsNull(Arg1);
                if iOperator = coNOTBLANK then
                  Result := not Result;
              end;
            coNOT:
              Result := not WordBool(ParseNode(pfdStart, pArg1));
            coMINUS:
              Result := - ParseNode(pfdStart, pArg1);
            coUPPER:
              Result := AnsiUpperCase(VarToStr(ParseNode(pfdStart, pArg1)));
            coLOWER:
              Result := AnsiLowerCase(VarToStr(ParseNode(pfdStart, pArg1)));
          end;
        end;
      nodeBINARY:
        begin
          pArg1 := pfdStart;
          Inc(pArg1, CANEXPRSIZE + PWord(@pfd[0])^);
          pArg2 := pfdStart;
          Inc(pArg2, CANEXPRSIZE + PWord(@pfd[2])^);
          case iOperator of
            coAssign:Result := ParseNode(pfdStart, pArg1) ;
            coEQ:
              Result := ParseNode(pfdStart, pArg1) = ParseNode(pfdStart, pArg2);
            coNE:
              Result := ParseNode(pfdStart, pArg1) <> ParseNode(pfdStart, pArg2);
            coGT:
              Result := ParseNode(pfdStart, pArg1) > ParseNode(pfdStart, pArg2);
            coGE:
              Result := ParseNode(pfdStart, pArg1) >= ParseNode(pfdStart, pArg2);
            coLT:
              Result := ParseNode(pfdStart, pArg1) < ParseNode(pfdStart, pArg2);
            coLE:
              Result := ParseNode(pfdStart, pArg1) <= ParseNode(pfdStart, pArg2);
            coOR:
              Result := WordBool(ParseNode(pfdStart, pArg1)) or WordBool(ParseNode(pfdStart, pArg2));