unit uDAExpressionEvaluator;

{----------------------------------------------------------------------------}
{ Data Abstract Library - Core Library                                       }
{                                                                            }
{ compiler: Delphi 6 and up, Kylix 3 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the Data Abstract              }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$I DataAbstract.inc}

interface
uses
  SysUtils, Classes, uDAMacros;

type
  EDAEvaluationException = class(Exception);
  TDAExpressionEvaluator = class;
  TDAEEGetValue = procedure (Sender: TDAExpressionEvaluator; const aIdentifier: string; out aValue: Variant) of object;
  TDAEEFunctionCall = procedure (Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant) of object;
  TDAEEFunction = class(TObject)
  private
    fName: string;
    fOnCall: TDAEEFunctionCall;
    fNameHash: Integer;
    procedure SetName(const Value: string);
  public
    property Name: string read fName write SetName;
    property NameHash: Integer read fNameHash;
    property OnCall: TDAEEFunctionCall read fOnCall write fOnCall;
  end;

  TDAEEFunctionList = class(TObject)
  private
    fItems: TList;
    function GetCount: Integer;
    function GetItem(i: Integer): TDAEEFunction;
  public
    constructor Create;
    destructor Destroy; override;

    property Count: Integer read GetCount;
    property Items[I: Integer]: TDAEEFunction read GetItem; default;

    function Add(const aName: string): TDAEEFunction;
    procedure Delete(I: Integer);
    procedure Clear;
  end;

  TDAExpressionEvaluator = class(TObject)
  private
    fOnUnknownFunctionCall: TDAEEFunctionCall;
    fOnGetValue: TDAEEGetValue;
    fFunctionList: TDAEEFunctionList;
    fParser: TROPascalParser;
    function EvaluateProcCall(const aIdentifier: string; const Args: Variant): Variant;
    function EvaluateValue(const aIdentifier: string): Variant;

    function Op_In(const V1, V2: Variant): Variant;
    function Op_Like(const V1, V2: Variant): Variant;
    function ParseBooleanExpression: Variant;
    function ParseComparisonExpression: Variant;
    function ParseFactor: Variant;
    function ParseSimpleExpression: Variant;
    function ParseTerm: Variant;
  public
    constructor Create;
    destructor Destroy; override;

    property OnGetValue: TDAEEGetValue read fOnGetValue write fOnGetValue;
    property OnUnknownFunctionCall: TDAEEFunctionCall read fOnUnknownFunctionCall write fOnUnknownFunctionCall;
    property FunctionList: TDAEEFunctionList read fFunctionList;

    function Evaluate(const aString: string): Variant;
  end;

  TDAStdExpressionEvaluator = class(TDAExpressionEvaluator)
  private
     procedure Convert(Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant);
     procedure Len(Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant);
     procedure IsNull(Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant);
     procedure IIF(Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant);
     procedure Trim(Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant);
     procedure Substring(Sender: TDAExpressionEvaluator; const aIdentifier: string; const Args: array of Variant; out aValue: Variant);
  public
    constructor Create;
  end;
implementation

uses Variants;

{ TDAExpressionEvaluator }

constructor TDAExpressionEvaluator.Create;
begin
  inherited Create;
  fFunctionList := TDAEEFunctionList.Create;
end;

destructor TDAExpressionEvaluator.Destroy;
begin
  fFunctionList.Free;
  inherited Destroy;
end;

function TDAExpressionEvaluator.Evaluate(const aString: string): Variant;
begin
  fParser := TROPascalParser.Create;
  fParser.OpenBlockEscape := true;
  try
    fParser.SetText(aString);
    Result := ParseBooleanExpression;

    if fParser.CurrtokenId <> CSTI_EOF then
      raise EDAEvaluationException.Create('End of expression expected');
  finally
    fParser.Free;
  end;
end;

function TDAExpressionEvaluator.EvaluateProcCall(const aIdentifier: string;
  const Args: Variant): Variant;
var
  s: string;
  h, i: Integer;
  lFunction: TDAEEFunction;
  lRealArgs: array of Variant;
begin
  if not VarIsArray(Args) then begin
    SetLength(lRealArgs, 1);
    lRealArgs[0] := args;
  end else begin
    SetLength(lRealArgs, VarArrayHighBound(Args, 1)+1);
    for i := 0 to Length(lRealArgs) -1 do begin
      lRealArgs[i] := Args[i];
    end;
  end;
  s := FastUppercase(aIdentifier);
  h := MakeHash(s);
  for i := 0 to fFunctionList.Count -1 do begin
    lFunction := fFunctionList[i];
    if (lFunction.NameHash = h) and (lFunction.Name = s) and (assigned(lFunction.OnCall)) then begin
      lFunction.OnCall(self, aIdentifier, lRealArgs, Result);
      exit;
    end;
  end;
  if assigned(fOnUnknownFunctionCall) then
    fOnUnknownFunctionCall(Self, aIdentifier, Args, Result)
  else
    raise EDAEvaluationException('Unknown function: '+aIdentifier);
end;

function TDAExpressionEvaluator.EvaluateValue(const aIdentifier: string): Variant;
begin
  if assigned(fOnGetValue) then
    fOnGetValue(Self, aIdentifier, Result)
  else
    raise EDAEvaluationException('Unknown identifier: '+aIdentifier);
end;

function TDAExpressionEvaluator.ParseComparisonExpression: Variant;
var
  V1, V2: Variant;
  lTok: TROPasToken;
begin
  V1 := ParseSimpleExpression;
  lTok := fParser.CurrTokenId;
  while (lTok = CSTII_In) or
    (lTok = CSTII_Like) or
    (lTok = CSTI_Greater ) or
    (lTok = CSTI_GreaterEqual) or
    (lTok = CSTI_Smaller ) or
    (lTok = CSTI_SmallerEqual) or
    (lTok = CSTI_Equal) or
    (lTok =CSTI_NotEqual) do
  begin
    FParser.Next;
    V2 := ParseSimpleExpression;

    case lTok of
      CSTII_In: V1 := Op_In(v1, v2);
      CSTII_Like: V1 := Op_Like(v1, v2);
      CSTI_Greater: v1 := v1 > v2;
      CSTI_GreaterEqual: v1 := v1 >= v2;
      CSTI_Smaller: v1 := v1 <= v2;
      CSTI_SmallerEqual: v1 := v1 <= v2;
      CSTI_Equal: v1 := v1 = v2;
      //CSTI_notEqual:
      else v1 := v1 <> v2;
    end;
    lTok := fParser.CurrTokenId;
  end;
  Result := V1;
end;

function TDAExpressionEvaluator.ParseSimpleExpression: Variant;
var
  V1, V2: Variant;
  lTok: TROPasToken;
begin
  V1 := ParseTerm;
  lTok := fParser.CurrTokenId;
  while (lTok = CSTI_Plus) or
    (lTok = CSTI_Minus) do
  begin
    FParser.Next;
    V2 := ParseTerm;

    case lTok of
      CSTI_Minus: V1 := V1 - V2;
      else v1 := v1 + v2; // CSTI_plus
    end;
    lTok := fParser.CurrTokenId;
  end;
  Result := V1;
end;

function ParseDate(s: string): TDateTime;
begin
  s := copy(S,2,Length(s)-2);
  if length(s) = 10 then begin
    if (s[3] <> '/') or (s[6] <> '/') then raise EDAEvaluationException.Create('Invalid date format');
    Result := EncodeDate(StrToInt(copy(s, 7, 4)), StrToInt(copy(S, 1, 2)), StrToInt(copy(s, 4, 2)));
  end else
    raise EDAEvaluationException.Create('Invalid date format');
end;

function TDAExpressionEvaluator.ParseFactor: Variant;
var
  tmp: TList;
  pv: PVariant;
  i: Integer;
  e: Extended;
  s: string;
begin
  case fParser.CurrTokenId of
    CSTII_Not: begin
        FParser.Next;
        Result := not ParseFactor;
      end;
    CSTI_Plus: begin
        FParser.Next;
        Result := + ParseFactor;
      end;
    CSTI_Minus: begin
        FParser.Next;
        Result := - ParseFactor;
      end;
    CSTI_OpenRound: begin
       FParser.Next;
       Result := ParseBooleanExpression;
       if fParser.CurrTokenId = CSTI_Comma then begin
         tmp := TList.Create;
         New(pv);
         pv^ := Result;
         tmp.Add(pv);
         while FPArser.CurrTokenId = CSTI_Comma do begin
           FParser.Next;
           try
             result := ParseBooleanExpression;
             New(pv);
             pv^ := Result;
             tmp.Add(pv);
           except
             for i := 0 to tmp.Count -1 do begin
               pv := tmp[i];
               dispose(pv);
             end;
             tmp.Free;
             raise;
           end;
         end;
         Result := VarArrayCreate([0, tmp.Count -1], varVariant);
         for i := 0 to tmp.Count -1 do begin
           pv := tmp[i];
           Result[i] := pv^;
           dispose(pv);
         end;
         tmp.Free;
       end;
       if fParser.CurrTokenId <> CSTI_CloseRound then
         raise EDAEvaluationException.Create('Closing parenthesis expected');
       FParser.Next;
     end;
    CSTI_HexInt, CSTI_Integer: begin
      Result := StrToInt64(FParser.OriginalToken);
      FParser.Next;
    end;
    CSTI_Real: begin
      Val(FParser.OriginalToken, e, i); Result := e;
      FParser.Next;
    end;
    CSTI_String: begin
      Result := StringReplace(FParser.OriginalToken, #39#39, #39, [rfReplaceAll]);
      Result := Copy(Result, 2, Length(Result) -2);
      Fparser.Next;
    end;
    CSTI_Date: begin
      Result := ParseDate(FParser.OriginalToken);
      FParser.Next;
    end;
    CSTI_Identifier: begin
      s :=  FPArser.OriginalToken;
      FParser.Next;
      if FParser.CurrTokenID = CSTI_OpenRound then
        Result := EvaluateProcCall(s, ParseFactor)
      else
        Result := EvaluateValue(s)
    end;
  else
    raise EDAEvaluationException.Create('Syntax error');
  end;
end;

function TDAExpressionEvaluator.ParseBooleanExpression: Variant;
var
  V1, V2: Variant;
  lTok: TROPasToken;
begin
  V1 := ParseComparisonExpression;
  lTok := fParser.CurrTokenId;
  while (lTok = CSTII_and) or
    (lTok = CSTII_or) or
    (lTok = CSTII_xor) do
  begin
    FParser.Next;
    V2 := ParseComparisonExpression;

    case lTok of
      CSTII_or: V1 := V1 or V2;
      CSTII_xor: V1 := V1 xor V2;
      else v1 := v1 and v2; // CSTII_and
    end;
    lTok := fParser.CurrTokenId;
  end;
  Result := V1;
end;

function TDAExpressionEvaluator.ParseTerm: Variant;
var
  V1, V2: Variant;
  lTok: TROPasToken;
begin
  V1 := ParseFactor;
  lTok := fParser.CurrTokenId;
  while (lTok = CSTI_multiply) or
    (lTok = CSTI_divide) or
    (lTok = CSTI_Modulus) do
  begin
    FParser.Next;
    V2 := ParseFactor;

    case lTok of
      CSTI_Multiply: V1 := V1 * V2;
      CSTI_Divide: V1 := V1 / V2;
      else v1 := v1 mod v2; // CSTI_modulus
    end;
    lTok := fParser.CurrTokenId;
  end;
  Result := V1;
end;

function TDAExpressionEvaluator.Op_In(const V1, V2: Variant): Variant;
var
  i: Integer;
begin
  if VarIsArray(V2) then begin
    for i := VarArrayLowBound(V2, 1) to VarArrayHighBound(V2, 1) do begin
      if v2[i] = v1 then begin Result := true; exit; end;
    end;
    Result := False;
  end else
    raise EDAEvaluationException.Create('Array expected for IN expression');
end;

function WidePos(const iSubString, iString:WideString): Integer; overload;
var i,j:integer;
    LenS,LenS1:integer;
    b: Boolean;
begin
  LenS1 := Length(iSubString);
  LenS := Length(iString);

  i := 1;
  while i <= LenS-LenS1+1 do begin

    { IsCandidate }
    b := true;
    for j := 1 to LenS1 do begin
      if iString[i+j-1] <> iSubString[j] then begin
        b := false;
        break;
      end;
    end;

    if b then begin
      result := i;
      exit;
    end;

    inc(i);
  end;
  result := 0;
end;

function TDAExpressionEvaluator.Op_Like(const V1, V2: Variant): Variant;
var
  w1, w2: WideString;
begin
  w1 := WideUppercase(V1);
  W2 := WideUppercase(V2);
  if Length(W2) = 0 then begin Result := False; exit; end;

  if (Length(W2) > 0) and ((W2[1] = '%') or (W2[1] = '*')) then begin
    if ((W2[Length(W2)] = '%') or (W2[Length(W2)] = '*')) then begin
      W2 := Copy(W2, 2, Length(W2) -2);
      Result := WidePos(W2, W1) > 0;
    end else begin
      W2 := Copy(W2, 2, Length(W2) -1);
      Result := Copy(W1, LEngth(W1) - Length(W2)+1, Length(W2)) = W2;
    end;
  end else if (Length(W2)> 0) and ((W2[Length(W2)] = '%') or (W2[Length(W2)] = '*')) then begin
    W2 := copy(W2, 1, Length(W2)-1);
    result := Copy(W1, 1, Length(W2)) = W2;
  end else
    result := w1 = w2;
end;

{ TDAEEFunction }

procedure TDAEEFunction.SetName(const Value: string);
begin
  fName := FastUppercase(Value);
  fNameHash := MakeHash(fName);
end;

{ TDAEEFunctionList }

function TDAEEFunctionList.Add(const aName: string): TDAEEFunction;
begin
  result := TDAEEFunction.Create;
  Result.Name := aName;
  fItems.Add(Result);
end;

procedure TDAEEFunctionList.Clear;
var
  i: Integer;
begin
  for i := fItems.Count -1 downto 0 do begin
    TDAEEFunction(fItems[i]).Free;
  end;
  fItems.Clear;
end;

constructor TDAEEFunctionList.Create;
begin
  inherited Create;
  fItems := TList.Create;
end;

procedure TDAEEFunctionList.Delete(I: Integer);
begin
  TDAEEFunction(fItems[i]).Free;
  fItems.Delete(i);
end;

destructor TDAEEFunctionList.Destroy;
begin
  Clear;
  fItems.Free;
  inherited Destroy;
end;

function TDAEEFunctionList.GetCount: Integer;
begin
  result := fItems.Count;
end;

function TDAEEFunctionList.GetItem(i: Integer): TDAEEFunction;
begin
  result := TDAEEFunction(fItems[i]);
end;

{ TDAStdExpressionEvaluator }

procedure TDAStdExpressionEvaluator.Convert(Sender: TDAExpressionEvaluator;
  const aIdentifier: string; const Args: array of Variant;
  out aValue: Variant);
var
  aType: TVarType;
  s: string;
begin
  if Length(Args) <> 2 then raise EDAEvaluationException.Create('2 arguments expected for "Convert"');
  s := FastUppercase(args[1]);
  if (s = 'SYSTEM.BYTE') or (s = 'BYTE') then aType := varByte else
  if (s = 'SYSTEM.SBYTE') or (s = 'SBYTE') then aType := varShortInt else
  if (s = 'SYSTEM.INT16') or (s = 'INT16') then aType := varSmallint else
  if (s = 'SYSTEM.UINT16') or (s = 'UINT16') then aType := varWord else
  if (s = 'SYSTEM.INT32') or (s = 'INT32') then aType := varInteger else
  if (s = 'SYSTEM.UINT32') or (s = 'UINT32') then aType := varLongWord else
  if (s = 'SYSTEM.INT64') or (s = 'INT64') then aType := varInt64 else
  if (s = 'SYSTEM.UINT64') or (s = 'UINT64') then aType := VarInt64 else
  if (s = 'SYSTEM.STRING') or (s = 'STRING') then aType := varOleStr else
  if (s = 'SYSTEM.SINGLE') or (s = 'SINGLE') then aType := varSIngle else
  if (s = 'SYSTEM.DOUBLE') or (s = 'DOUBLE') then aType := varDouble else
  if (s = 'SYSTEM.CHAR') or (s = 'CHAR') then aType := varOleStr else
  if (s = 'SYSTEM.DATETIME') or (s = 'DATETIME') then aType := varDate else
  raise EDAEvaluationException.Create('Unknown type used for conversion: "'+args[1]+'"');
  VarCast(aValue, Args[0], aType);
end;

constructor TDAStdExpressionEvaluator.Create;
begin
  inherited Create;
  FunctionList.Add('Convert').OnCall := Convert;
  FunctionList.Add('Len').OnCall := Len;
  FunctionList.Add('IsNull').OnCall := IsNull;
  FunctionList.Add('IIF').OnCall := IIF;
  FunctionList.Add('Trim').OnCall := Trim;
  FunctionList.Add('SubString').OnCall := SubString;
end;

procedure TDAStdExpressionEvaluator.IIF(Sender: TDAExpressionEvaluator;
  const aIdentifier: string; const Args: array of Variant;
  out aValue: Variant);
begin
  if Length(Args) <> 3 then raise EDAEvaluationException.Create('3 arguments expected for "IIF"');
  if Args[0] then
    aValue := Args[1]
  else
    aValue := Args[2];
end;

procedure TDAStdExpressionEvaluator.IsNull(Sender: TDAExpressionEvaluator;
  const aIdentifier: string; const Args: array of Variant;
  out aValue: Variant);
begin
  if Length(Args) <> 2 then raise EDAEvaluationException.Create('2 arguments expected for "IsNull"');
  if VarIsError(Args[0]) or VarIsNull(Args[0]) then
    aValue := Args[1]
  else
    aValue := Args[0];
end;

procedure TDAStdExpressionEvaluator.Len(Sender: TDAExpressionEvaluator;
  const aIdentifier: string; const Args: array of Variant;
  out aValue: Variant);
begin
  if Length(Args) <> 1 then raise EDAEvaluationException.Create('1 argument expected for "Len"');
  aValue := Length(WideString(Args[0]));
end;

procedure TDAStdExpressionEvaluator.Substring(
  Sender: TDAExpressionEvaluator; const aIdentifier: string;
  const Args: array of Variant; out aValue: Variant);
var
  w: WideString;
  s: string;
begin
  if Length(Args) <> 3 then raise EDAEvaluationException.Create('3 arguments expected for "Substring"');
  if VarType(Args[0]) = varOleStr then begin
    w := Args[0];
    aValue := Copy(w, Integer(args[1])-1, Integer(Args[2])); // zero based
  end else begin
    s := Args[0];
    aValue := Copy(s, Integer(args[1])-1, Integer(Args[2])); // zero based
  end;end;

procedure TDAStdExpressionEvaluator.Trim(Sender: TDAExpressionEvaluator;
  const aIdentifier: string; const Args: array of Variant;
  out aValue: Variant);
var
  w: WideString;
  s: string;
begin
  if Length(Args) <> 1 then raise EDAEvaluationException.Create('1 argument expected for "Trim"');
  if VarType(Args[0]) = varOleStr then begin
    w := Args[0];
    while (length(w) > 0) and ((w[1] = #13) or (w[1] = #10) or (w[1] = #9) or (w[1] = #32)) do
      Delete(w, 1, 1);
    while (length(w) > 0) and ((w[Length(w)] = #13) or (w[Length(w)] = #10) or (w[Length(w)] = #9) or (w[Length(w)] = #32)) do
      Delete(w, Length(w), 1);
    aValue := w;
  end else begin
    s := Args[0];
    while (length(s) > 0) and ((s[1] = #13) or (s[1] = #10) or (s[1] = #9) or (s[1] = #32)) do
      Delete(s, 1, 1);
    while (length(s) > 0) and ((s[Length(s)] = #13) or (s[Length(s)] = #10) or (s[Length(s)] = #9) or (s[Length(s)] = #32)) do
      Delete(s, Length(s), 1);
    aValue := s;
  end;
end;

end.