{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1995-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.DBCommon;

{$T-,H+,X+,R-}

interface

uses Variants, Classes, DB, SqlTimSt, StrUtils;

type
  TCANOperator = (
    coNOTDEFINED,                      {                                   }
    coISBLANK,                         { coUnary;  is operand blank.      }
    coNOTBLANK,                        { coUnary;  is operand not blank.  }
    coEQ,                              { coBinary, coCompare; equal.     }
    coNE,                              { coBinary; NOT equal.             }
    coGT,                              { coBinary; greater than.          }
    coLT,                              { coBinary; less than.             }
    coGE,                              { coBinary; greater or equal.      }
    coLE,                              { coBinary; less or equal.         }
    coNOT,                             { coUnary; NOT                     }
    coAND,                             { coBinary; AND                    }
    coOR,                              { coBinary; OR                     }
    coTUPLE2,                          { coUnary; Entire record is operand. }
    coFIELD2,                          { coUnary; operand is field        }
    coCONST2,                          { coUnary; operand is constant     }
    coMINUS,                           { coUnary;  minus. }
    coADD,                             { coBinary; addition. }
    coSUB,                             { coBinary; subtraction. }
    coMUL,                             { coBinary; multiplication. }
    coDIV,                             { coBinary; division. }
    coMOD,                             { coBinary; modulo division. }
    coREM,                             { coBinary; remainder of division. }
    coSUM,                             { coBinary, accumulate sum of. }
    coCOUNT,                           { coBinary, accumulate count of. }
    coMIN,                             { coBinary, find minimum of. }
    coMAX,                             { coBinary, find maximum of. }
    coAVG,                             { coBinary, find average of. }
    coCONT,                            { coBinary; provides a link between two }
    coUDF2,                            { coBinary; invokes a User defined fn }
    coCONTINUE2,                       { coUnary; Stops evaluating records }
    coLIKE,                            { coCompare, extended binary compare        }
    coIN,                              { coBinary field in list of values }
    coLIST2,                           { List of constant values of same type }
    coUPPER,                           { coUnary: upper case }
    coLOWER,                           { coUnary: lower case }
    coFUNC2,                           { coFunc: Function }
    coLISTELEM2,                       { coListElem: List Element }
    coASSIGN                           { coBinary: Field assignment }
  );

  NODEClass = (                         { Node Class }
    nodeNULL,                           { Null node                   }
    nodeUNARY,                          { Node is a unary             }
    nodeBINARY,                         { Node is a binary            }
    nodeCOMPARE,                        { Node is a compare           }
    nodeFIELD,                          { Node is a field             }
    nodeCONST,                          { Node is a constant          }
    nodeTUPLE,                          { Node is a record }
    nodeCONTINUE,                       { Node is a continue node     }
    nodeUDF,                            { Node is a UDF node }
    nodeLIST,                           { Node is a LIST node }
    nodeFUNC,                           { Node is a Function node }
    nodeLISTELEM                        { Node is a List Element node }
  );

const
  CANEXPRSIZE        = 10; { SizeOf(CANExpr) }
  CANHDRSIZE         = 8;  { SizeOf(CANHdr) }
  CANEXPRVERSION     = 2;


type
  TExprData = array of Byte;
  TFieldMap = array[TFieldType] of Byte;

{ TFilterExpr }

type

  TParserOption = (poExtSyntax, poAggregate, poDefaultExpr, poUseOrigNames,
                   poFieldNameGiven, poFieldDepend);
  TParserOptions = set of TParserOption;

  TExprNodeKind = (enField, enConst, enOperator, enFunc);
  TExprScopeKind = (skField, skAgg, skConst);

//  PExprNode = ^TExprNode;
  TExprNode = class
  public
    FNext: TExprNode;
    FKind: TExprNodeKind;
    FPartial: Boolean;
    FOperator: TCANOperator;
    FData: Variant;
    FLeft: TExprNode;
    FRight: TExprNode;
    FDataType: TFieldType;
    FDataSize: Integer;
    FArgs: TList;
    FScopeKind: TExprScopeKind;
  end;

  TFilterExpr = class
  private
    FDataSet: TDataSet;
    FFieldMap: TFieldMap;
    FOptions: TFilterOptions;
    FParserOptions: TParserOptions;
    FNodes: TExprNode;
    FExprBuffer: TExprData;
    FExprBufSize: Integer;
    FExprNodeSize: Integer;
    FExprDataSize: Integer;
    FFieldName: string;
    FDependentFields: TBits;
    procedure WriteBufBytes(var Pos: Integer; Data: TBytes);
    function FieldFromNode(Node: TExprNode): TField;
    function GetExprData(Pos, Size: Integer): Integer;
    function PutConstBCD(const Value: Variant; Decimals: Integer): Integer;
    function PutConstFMTBCD(const Value: Variant; Decimals: Integer): Integer;
    function PutConstBool(const Value: Variant): Integer;
    function PutConstDate(const Value: Variant): Integer;
    function PutConstDateTime(const Value: Variant): Integer;
    function PutConstSQLTimeStamp(const Value: Variant): Integer;
    function PutConstFloat(const Value: Variant): Integer;
    function PutConstInt(DataType: TFieldType; const Value: Variant): Integer;
    function PutConstNode(DataType: TFieldType; Data: TBytes;
      Size: Integer): Integer;
    function PutConstStr(const Value: string): Integer;
    function PutConstTime(const Value: Variant): Integer;
    function PutData(Data: TBytes; Size: Integer): Integer;
    function PutExprNode(Node: TExprNode; ParentOp: TCANOperator): Integer;
    function PutFieldNode(Field: TField; Node: TExprNode): Integer;
    function PutNode(NodeType: NodeClass; OpType: TCANOperator;
      OpCount: Integer): Integer;
    procedure SetNodeOp(Node, Index, Data: Integer);
    function PutConstant(Node: TExprNode): Integer;
    function GetFieldByName(Name: string) : TField;
  public
    constructor Create(DataSet: TDataSet; Options: TFilterOptions;
      ParseOptions: TParserOptions; const FieldName: string; DepFields: TBits;
      FieldMap: TFieldMap);
    destructor Destroy; override;
    function NewCompareNode(Field: TField; Operator: TCANOperator;
      const Value: Variant): TExprNode;
    function NewNode(Kind: TExprNodeKind; Operator: TCANOperator;
      const Data: Variant; Left, Right: TExprNode): TExprNode;
    function GetFilterData(Root: TExprNode): TExprData;
    property DataSet: TDataSet write FDataSet;
  end;

{ TExprParser }

  TExprToken = (etEnd, etSymbol, etName, etLiteral,  etLParen, etRParen,
    etEQ, etNE, etGE, etLE, etGT, etLT, etADD, etSUB, etMUL, etDIV,
    etComma, etLIKE, etISNULL, etISNOTNULL, etIN);

  TExprParser = class
  private
    FDecimalSeparator: string;
    FFilter: TFilterExpr;
    FFieldMap: TFieldMap;
    FText: string;
    FSourcePtr: Integer;
    FTokenPtr: Integer;
    FTokenString: string;
    FStrTrue: string;
    FStrFalse: string;
    FToken: TExprToken;
    FPrevToken: TExprToken;
    FFilterData: TExprData;
    FNumericLit: Boolean;
    FDataSize: Integer;
    FParserOptions: TParserOptions;
    FFieldName: string;
    FDataSet: TDataSet;
    FDependentFields: TBits;
    procedure NextToken;
    function NextTokenIsLParen : Boolean;
    function ParseExpr: TExprNode;
    function ParseExpr2: TExprNode;
    function ParseExpr3: TExprNode;
    function ParseExpr4: TExprNode;
    function ParseExpr5: TExprNode;
    function ParseExpr6: TExprNode;
    function ParseExpr7: TExprNode;
    function TokenName: string;
    function TokenSymbolIs(const S: string): Boolean;
    function TokenSymbolIsFunc(const S: string) : Boolean;
    procedure GetFuncResultInfo(Node: TExprNode);
    procedure TypeCheckArithOp(Node: TExprNode);
    procedure GetScopeKind(Root, Left, Right : TExprNode);
  public
    constructor Create(DataSet: TDataSet; const Text: string;
      Options: TFilterOptions; ParserOptions: TParserOptions;
      const FieldName: string; DepFields: TBits; FieldMap: TFieldMap);
    destructor Destroy; override;
    procedure SetExprParams(const Text: string; Options: TFilterOptions;
      ParserOptions: TParserOptions; const FieldName: string);
    property FilterData: TExprData read FFilterData;
    property DataSize: Integer read FDataSize;
  end;

{ Field Origin parser }

type
  TFieldInfo = record
    DatabaseName: string;
    TableName: string;
    OriginalFieldName: string;
  end;

function GetFieldInfo(const Origin: string; var FieldInfo: TFieldInfo): Boolean;

{ SQL Parser }

type
  TSQLToken = (stUnknown, stTableName, stFieldName, stAscending, stDescending, stSelect,
    stFrom, stWhere, stGroupBy, stHaving, stUnion, stPlan, stOrderBy, stForUpdate,
    stEnd, stPredicate, stValue, stIsNull, stIsNotNull, stLike, stAnd, stOr,
    stNumber, stAllFields, stComment, stDistinct);

const
  SQLSections = [stSelect, stFrom, stWhere, stGroupBy, stHaving, stUnion,
    stPlan, stOrderBy, stForUpdate];

function NextSQLToken(const SQL: string; var p: Integer; out Token: string; CurSection: TSQLToken): TSQLToken;
function GetIndexForOrderBy(const SQL: string; DataSet: TDataSet): TIndexDef;
function GetTableNameFromSQL(const SQL: string): string;
function GetTableNameFromQuery(const SQL: string): string;
function AddParamSQLForDetail(Params: TParams; SQL: string; Native: Boolean; QuoteChar: string = ''): string;
function IsMultiTableQuery(const SQL: string): Boolean;
procedure CopyBuffer(Source, Dest: IntPtr; Len: Cardinal);
procedure InitializeBuffer(Buffer: IntPtr; Size: Integer; Value: Byte);

implementation

uses SysUtils, FMTBcd, DBConsts, System.Runtime.InteropServices;

{ SQL Parser }

function NextSQLToken(const SQL: string; var p: Integer; out Token: string; CurSection: TSQLToken): TSQLToken;
var
  DotStart: Boolean;

  function NextTokenIs(Value: string; var Str: string): Boolean;
  var
    Tmp: Integer;
    S: string;
  begin
    Tmp := p;
    NextSQLToken(SQL, Tmp, S, CurSection);
    Result := CompareText(Value, S) = 0;
    if Result then
    begin
      Str := Str + ' ' + S;
      p := Tmp;
    end;
  end;

  function GetSQLToken(var Str: string): TSQLToken;
  var
    l: Integer;
    s: string;
  begin
    if Length(Str) = 0 then
      Result := stEnd else
    if (Str = '*') and (CurSection = stSelect) then
      Result := stAllFields else
    if DotStart then
      Result := stFieldName else
    if (CompareText('DISTINCT', Str) = 0) and (CurSection = stSelect) then
      Result := stDistinct else
    if (CompareText('ASC', Str) = 0) or (CompareText('ASCENDING', Str) = 0) then
      Result := stAscending else
    if (CompareText('DESC', Str) = 0) or (CompareText('DESCENDING', Str) = 0)then
      Result := stDescending else
    if CompareText('SELECT', Str) = 0 then
      Result := stSelect else
    if CompareText('AND', Str) = 0 then
      Result := stAnd else
    if CompareText('OR', Str) = 0 then
      Result := stOr else
    if CompareText('LIKE', Str) = 0 then
      Result := stLike else
    if (CompareText('IS', Str) = 0) then
    begin
      if NextTokenIs('NULL', Str) then
        Result := stIsNull else
      begin
        l := p;
        s := Str;
        if NextTokenIs('NOT', Str) and NextTokenIs('NULL', Str) then
          Result := stIsNotNull else
        begin
          p := l;
          Str := s;
          Result := stValue;
        end;
      end;
    end else
    if CompareText('FROM', Str) = 0 then
      Result := stFrom else
    if CompareText('WHERE', Str) = 0 then
      Result := stWhere else
    if (CompareText('GROUP', Str) = 0) and NextTokenIs('BY', Str) then
      Result := stGroupBy else
    if CompareText('HAVING', Str) = 0 then
      Result := stHaving else
    if CompareText('UNION', Str) = 0 then
      Result := stUnion else
    if CompareText('PLAN', Str) = 0 then
      Result := stPlan else
    if (CompareText('FOR', Str) = 0) and NextTokenIs('UPDATE', Str) then
      Result := stForUpdate else
    if (CompareText('ORDER', Str) = 0) and NextTokenIs('BY', Str)  then
      Result := stOrderBy else
    if CompareText('NULL', Str) = 0 then
      Result := stValue else
    if CurSection = stFrom then
      Result := stTableName else
      Result := stFieldName;
  end;

var
  TokenStart: Integer;

  procedure StartToken;
  begin
    if TokenStart <= 0 then
      TokenStart := p;
  end;

var
  Literal: Char;
  Mark, EndPos: Integer;
begin
  TokenStart := -1;
  DotStart := False;
  EndPos := Length(SQL);
  while p <= EndPos do
  begin
    case SQL[p] of
      '"','''','`':
      begin
        StartToken;
        Literal := SQL[p];
        Mark := p;
        repeat Inc(p) until (p > EndPos) or (SQL[p] = Literal);
        if p > EndPos then
        begin
          p := Mark;
          Inc(p);
        end else
        begin
          Inc(p);
          Token := DequotedStr(Copy(SQL, TokenStart, p - TokenStart), Literal);
          if DotStart then
            Result := stFieldName else
          if (p <= EndPos) and (SQL[p] = '.') then
            Result := stTableName else
            Result := stValue;
          Exit;
        end;
      end;
      '/':
      begin
        StartToken;
        Inc(p);
        if (P <= EndPos) and (SQL[p] in ['/','*']) then
        begin
          if SQL[p] = '*' then
          begin
            repeat
              Inc(p)
            until (p > EndPos) or
                  ((SQL[p] = '*') and (p < EndPos) and (SQL[p+1] = '/'));
          end else
            while (p <= EndPos) and not (SQL[p] in [#10, #13]) do Inc(p);
          Token := Copy(SQL, TokenStart, p - TokenStart);
          Result := stComment;
          Exit;
        end;
      end;
      ' ', #10, #13, ',', '(':
      begin
        if TokenStart > 0 then
        begin
          Token := Copy(SQL, TokenStart, p - TokenStart);
          Result := GetSQLToken(Token);
          Exit;
        end else
          while (p <= EndPos) and (SQL[p] in [' ', #10, #13, ',', '(']) do
            Inc(p);
      end;
      '.':
      begin
        if TokenStart > 0 then
        begin
          Token := Copy(SQL, TokenStart, p - TokenStart);
          Result := stTableName;
          Exit;
        end else
        begin
          DotStart := True;
          Inc(p);
        end;
      end;
      '=','<','>':
      begin
        if TokenStart < 1 then
        begin
          TokenStart := p;
          while (p <= EndPos) and (SQL[p] in ['=','<','>']) do Inc(p);
          Token := Copy(SQL, TokenStart, p - TokenStart);
          Result := stPredicate;
          Exit;
        end;
        Inc(p);
      end;
      '0'..'9':
      begin
        if TokenStart < 1 then
        begin
          TokenStart := p;
          while (p <= EndPos) and (SQL[p] in ['0'..'9','.']) do Inc(p);
          Token := Copy(SQL, TokenStart, p - TokenStart);
          Result := stNumber;
          Exit;
        end else
          Inc(p);
      end;
    else
      StartToken;
      Inc(p);
    end;
  end;
  { we reached the end of the SQL string (p = EndPos + 1)}
  if TokenStart > 0 then
  begin
    Token := Copy(SQL, TokenStart, p - TokenStart);
    Result := GetSQLToken(Token);
  end else
  begin
    Result := stEnd;
    Token := '';
  end;
end;

const
  SWhere = ' where ';     { do not localize }
  SAnd = ' and ';         { do not localize }

function AddParamSQLForDetail(Params: TParams; SQL: string; Native: Boolean; QuoteChar: string = ''): string;
  function GenerateParamSQL: string;
  var
    I: Integer;
    ParamName: string;
  begin
    for I := 0 to Params.Count -1 do
    begin
      if QuoteChar = '"' then
        ParamName := '"' + StringReplace(Params[I].Name, '"', '""', [rfReplaceAll] ) + '"'
      else
        ParamName := QuoteChar + Params[I].Name +QuoteChar;
      if I > 0 then Result := Result + SAnd;
      if Native then
        Result := Result + format('%s = ?', [ParamName])
      else
        Result := Result + format('%s = :%s', [ParamName, ParamName]);
    end;
    if pos(SWhere, LowerCase(Result)) > 0 then
      Result := SAnd + Result
    else
      Result := SWhere + Result;
  end;

  function AddWhereClause: string;
  var
    Start: Integer;
    FName: string;
    SQLToken, CurSection: TSQLToken;
  begin
    Start := 1;
    CurSection := stUnknown;
    repeat
      SQLToken := NextSQLToken(SQL, Start, FName, CurSection);
    until SQLToken in [stFrom, stEnd];
    if SQLToken = stFrom then
      NextSQLToken(SQL, Start, FName, CurSection);
    if Start > Length(SQL) then
      Result := SQL + ' ' + GenerateParamSQL
    else
      Result := Copy(SQL, 1, Start - 1) + ' ' + GenerateParamSQL +
        Copy(SQL, Start, Length(SQL) - Start + 1);
  end;

begin
  if (Params.Count > 0) then
    Result := AddWhereClause
  else
    Result := SQL;
end;

// SQL might be a direct tablename;
function GetTableNameFromQuery(const SQL: string): string;
begin
  if pos( 'select', lowercase(SQL) ) < 1 then
    Result := SQL
  else
    Result := GetTableNameFromSQL(SQL);
end;

function GetTableNameFromSQL(const SQL: string): string;
var
  Start: Integer;
  Token: string;
  SQLToken, CurSection: TSQLToken;
begin
  Result := '';
  Start := 1;
  CurSection := stUnknown;
  repeat
    SQLToken := NextSQLToken(SQL, Start, Token, CurSection);
    if SQLToken in SQLSections then CurSection := SQLToken;
  until SQLToken in [stEnd, stFrom];
  if SQLToken = stFrom then
  begin
    repeat
      SQLToken := NextSQLToken(SQL, Start, Token, CurSection);
      if SQLToken in SQLSections then
        CurSection := SQLToken else
      // stValue is returned if TableNames contain quote chars.
      if (SQLToken = stTableName) or (SQLToken = stValue) then
      begin
        if RightStr(Token, 1) = ';' then
        begin
          Token := LeftStr(Token, Length(Token)-1);
        end;
        Result := Token;
        while (Start <= Length(SQL)) and (SQL[Start] = '.') and
          not (SQLToken in [stEnd]) do
        begin
          SQLToken := NextSqlToken(SQL, Start, Token, CurSection);
          Result := Result + '.' + Token;
        end;
        Exit;
      end;
    until (CurSection <> stFrom) or (SQLToken in [stEnd, stTableName]);
  end;
end;

const
  SInnerJoin = 'inner join ';       { do not localize }
  SOuterJoin = 'outer join ';       { do not localize }

function IsMultiTableQuery(const SQL: string): Boolean;
var
  Start: Integer;
  SResult, Token: string;
  SQLToken, CurSection, SaveToken: TSQLToken;
begin
  SResult := '';
  Start := 1;
  CurSection := stUnknown;
  Result := True;
  repeat
    SQLToken := NextSQLToken(SQL, Start, Token, CurSection);
    if SQLToken in SQLSections then CurSection := SQLToken;
  until SQLToken in [stEnd, stFrom];
  if SQLToken = stFrom then
  begin
    repeat
      SQLToken := NextSQLToken(SQL, Start, Token, CurSection);
      if SQLToken in SQLSections then
        CurSection := SQLToken else
      // stValue is returned if TableNames contain quote chars.
      if (SQLToken = stTableName) or (SQLToken = stValue) then
      begin
        SResult := Token;
        while (Start <= Length(SQL)) and (SQL[Start] = '.') and
          not (SQLToken in [stEnd]) do
        begin
          SQLToken := NextSqlToken(SQL, Start, Token, CurSection);
          SResult := SResult + '.' + Token;
        end;
        if Start <= Length(SQL) then
        begin
          if (SQL[Start] = ',') or
            ((Start < Length(SQL)) and (SQL[Start + 1] = ',')) then
            exit;          
          SaveToken := SQLToken;
          SQLToken := NextSqlToken(SQL, Start, Token, CurSection);
          if SQLToken in SQLSections then CurSection := SQLToken;
          if (Start < Length(SQL)) and
             ((PosEx(sInnerJoin, SQL, Start) >= 1) or
              (PosEx(sOuterJoin, SQL, Start) >= 1)) then
            Exit;
          SQLToken := NextSqlToken(SQL, Start, Token, CurSection);
          if (SQLToken = stTableName) or (SaveToken = stTableName) then
            Exit;
        end;
        Result := False;
        Exit;
      end;
    until (CurSection <> stFrom) or (SQLToken in [stEnd, stTableName]);
  end;
end;

function GetIndexForOrderBy(const SQL: string; DataSet: TDataSet): TIndexDef;

  function AddField(const Fields, NewField: string): string;
  begin
    Result := Fields;
    if Fields <> '' then
      Result := Fields + ';' + NewField else
      Result := NewField;
  end;

var
  Start: Integer;
  Token, LastField, SaveField: string;
  SQLToken, CurSection: TSQLToken;
  FieldIndex: Integer;
begin
  Result := nil;
  Start := 1;
  CurSection := stUnknown;
  repeat
    SQLToken := NextSQLToken(SQL, Start, Token, CurSection);
    if SQLToken in SQLSections then CurSection := SQLToken;
  until SQLToken in [stEnd, stOrderBy];
  if SQLToken = stOrderBy then
  begin
    Result := TIndexDef.Create(nil);
    try
      LastField := '';
      repeat
        SQLToken := NextSQLToken(SQL, Start, Token, CurSection);
        if SQLToken in SQLSections then
          CurSection := SQLToken else
          case SQLToken of
            stTableName: ;
            stFieldName:
            begin
              LastField := Token;
              { Verify that we parsed a valid field name, not something like "UPPER(Foo)" }
              if not Assigned(Dataset.FindField(LastField)) then continue;
              Result.Fields := AddField(Result.Fields, LastField);
              SaveField := LastField;
            end;
            stAscending: ;
            stDescending:
              Result.DescFields := AddField(Result.DescFields, SaveField);
            stNumber:
            begin
              FieldIndex := StrToInt(Token);
              if DataSet.FieldCount >= FieldIndex then
                LastField := DataSet.Fields[FieldIndex - 1].FieldName else
              if DataSet.FieldDefs.Count >= FieldIndex then
                LastField := DataSet.FieldDefs[FieldIndex - 1].Name
              else
                { DB2 specific syntax "FETCH FIRST n ROWS ONLY" is blocked here,
                  so commenting out the following line }
                //SysUtils.Abort;
                continue;
              Result.Fields := AddField(Result.Fields, LastField);
            end;
          end;
      until (CurSection <> stOrderBy) or (SQLToken = stEnd);
    finally
      if Result.Fields = '' then
      begin
        Result.Free;
        Result := nil;
      end;
    end;
  end;
end;

function GetFieldInfo(const Origin: string; var FieldInfo: TFieldInfo): Boolean;
var
  Current: Integer;
  Values: array[0..4] of string;
  I: Integer;
  Len: Integer;

  function NextItem: string;
  var
    C: Integer;
    I: Integer;
    Terminator: Char;
  begin
    Result := '';
    C := Current;
    I := 1;
    while (C <= Len) and (Origin[C] in ['.',' ',#0]) do
      if (Origin[C] = #0) then Exit else Inc(C);
    if C > Len then Exit;
    Terminator := '.';
    if Origin[C] = '"' then
    begin
      Terminator := '"';
      Inc(C);
    end;
    SetLength(Result, Len);
    while (C <= Len) and (Origin[C] <> Terminator) and (Origin[C] <> #0) do
    begin
                     
(*
      if Origin[C] in LeadBytes then
      begin
        Result[I] := Origin[C];
        Inc(C);
        Inc(I);
      end
      else *)if Origin[C] = '\' then
      begin
        Inc(C);
                         
(*
        if (C < Len) and (Origin[C] in LeadBytes) then
        begin
          Result[I] := Origin[C];
          Inc(C);
          Inc(I);
        end;
*)
        if (C > Len) or (Origin[C] = #0) then Dec(C);
      end;
      Result[I] := Origin[C];
      Inc(C);
      Inc(I);
    end;
    SetLength(Result, I - 1);
    if (Terminator = '"') and (C <= Len) and (Origin[C] <> #0) then Inc(C);
    Current := C;
  end;

begin
  Result := False;
  if (Origin = '') then Exit;
  Current := 1;
  Len := Length(Origin);
  I := -1;
  repeat
    Inc(I);
    Values[I] := NextItem;
  until (Values[I] = '') or (I = High(Values));
  if I = High(Values) then Exit;
  Dec(I);
  if I >= 0 then
  begin
    FieldInfo.OriginalFieldName := Values[I];
    Dec(I);
  end else
    FieldInfo.OriginalFieldName := '';
  if I >= 0 then
  begin
    FieldInfo.TableName := Values[I];
    Dec(I);
  end else
    FieldInfo.TableName := '';
  if I >= 0 then
    FieldInfo.DatabaseName := Values[I]
  else
    FieldInfo.DatabaseName := '';
  Result := (FieldInfo.OriginalFieldName <> '') and (FieldInfo.TableName <> '');
end;

const
  StringFieldTypes = [ftString, ftFixedChar, ftWideString, ftGuid];
  BlobFieldTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle,
    ftTypedBinary, ftOraBlob, ftOraClob];

function IsNumeric(DataType: TFieldType): Boolean;
begin
  Result := DataType in [ftSmallint, ftInteger, ftWord, ftFloat, ftCurrency,
    ftBCD, ftAutoInc, ftLargeint, ftFMTBcd];
end;

function IsTemporal(DataType: TFieldType): Boolean;
begin
  Result := DataType in [ftDate, ftTime, ftDateTime, ftTimeStamp];
end;

{ TFilterExpr }

constructor TFilterExpr.Create(DataSet: TDataSet; Options: TFilterOptions;
  ParseOptions: TParserOptions; const FieldName: string; DepFields: TBits;
  FieldMap: TFieldMap);
begin
  inherited Create;
  FFieldMap := FieldMap;
  FDataSet := DataSet;
  FOptions := Options;
  FFieldName := FieldName;
  FParserOptions := ParseOptions;
  FDependentFields := DepFields;
end;

destructor TFilterExpr.Destroy;
var
  Node: TExprNode;
begin
  SetLength(FExprBuffer, 0);
  while FNodes <> nil do
  begin
    Node := FNodes;
    FNodes := Node.FNext;
    if (Node.FKind = enFunc) and (Node.FArgs <> nil) then
      Node.FArgs.Free;
    Node.Free;
  end;
end;

procedure TFilterExpr.WriteBufBytes(var Pos: Integer; Data: TBytes);
var
  I: Integer;
begin
  for I := 0 to Length(Data) - 1 do
    FExprBuffer[Pos + I] := Data[I];
  Inc(Pos, Length(Data));
end;

function TFilterExpr.FieldFromNode(Node: TExprNode): TField;
begin
  Result := GetFieldByName(VarToStr(Node.FData));
  if not (Result.FieldKind in [fkData, fkInternalCalc]) then
    DatabaseErrorFmt(SExprBadField, [Result.FieldName]);
end;

function TFilterExpr.GetExprData(Pos, Size: Integer): Integer;
var
  I: Integer;
begin
  SetLength(FExprBuffer, FExprBufSize + Size);
  for I := FExprBufSize - 1 downto Pos do
    FExprBuffer[I + Size] := FExprBuffer[I];
  Inc(FExprBufSize, Size);
  Result := Pos;
end;

function TFilterExpr.GetFilterData(Root: TExprNode): TExprData;
var
  Pos: Integer;
begin
  FExprBufSize := CANExprSize;
  SetLength(FExprBuffer, FExprBufSize);
  PutExprNode(Root, coNOTDEFINED);
  Pos := 0;
  WriteBufBytes(Pos, BitConverter.GetBytes(Word(CANEXPRVERSION))); { iVer }
  WriteBufBytes(Pos, BitConverter.GetBytes(Word(FExprBufSize)));   { iTotalSize }
  WriteBufBytes(Pos, BitConverter.GetBytes(Word($FFFF)));          { iNodes }
  WriteBufBytes(Pos, BitConverter.GetBytes(Word(CANEXPRSIZE)));    { iNodeStart }
  WriteBufBytes(Pos, BitConverter.GetBytes(Word(FExprNodeSize + CANEXPRSIZE))); { iLiteralStart }
  Result := FExprBuffer;
end;

function TFilterExpr.NewCompareNode(Field: TField; Operator: TCANOperator;
  const Value: Variant): TExprNode;
var
  ConstExpr: TExprNode;
begin
  ConstExpr := NewNode(enConst, coNOTDEFINED, Value, nil, nil);
  ConstExpr.FDataType := Field.DataType;
  ConstExpr.FDataSize := Field.Size;
  Result := NewNode(enOperator, Operator, Unassigned,
    NewNode(enField, coNOTDEFINED, Field.FieldName, nil, nil), ConstExpr);
end;

function TFilterExpr.NewNode(Kind: TExprNodeKind; Operator: TCANOperator;
  const Data: Variant; Left, Right: TExprNode): TExprNode;
var
  Field : TField;
begin
  Result := TExprNode.Create;
  with Result do
  begin
    FNext := FNodes;
    FKind := Kind;
    FPartial := False;
    FOperator := Operator;
    FData := Data;
    FLeft := Left;
    FRight := Right;
  end;
  FNodes := Result;
  if Kind = enField then
  begin
    Field := GetFieldByName(VarToStr(Data));
    if Field = nil then
      DatabaseErrorFmt(SFieldNotFound, [Data]);
    Result.FDataType := Field.DataType;
    Result.FDataSize := Field.Size;
  end;
end;

function TFilterExpr.PutConstBCD(const Value: Variant;
  Decimals: Integer): Integer;
var
  LBCD: TBcd;
begin
  LBCD := Value;
  LBCD := LBCD.Normalize(32, Decimals);
  Result := PutConstNode(ftBCD, TBcd.ToBytes(LBCD), 18);
end;

function TFilterExpr.PutConstFMTBCD(const Value: Variant;
  Decimals: Integer): Integer;
begin
  Result := PutConstNode(ftBCD, TBcd.ToBytes(Value), 18);
end;

function TFilterExpr.PutConstBool(const Value: Variant): Integer;
begin
  Result := PutConstNode(ftBoolean, BitConverter.GetBytes(Word(Value)),
    SizeOf(WordBool));
end;

function TFilterExpr.PutConstDate(const Value: Variant): Integer;
var
  DateTime: TDateTime;
  TimeStamp: TTimeStamp;
begin
  if VarType(Value) = varString then
    DateTime := StrToDate(VarToStr(Value)) else
    DateTime := Value;
  TimeStamp := DateTimeToTimeStamp(DateTime);
  Result := PutConstNode(ftDate, BitConverter.GetBytes(TimeStamp.Date), 4);
end;

function TFilterExpr.PutConstDateTime(const Value: Variant): Integer;
var
  DateTime: TDateTime;
  DateData: Int64;
begin
  DateTime := Value;
  DateData := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
  Result := PutConstNode(ftDateTime, BitConverter.GetBytes(DateData), 8);
end;

function TFilterExpr.PutConstSQLTimeStamp(const Value: Variant): Integer;
begin
  Result := PutConstNode(ftTimeStamp, TSQLTimeStamp.ToBytes(Value), 16);
end;

function TFilterExpr.PutConstFloat(const Value: Variant): Integer;
var
  F: Double;
begin
  F := Value;
  Result := PutConstNode(ftFloat, BitConverter.GetBytes(F), SizeOf(Double));
end;

function TFilterExpr.PutConstInt(DataType: TFieldType;
  const Value: Variant): Integer;
var
  I, Size: Integer;
begin
  I := Value;
  Size := 2;
  case DataType of
    ftSmallint:
      if (I < -32768) or (I > 32767) then DatabaseError(SExprRangeError);
    ftWord:
      if (I < 0) or (I > 65535) then DatabaseError(SExprRangeError);
  else
    Size := 4;
  end;
  Result := PutConstNode(DataType, BitConverter.GetBytes(I), Size);
end;

function TFilterExpr.PutConstNode(DataType: TFieldType; Data: TBytes;
  Size: Integer): Integer;
begin
  Result := PutNode(nodeCONST, coCONST2, 3);
  SetNodeOp(Result, 0, FFieldMap[DataType]);
  SetNodeOp(Result, 1, Size);
  SetNodeOp(Result, 2, PutData(Data, Size));
end;

function TFilterExpr.PutConstStr(const Value: string): Integer;
var
  Str: string;
begin
  if Length(Value) >= 256 then
    Str := Copy(Value, 1, 255) else
    Str := Value;
  Str := Str + #0;
  FDataSet.Translate(Str, Str, True);
  Result := PutConstNode(ftString, BytesOf(Str), Length(Str));
end;

function TFilterExpr.PutConstTime(const Value: Variant): Integer;
var
  DateTime: TDateTime;
  TimeStamp: TTimeStamp;
begin
  if VarType(Value) = varString then
    DateTime := StrToTime(VarToStr(Value)) else
    DateTime := Value;
  TimeStamp := DateTimeToTimeStamp(DateTime);
  Result := PutConstNode(ftTime, BitConverter.GetBytes(TimeStamp.Time), 4);
end;

function TFilterExpr.PutData(Data: TBytes; Size: Integer): Integer;
var
  I, P: Integer;
begin
  P := GetExprData(FExprBufSize, Size);
  for I := 0 to Size - 1 do
    FExprBuffer[P + I] := Data[I];
  Result := FExprDataSize;
  Inc(FExprDataSize, Size);
end;

function TFilterExpr.PutConstant(Node: TExprNode): Integer;
begin
  Result := 0;
  case Node.FDataType of
    ftSmallInt, ftInteger, ftWord, ftAutoInc:
      Result := PutConstInt(Node.FDataType, Node.FData);
    ftFloat, ftCurrency:
      Result := PutConstFloat(Node.FData);
    ftString, ftWideString, ftFixedChar, ftGuid:
      Result := PutConstStr(VarToStr(Node.FData));
    ftDate:
      Result := PutConstDate(Node.FData);
    ftTime:
      Result := PutConstTime(Node.FData);
    ftDateTime:
      Result := PutConstDateTime(Node.FData);
    ftTimeStamp:
      Result := PutConstSQLTimeStamp(Node.FData);
    ftBoolean:
      Result := PutConstBool(Node.FData);
    ftBCD:
      Result := PutConstBCD(Node.FData, Node.FDataSize);
    ftFMTBcd:
      Result := PutConstFMTBCD(Node.FData, Node.FDataSize);
    else
      DatabaseErrorFmt(SExprBadConst, [Node.FData]);
  end;
end;

const
  ReverseOperator: array[coEQ..coLE] of TCANOperator = (coEQ, coNE, coLT,
    coGT, coLE, coGE);
  BoolFalse: Word = 0;

function TFilterExpr.PutExprNode(Node: TExprNode; ParentOp: TCANOperator): Integer;
var
  Field: TField;
  Left, Right, Temp : TExprNode;
  LeftPos, RightPos, ListElem, PrevListElem, I: Integer;
  Operator: TCANOperator;
  CaseInsensitive, PartialLength, L:  Integer;
  S: string;
begin
  Result := 0;
  case Node.FKind of
    enField:
      begin
        Field := FieldFromNode(Node);
        if (ParentOp in [coOR, coNOT, coAND, coNOTDEFINED]) and
           (Field.DataType = ftBoolean) then
        begin
          Result := PutNode(nodeBINARY, coNE, 2);
          SetNodeOp(Result, 0, PutFieldNode(Field, Node));
          SetNodeOp(Result, 1,
            PutConstNode(ftBoolean, BitConverter.GetBytes(BoolFalse), SizeOf(WordBool)));
        end
        else
          Result := PutFieldNode(Field, Node);
      end;
    enConst:
      Result := PutConstant(Node);
    enOperator:
      case Node.FOperator of
        coIN:
          begin
            Result := PutNode(nodeBINARY, coIN, 2);
            SetNodeOp(Result, 0, PutExprNode(Node.FLeft, Node.FOperator));
            ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
            SetNodeOp(Result, 1, ListElem);
            PrevListElem := ListElem;
            for I := 0 to Node.FArgs.Count - 1 do
            begin
              LeftPos := PutExprNode(TExprNode(Node.FArgs.Items[I]), Node.FOperator);
              if I = 0 then
                begin
                  SetNodeOp(PrevListElem, 0, LeftPos);
                  SetNodeOp(PrevListElem, 1, 0);
                end
              else
                begin
                  ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
                  SetNodeOp(ListElem, 0, LeftPos);
                  SetNodeOp(ListElem, 1, 0);
                  SetNodeOp(PrevListElem, 1, ListElem);
                  PrevListElem := ListElem;
                end;
              end;
          end;
        coNOT,
        coISBLANK,
        coNOTBLANK:
          begin
            Result := PutNode(nodeUNARY, Node.FOperator, 1);
            SetNodeOp(Result, 0, PutExprNode(Node.FLeft, Node.FOperator));
          end;
        coEQ..coLE,
        coAND,coOR,
        coADD..coDIV,
        coLIKE,
        coASSIGN:
          begin
            Operator := Node.FOperator;
            Left := Node.FLeft;
            Right := Node.FRight;
            if (Operator in [coEQ..coLE]) and (Right.FKind = enField) and
               (Left.FKind <> enField) then
            begin
              Temp := Left;
              Left := Right;
              Right := Temp;
              Operator := ReverseOperator[Operator];
            end;

            Result := 0;
            if (Left.FKind = enField) and (Right.FKind = enConst)
               and ((Node.FOperator = coEQ)  or (Node.FOperator = coNE)
               or (Node.FOperator = coLIKE)) then
            begin
              if VarIsNull(Right.FData) then
              begin
                case Node.FOperator of
                  coEQ: Operator := coISBLANK;
                  coNE: Operator := coNOTBLANK;
                else
                  DatabaseError(SExprBadNullTest);
                end;
                Result := PutNode(nodeUNARY, Operator, 1);
                SetNodeOp(Result, 0, PutExprNode(Left,Node.FOperator));
              end
              else if (Right.FDataType in StringFieldTypes) then
              begin
                S := VarToStr(Right.FData);
                L := Length(S);
                if L <> 0 then
                begin
                  CaseInsensitive := 0;
                  PartialLength := 0;
                  if foCaseInsensitive in FOptions then CaseInsensitive := 1;
                  if Node.FPartial then PartialLength := L else
                    if not (foNoPartialCompare in FOptions) and (L > 1) and
                      (S[L] = '*') then
                    begin
                      Delete(S, L, 1);
                      PartialLength := L - 1;
                    end;
                  if (CaseInsensitive <> 0) or (PartialLength <> 0) then
                  begin
                    Result := PutNode(nodeCOMPARE, Operator, 4);
                    SetNodeOp(Result, 0, CaseInsensitive);
                    SetNodeOp(Result, 1, PartialLength);
                    SetNodeOp(Result, 2, PutExprNode(Left, Node.FOperator));
                    SetNodeOp(Result, 3, PutConstStr(S));
                  end;
                end;
              end;
            end;

            if Result = 0 then
            begin
              if (Operator = coISBLANK) or (Operator = coNOTBLANK) then
              begin
                Result := PutNode(nodeUNARY, Operator, 1);
                LeftPos := PutExprNode(Left, Node.FOperator);
                SetNodeOp(Result, 0, LeftPos);
              end else
              begin
                Result := PutNode(nodeBINARY, Operator, 2);
                LeftPos := PutExprNode(Left, Node.FOperator);
                RightPos := PutExprNode(Right, Node.FOperator);
                SetNodeOp(Result, 0, LeftPos);
                SetNodeOp(Result, 1, RightPos);
              end;
            end;
          end;
      end;
    enFunc:
      begin
        Result := PutNode(nodeFUNC, coFUNC2, 2);
        S := VarToStr(Node.FData);
        SetNodeOp(Result, 0,  PutData(BytesOf(S + #0), Length(S) + 1));
        if Node.FArgs <> nil then
        begin
          ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
          SetNodeOp(Result, 1, ListElem);
          PrevListElem := ListElem;
          for I := 0 to Node.FArgs.Count - 1 do
          begin
            LeftPos := PutExprNode(TExprNode(Node.FArgs.Items[I]), Node.FOperator);
            if I = 0 then
            begin
              SetNodeOp(PrevListElem, 0, LeftPos);
              SetNodeOp(PrevListElem, 1, 0);
            end
            else
            begin
              ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
              SetNodeOp(ListElem, 0, LeftPos);
              SetNodeOp(ListElem, 1, 0);
              SetNodeOp(PrevListElem, 1, ListElem);
              PrevListElem := ListElem;
            end;
          end;
        end else
          SetNodeOp(Result, 1, 0);
      end;
  end;
end;


function TFilterExpr.PutFieldNode(Field: TField; Node: TExprNode): Integer;
var
  Buffer: string;
begin
  if poFieldNameGiven in FParserOptions then
    FDataSet.Translate(Field.FieldName, Buffer, True)
  else
    FDataSet.Translate(VarToStr(Node.FData), Buffer, True);
  Buffer := Buffer + #0;
  Result := PutNode(nodeFIELD, coFIELD2, 2);
  SetNodeOp(Result, 0, Field.FieldNo);
  SetNodeOp(Result, 1, PutData(BytesOf(Buffer), Length(Buffer)));
end;

function TFilterExpr.PutNode(NodeType: NodeClass; OpType: TCANOperator;
  OpCount: Integer): Integer;
var
  Size: Integer;
  DataPos: Integer;
begin
  Size := CANHDRSIZE + OpCount * SizeOf(Word);
  DataPos := GetExprData(CANEXPRSIZE + FExprNodeSize, Size);
  WriteBufBytes(DataPos, BitConverter.GetBytes(Integer(NodeType))); { CANHdr.nodeClass }
  WriteBufBytes(DataPos, BitConverter.GetBytes(Integer(OpType)));   { CANHdr.coOp }
  Result := FExprNodeSize;
  Inc(FExprNodeSize, Size);
end;

procedure TFilterExpr.SetNodeOp(Node, Index, Data: Integer);
var
  I: Integer;
begin
  I := CANEXPRSIZE + Node + CANHDRSIZE + (Index * SizeOf(Word));
  WriteBufBytes(I, BitConverter.GetBytes(Word(Data)));
(*  PWordArray(PChar(FExprBuffer) + (CANEXPRSIZE + Node +
    CANHDRSIZE))^[Index] := Data; *)
end;

function TFilterExpr.GetFieldByName(Name: string) : TField;
var
  I: Integer;
  F: TField;
  FieldInfo: TFieldInfo;
begin
  Result := nil;
  if poFieldNameGiven in FParserOptions then
    Result := FDataSet.FieldByName(FFieldName)
  else if poUseOrigNames in FParserOptions then
  begin
    for I := 0 to FDataset.FieldCount - 1 do
    begin
      F := FDataSet.Fields[I];
      if GetFieldInfo(F.Origin, FieldInfo) and
         (AnsiCompareStr(Name, FieldInfo.OriginalFieldName) = 0) then
      begin
        Result := F;
        Exit;
      end;
    end;
  end;
  if Result = nil then
    Result := FDataSet.FieldByName(Name);
  if (Result <> nil) and (Result.FieldKind = fkCalculated) and (poAggregate in FParserOptions) then
    DatabaseErrorFmt(SExprNoAggOnCalcs, [Result.FieldName]);
  if (poFieldDepend in FParserOptions) and (Result <> nil) and
     (FDependentFields <> nil) then
    FDependentFields[Result.FieldNo-1] := True;
end;

constructor TExprParser.Create(DataSet: TDataSet; const Text: string;
  Options: TFilterOptions; ParserOptions: TParserOptions; const FieldName: string;
  DepFields: TBits; FieldMap: TFieldMap);
begin
  inherited Create;
  FDecimalSeparator := DecimalSeparator;
  FFieldMap := FieldMap;
  FStrTrue := STextTrue;
  FStrFalse := STextFalse;
  FDataSet := DataSet;
  FDependentFields := DepFields;
  FFilter := TFilterExpr.Create(DataSet, Options, ParserOptions, FieldName,
    DepFields, FieldMap);
  if Text <> '' then
    SetExprParams(Text, Options, ParserOptions, FieldName);
end;

destructor TExprParser.Destroy;
begin
  FreeAndNil(FFilter);
end;

procedure  TExprParser.SetExprParams(const Text: string; Options: TFilterOptions;
  ParserOptions: TParserOptions; const FieldName: string);
var
  Root, DefField: TExprNode;
begin
  FParserOptions := ParserOptions;
  if FFilter <> nil then
    FFilter.Free;
  FFilter := TFilterExpr.Create(FDataSet, Options, ParserOptions, FieldName,
    FDependentFields, FFieldMap);
  FText := Text;
  FSourcePtr := 1;
  FFieldName := FieldName;
  NextToken;
  Root := ParseExpr;
  if FToken <> etEnd then DatabaseError(SExprTermination);
  if (poAggregate in FParserOptions) and (Root.FScopeKind <> skAgg) then
     DatabaseError(SExprNotAgg);
  if (not (poAggregate in FParserOptions)) and (Root.FScopeKind = skAgg) then
     DatabaseError(SExprNoAggFilter);
  if poDefaultExpr in ParserOptions then
  begin
    DefField := FFilter.NewNode(enField, coNOTDEFINED, FFieldName, nil, nil);
    if (IsTemporal(DefField.FDataType) and (Root.FDataType in StringFieldTypes)) or
       ((DefField.FDataType = ftBoolean ) and (Root.FDataType in StringFieldTypes)) then
      Root.FDataType := DefField.FDataType;

    if not ((IsTemporal(DefField.FDataType) and IsTemporal(Root.FDataType))
       or (IsNumeric(DefField.FDataType) and IsNumeric(Root.FDataType))
       or ((DefField.FDataType in StringFieldTypes) and (Root.FDataType in StringFieldTypes))
       or ((DefField.FDataType = ftBoolean) and (Root.FDataType = ftBoolean))) then
      DatabaseError(SExprTypeMis);
    Root := FFilter.NewNode(enOperator, coASSIGN, Unassigned, Root, DefField);
  end;

  if not (poAggregate in FParserOptions) and not(poDefaultExpr in ParserOptions)
     and (Root.FDataType <> ftBoolean ) then
     DatabaseError(SExprIncorrect);

  FFilterData := FFilter.GetFilterData(Root);
  FDataSize := FFilter.FExprBufSize;
end;

function TExprParser.NextTokenIsLParen : Boolean;
var
  P : Integer;
begin
  P := FSourcePtr;
  while (P <= Length(FText)) and (FText[P] <> #0) and (FText[P] <= ' ') do Inc(P);
  Result := (P <= Length(FText)) and (FText[P] = '(');
end;

function EndOfLiteral(S: string; var P : Integer): Boolean;
var
  FName: String;
  Len: Integer;
  PTemp: Integer;
begin
  Inc(P);
  Len := Length(S);
  Result := (P > Len) or (S[P] <> '''');
  if Result and (P <= Len) then
  begin      // now, look for 'John's Horse'
    if PosEx('''', S, P) >= 1 then // found another '
    begin
      PTemp := P;  // don't advance P
      while (S[PTemp] in [ ' ', ')' ]) do Inc(PTemp);
      if NextSQLToken(S, PTemp, FName, stValue) in [stFieldName, stUnknown] then
      begin   // 'John's Horse' case: not really end of literal
        Result := False;
        Dec(P);
      end;
    end;
  end;
end;

procedure TExprParser.NextToken;
var
  P, TokenStart: Integer;
  L, Len: Integer;
  StrBuf: string;

                    
(*
  function IsKatakana(const Chr: Byte): Boolean;
  begin
{$IFDEF MSWINDOWS}
    Result := (SysLocale.PriLangID = LANG_JAPANESE) and (Chr in [$A1..$DF]);
{$ENDIF}
{$IFDEF LINUX}
    Result := False;
{$ENDIF}
  end;
*)
  procedure Skip(TheSet: TSysCharSet);
  begin
    while P <= Len do
    begin
                       
(*
      if P^ in LeadBytes then
        Inc(P, 2)
      else *) if (FText[P] in TheSet)
(*
         or IsKatakana(Byte(P^)) *) then
        Inc(P)
      else
        Exit;
    end;
  end;

begin
  FPrevToken := FToken;
  FTokenString := '';
  P := FSourcePtr;
  Len := Length(FText);
  while (P <= Len) and (FText[P] <= ' ') and (FText[P] <> #0) do Inc(P);
  if (P < Len) and (FText[P] = '/') and (FText[P+1] = '*') then
  begin
    P := P + 2;
    while (P <= Len) and not (FText[P] in ['*', #0]) do Inc(P);
    if (P < Len) and (FText[P] = '*') and (FText[P+1] =  '/')  then
      P := P + 2
    else if P <= Len then
      DatabaseErrorFmt(SExprInvalidChar, [FText[P]]);
  end;
  while (P <= Len) and (FText[P] <= ' ') do Inc(P);
  FTokenPtr := P;
  if (P > Len) or (FText[P] = #0) then
   FToken := etEnd
  else case FText[P] of
    'A'..'Z', 'a'..'z', '_', #$81..#$fe:
      begin
        TokenStart := P;
        if not SysLocale.FarEast then
        begin
          Inc(P);
          while (P <= Len) and
            (FText[P] in ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '[', ']']) do
            Inc(P);
        end
        else
          Skip(['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '[', ']']);
        FTokenString := Copy(FText, TokenStart, P - TokenStart);
        FToken := etSymbol;
        if SameText(FTokenString, 'LIKE') then   { do not localize }
          FToken := etLIKE
        else if SameText(FTokenString, 'IN') then   { do not localize }
          FToken := etIN
        else if SameText(FTokenString, 'IS') then    { do not localize }
        begin
          while (P <= Len) and (FText[P] <= ' ') do Inc(P);
          TokenStart := P;
          Skip(['A'..'Z', 'a'..'z']);
          FTokenString := Copy(FText, TokenStart, P - TokenStart);
          if SameText(FTokenString, 'NOT') then  { do not localize }
          begin
            while (P <= Len) and (FText[P] <= ' ') do Inc(P);
            TokenStart := P;
            Skip(['A'..'Z', 'a'..'z']);
            FTokenString := Copy(FText, TokenStart, P - TokenStart);
            if SameText(FTokenString, 'NULL') then
              FToken := etISNOTNULL
            else
              DatabaseError(SInvalidKeywordUse);
          end
          else if SameText (FTokenString, 'NULL')  then  { do not localize }
          begin
            FToken := etISNULL;
          end
          else
            DatabaseError(SInvalidKeywordUse);
        end;
      end;
    '[':
      begin
        Inc(P);
        TokenStart := P;
        if (P <= Len) then
          P := PosEx(']', FText, P);
        if P = 0 then DatabaseError(SExprNameError);
        FTokenString := Copy(FText, TokenStart, P - TokenStart);
        FToken := etName;
        Inc(P);
      end;
    '''':
      begin
        Inc(P);
        L := 1;
        SetLength(StrBuf, 256);
        while True do
        begin
          if (P > Len) or (FText[P] = #0) then DatabaseError(SExprStringError);
          if FText[P] = '''' then
            if EndOfLiteral(FText, P) then
              Break;
          if (L <= Length(StrBuf)) and (P <= Len) then
          begin
            StrBuf[L] := FText[P];
            Inc(L);
          end;
          Inc(P);
        end;
        FTokenString := Copy(StrBuf, 1, L - 1);
        FToken := etLiteral;
        FNumericLit := False;
      end;
    '-', '0'..'9':
      begin
        if (FPrevToken <> etLiteral) and (FPrevToken <> etName) and
           (FPrevToken <> etSymbol)and (FPrevToken <> etRParen) then
          begin
            TokenStart := P;
            Inc(P);
            while (P <= Len) and
              ((FText[P] in ['0'..'9', 'e', 'E', '+', '-']) or
               (System.String.CompareOrdinal(FText, P - 1, FDecimalSeparator, 0, Length(FDecimalSeparator)) = 0)) do
              Inc(P);
            if (FText[P-1] = ',') and SameText(FDecimalSeparator, ',') and
              (P <= Len) and (FText[P] = ' ') then
              Dec(P);
            FTokenString := Copy(FText, TokenStart, P - TokenStart);
            FToken := etLiteral;
            FNumericLit := True;
          end
        else
         begin
           FToken := etSUB;
           Inc(P);
         end;
      end;
    '(':
      begin
        Inc(P);
        FToken := etLParen;
      end;
    ')':
      begin
        Inc(P);
        FToken := etRParen;
      end;
    '<':
      begin
        Inc(P);
        if P > Len then
          FToken := etLT
        else case FText[P] of
          '=':
            begin
              Inc(P);
              FToken := etLE;
            end;
          '>':
            begin
              Inc(P);
              FToken := etNE;
            end;
        else
          FToken := etLT;
        end;
      end;
    '=':
      begin
        Inc(P);
        FToken := etEQ;
      end;
    '>':
      begin
        Inc(P);
        if (P <= Len) and (FText[P] = '=') then
        begin
          Inc(P);
          FToken := etGE;
        end else
          FToken := etGT;
      end;
    '+':
      begin
        Inc(P);
        FToken := etADD;
      end;
    '*':
      begin
        Inc(P);
        FToken := etMUL;
      end;
    '/':
      begin
        Inc(P);
        FToken := etDIV;
      end;
    ',':
      begin
        Inc(P);
        FToken := etComma;
      end;
  else
    DatabaseErrorFmt(SExprInvalidChar, [FText[P]]);
  end;
  FSourcePtr := P;
end;

function TExprParser.ParseExpr: TExprNode;
begin
  Result := ParseExpr2;
  while TokenSymbolIs('OR') do
  begin
    NextToken;
    Result := FFilter.NewNode(enOperator, coOR, Unassigned,
      Result, ParseExpr2);
    GetScopeKind(Result, Result.FLeft, Result.FRight);
    Result.FDataType := ftBoolean;
  end;
end;

function TExprParser.ParseExpr2: TExprNode;
begin
  Result := ParseExpr3;
  while TokenSymbolIs('AND') do
  begin
    NextToken;
    Result := FFilter.NewNode(enOperator, coAND, Unassigned,
      Result, ParseExpr3);
    GetScopeKind(Result, Result.FLeft, Result.FRight);
    Result.FDataType := ftBoolean;
  end;
end;

function TExprParser.ParseExpr3: TExprNode;
begin
  if TokenSymbolIs('NOT') then
  begin
    NextToken;
    Result := FFilter.NewNode(enOperator, coNOT, Unassigned,
      ParseExpr4, nil);
    Result.FDataType := ftBoolean;
  end else
    Result := ParseExpr4;
  GetScopeKind(Result, Result.FLeft, Result.FRight);
end;

const
  LogicalOperators: array[etEQ..etLT] of TCANOperator = (
    coEQ, coNE, coGE, coLE, coGT, coLT);

function TExprParser.ParseExpr4: TExprNode;
var
  Operator: TCANOperator;
  Left, Right: TExprNode;
begin
  Result := ParseExpr5;
  if (FToken in [etEQ..etLT]) or (FToken = etLIKE)
     or (FToken = etISNULL) or (FToken = etISNOTNULL)
     or (FToken = etIN) then
  begin
    case FToken of
      etEQ..etLT:
        Operator := LogicalOperators[FToken];
      etLIKE:
        Operator := coLIKE;
      etISNULL:
        Operator := coISBLANK;
      etISNOTNULL:
        Operator := coNOTBLANK;
      etIN:
        Operator := coIN;
      else
        Operator := coNOTDEFINED;
    end;
    NextToken;
    Left := Result;
    if Operator = coIN then
    begin
      if FToken <> etLParen then 
        DatabaseErrorFmt(SExprNoLParen, [TokenName]); 
      NextToken;
      Result := FFilter.NewNode(enOperator, coIN, Unassigned,
                 Left, nil);
      Result.FDataType := ftBoolean;
      if FToken <> etRParen then
      begin
        Result.FArgs := TList.Create;
        repeat
          Right := ParseExpr;
          if IsTemporal(Left.FDataType) then
            Right.FDataType := Left.FDataType;
          Result.FArgs.Add(Right);
          if (FToken <> etComma) and (FToken <> etRParen) then
            DatabaseErrorFmt(SExprNoRParenOrComma, [TokenName]);
          if FToken = etComma then NextToken;
        until (FToken = etRParen) or (FToken = etEnd);
        if FToken <> etRParen then
          DatabaseErrorFmt(SExprNoRParen, [TokenName]);
        NextToken;
      end else
        DatabaseError(SExprEmptyInList);
    end else
    begin
      if (Operator <> coISBLANK) and (Operator <> coNOTBLANK) then
        Right := ParseExpr5
      else
        Right := nil;
      Result := FFilter.NewNode(enOperator, Operator, Unassigned,
        Left, Right);
      if Right <> nil then
      begin
        if (Left.FKind = enField) and (Right.FKind = enConst) then
          begin
            Right.FDataType := Left.FDataType;
            Right.FDataSize := Left.FDataSize;
          end
        else if (Right.FKind = enField) and (Left.FKind = enConst) then
          begin
            Left.FDataType := Right.FDataType;
            Left.FDataSize := Right.FDataSize;
          end;
      end;
      if (Left.FDataType in BlobFieldTypes) and (Operator = coLIKE) then
      begin
        if Right.FKind = enConst then Right.FDataType := ftString;
      end
      else if (Operator <> coISBLANK) and (Operator <> coNOTBLANK)
         and ((Left.FDataType in (BlobFieldTypes + [ftBytes])) or
         ((Right <> nil) and (Right.FDataType in (BlobFieldTypes + [ftBytes])))) then
        DatabaseError(SExprTypeMis);
      Result.FDataType := ftBoolean;
      if Right <> nil then
      begin
        if IsTemporal(Left.FDataType) and (Right.FDataType in StringFieldTypes) then
          Right.FDataType := Left.FDataType
        else if IsTemporal(Right.FDataType) and (Left.FDataType in StringFieldTypes) then
          Left.FDataType := Right.FDataType;
      end;
      GetScopeKind(Result, Left, Right);
    end;
  end;
end;

const ArithOperators: array[etADD..etDIV] of TCANOperator = (
    coADD, coSUB, coMUL, coDIV);
function TExprParser.ParseExpr5: TExprNode;
var
  Operator: TCANOperator;
  Left, Right: TExprNode;
begin
  Result := ParseExpr6;
  while FToken in [etADD, etSUB] do
  begin
    if not (poExtSyntax in FParserOptions) then
      DatabaseError(SExprNoArith);
    Operator := ArithOperators[FToken];
    Left := Result;
    NextToken;
    Right := ParseExpr6;
    Result := FFilter.NewNode(enOperator, Operator, Unassigned, Left, Right);
    TypeCheckArithOp(Result);
    GetScopeKind(Result, Left, Right);
  end;
end;

function TExprParser.ParseExpr6: TExprNode;
var
  Operator: TCANOperator;
  Left, Right: TExprNode;
begin
  Result := ParseExpr7;
  while FToken in [etMUL, etDIV] do
  begin
    if not (poExtSyntax in FParserOptions) then
      DatabaseError(SExprNoArith);
    Operator := ArithOperators[FToken];
    Left := Result;
    NextToken;
    Right := ParseExpr7;
    Result := FFilter.NewNode(enOperator, Operator, Unassigned, Left, Right);
    TypeCheckArithOp(Result);
    GetScopeKind(Result, Left, Right);
  end;
end;


function TExprParser.ParseExpr7: TExprNode;
var
  FuncName: string;
begin
  case FToken of
    etSymbol:
      if (poExtSyntax in FParserOptions)
         and  NextTokenIsLParen and TokenSymbolIsFunc(FTokenString) then
        begin
          Funcname := FTokenString;
          NextToken;
          if FToken <> etLParen then 
            DatabaseErrorFmt(SExprNoLParen, [TokenName]); 
          NextToken;
          if (CompareText(FuncName,'count') = 0) and (FToken = etMUL) then 
          begin
            FuncName := 'COUNT(*)';
            NextToken;
          end;
          Result := FFilter.NewNode(enFunc, coNOTDEFINED, FuncName,
                    nil, nil);
          if FToken <> etRParen then
          begin
            Result.FArgs := TList.Create;
            repeat
              Result.FArgs.Add(ParseExpr);
              if (FToken <> etComma) and (FToken <> etRParen) then
                DatabaseErrorFmt(SExprNoRParenOrComma, [TokenName]); 
              if FToken = etComma then NextToken;
            until (FToken = etRParen) or (FToken = etEnd);
          end else 
            Result.FArgs := nil;

          GetFuncResultInfo(Result);
        end
      else if TokenSymbolIs('NULL') then
        begin
          Result := FFilter.NewNode(enConst, coNOTDEFINED, Variants.Null, nil, nil);
          Result.FScopeKind := skConst;
        end
      else if TokenSymbolIs(FStrTrue) then
        begin
          Result := FFilter.NewNode(enConst, coNOTDEFINED, Variant(1), nil, nil);
          Result.FScopeKind := skConst;
        end
      else if TokenSymbolIs(FStrFalse) then
        begin
          Result := FFilter.NewNode(enConst, coNOTDEFINED, Variant(0), nil, nil);
          Result.FScopeKind := skConst;
        end
      else
        begin
          Result := FFilter.NewNode(enField, coNOTDEFINED, FTokenString, nil, nil);
          Result.FScopeKind := skField;
        end;
    etName:
      begin
        Result := FFilter.NewNode(enField, coNOTDEFINED, FTokenString, nil, nil);
        Result.FScopeKind := skField;
      end;
    etLiteral:
      begin
        Result := FFilter.NewNode(enConst, coNOTDEFINED, FTokenString, nil, nil);
        if FNumericLit then Result.FDataType := ftFloat else
           Result.FDataType := ftString;
        Result.FScopeKind := skConst;
      end;
    etLParen:
      begin
        NextToken;
        Result := ParseExpr;
        if FToken <> etRParen then DatabaseErrorFmt(SExprNoRParen, [TokenName]);
      end;
  else
    DatabaseErrorFmt(SExprExpected, [TokenName]);
    Result := nil;
  end;
  NextToken;
end;

procedure  TExprParser.GetScopeKind(Root, Left, Right : TExprNode);
begin
  if (Left = nil) and (Right = nil) then Exit;
  if Right = nil then
  begin
    Root.FScopeKind := Left.FScopeKind;
    Exit;
  end;
  if ((Left.FScopeKind = skField) and (Right.FScopeKind = skAgg))
     or ((Left.FScopeKind = skAgg) and (Right.FScopeKind = skField)) then
    DatabaseError(SExprBadScope);
  if (Left.FScopeKind = skConst) and (Right.FScopeKind = skConst) then
    Root.FScopeKind := skConst
  else if (Left.FScopeKind = skAgg) or (Right.FScopeKind = skAgg) then
    Root.FScopeKind := skAgg
  else if (Left.FScopeKind = skField) or (Right.FScopeKind = skField) then
    Root.FScopeKind := skField;
end;

procedure TExprParser.GetFuncResultInfo(Node : TExprNode);
var
  S: string;
begin
  Node.FDataType := ftString;
  S := VarToStr(Node.FData);
  if (CompareText(S, 'COUNT(*)') <> 0 )
     and (CompareText(S,'GETDATE') <> 0 )
     and ( (Node.FArgs = nil ) or ( Node.FArgs.Count = 0) ) then
      DatabaseError(SExprTypeMis);

  if (Node.FArgs <> nil) and (Node.FArgs.Count > 0) then
     Node.FScopeKind := TExprNode(Node.FArgs.Items[0]).FScopeKind;
  if (CompareText(S, 'SUM') = 0) or
     (CompareText(S, 'AVG') = 0) then
  begin
    Node.FDataType := ftFloat;
    Node.FScopeKind := skAgg;
  end
  else if (CompareText(S, 'MIN') = 0) or
          (CompareText(S, 'MAX') = 0) then
  begin
    Node.FDataType := TExprNode(Node.FArgs.Items[0]).FDataType;
    Node.FScopeKind := skAgg;
  end
  else if  (CompareText(S, 'COUNT') = 0) or
           (CompareText(S, 'COUNT(*)') = 0) then
  begin
    Node.FDataType := ftInteger;
    Node.FScopeKind := skAgg;
  end
  else if (CompareText(S, 'YEAR') = 0) or
          (CompareText(S, 'MONTH') = 0) or
          (CompareText(S, 'DAY') = 0) or
          (CompareText(S, 'HOUR') = 0) or
          (CompareText(S, 'MINUTE') = 0) or
          (CompareText(S, 'SECOND') = 0 ) then
  begin
    Node.FDataType := ftInteger;
    Node.FScopeKind := TExprNode(Node.FArgs.Items[0]).FScopeKind;
  end
  else if CompareText(S, 'GETDATE') = 0  then
  begin
    Node.FDataType := ftDateTime;
    Node.FScopeKind := skConst;
  end
  else if CompareText(S, 'DATE') = 0  then
  begin
    Node.FDataType := ftDate;
    Node.FScopeKind := TExprNode(Node.FArgs.Items[0]).FScopeKind;
  end
  else if CompareText(S, 'TIME') = 0  then
  begin
    Node.FDataType := ftTime;
    Node.FScopeKind := TExprNode(Node.FArgs.Items[0]).FScopeKind;
  end;
end;

function TExprParser.TokenName: string;
begin
  if FSourcePtr = FTokenPtr then Result := SExprNothing else
  begin
    Result := Copy(FText, FTokenPtr, FSourcePtr - FTokenPtr);
    Result := '''' + Result + '''';
  end;
end;

function TExprParser.TokenSymbolIs(const S: string): Boolean;
begin
  Result := (FToken = etSymbol) and (CompareText(FTokenString, S) = 0);
end;


function TExprParser.TokenSymbolIsFunc(const S: string) : Boolean;
begin
  Result := (CompareText(S, 'UPPER') = 0) or
            (CompareText(S, 'LOWER') = 0) or
            (CompareText(S, 'SUBSTRING') = 0) or
            (CompareText(S, 'TRIM') = 0) or
            (CompareText(S, 'TRIMLEFT') = 0) or
            (CompareText(S, 'TRIMRIGHT') = 0) or
            (CompareText(S, 'YEAR') = 0) or
            (CompareText(S, 'MONTH') = 0) or
            (CompareText(S, 'DAY') = 0) or
            (CompareText(S, 'HOUR') = 0) or
            (CompareText(S, 'MINUTE') = 0) or
            (CompareText(S, 'SECOND') = 0) or
            (CompareText(S, 'GETDATE') = 0) or
            (CompareText(S, 'DATE') = 0) or
            (CompareText(S, 'TIME') = 0) or
            (CompareText(S, 'SUM') = 0) or
            (CompareText(S, 'MIN') = 0) or
            (CompareText(S, 'MAX') = 0) or
            (CompareText(S, 'AVG') = 0) or
            (CompareText(S, 'COUNT') = 0);

end;

procedure  TExprParser.TypeCheckArithOp(Node: TExprNode);
begin
  with Node do
  begin
    if IsNumeric(FLeft.FDataType) and IsNumeric(FRight.FDataType)  then
      FDataType := ftFloat
    else if (FLeft.FDataType in StringFieldTypes) and
       (FRight.FDataType in StringFieldTypes) and (FOperator = coADD) then
      FDataType := ftString
    else if IsTemporal(FLeft.FDataType) and IsNumeric(FRight.FDataType) and
       (FOperator = coADD) then
      FDataType := ftDateTime
    else if IsTemporal(FLeft.FDataType) and IsNumeric(FRight.FDataType) and
       (FOperator = coSUB) then
      FDataType := FLeft.FDataType
    else if IsTemporal(FLeft.FDataType) and IsTemporal(FRight.FDataType) and
       (FOperator = coSUB) then
      FDataType := ftFloat
    else if (FLeft.FDataType in StringFieldTypes) and IsTemporal(FRight.FDataType) and
       (FOperator = coSUB) then
    begin
      FLeft.FDataType := FRight.FDataType;
      FDataType := ftFloat;
    end
    else if ( FLeft.FDataType in StringFieldTypes) and  IsNumeric(FRight.FDataType )and
         (FLeft.FKind = enConst)  then
      FLeft.FDataType := ftDateTime
    else
      DatabaseError(SExprTypeMis);
  end;
end;

{ Utility routines }

procedure CopyBuffer(Source, Dest: IntPtr; Len: Cardinal);
var
  I: Integer;
begin
  for I := 0 to Len - 1 do
    with Marshal do
      WriteByte(Dest, I, ReadByte(Source, I));
end;

procedure InitializeBuffer(Buffer: IntPtr; Size: Integer; Value: Byte);
var
  I: Integer;
begin
  with Marshal do
    for I := 0 to Size - 1 do
      WriteByte(Buffer, I, Value);
end;

end.
