fr_pars.pas

FASTREPORT报表工具,可以迅速制作报表.

{******************************************}
{                                          }
{             FastReport v2.4              }
{            Expression parser             }
{                                          }
{ Copyright (c) 1998-2001 by Tzyganenko A. }
{                                          }
{******************************************}

unit FR_Pars;

interface

{$I FR.inc}

uses Classes;

type
  TGetPValueEvent = procedure(const s: String; var v: Variant) of object;
  TFunctionEvent = procedure(const Name: String; p1, p2, p3: Variant;
                             var Val: Variant) of object;

// TfrParser is intended for calculating expressions passed as string
// parameter like '1 + 2 * (a + b)'. Expression can contain variables and
// functions. There is two events in TfrParser: OnGetValue and OnFunction
// intended for substitute var/func value instead of var/func name.
// Call TfrParser.Calc(Expression) to get expression value.

  TfrParser = class
  private
    FOnGetValue: TGetPValueEvent;
    FOnFunction: TFunctionEvent;
    function GetIdentify(const s: String; var i: Integer): String;
    function GetString(const s: String; var i: Integer):String;
    procedure Get3Parameters(const s: String; var i: Integer;
      var s1, s2, s3: String);
  public
    function Str2OPZ(s: String): String;
    function CalcOPZ(const s: String): Variant;
    function Calc(const s: String): Variant;
    property OnGetValue: TGetPValueEvent read FOnGetValue write FOnGetValue;
    property OnFunction: TFunctionEvent read FOnFunction write FOnFunction;
  end;


// TfrVariables is tool class intended for storing variable name and its
// value. Value is of type Variant.
// Call TfrVariables['VarName'] := VarValue to set variable value and
// VarValue := TfrVariables['VarName'] to retrieve it.

  TfrVariables = class(TObject)
  private
    FList: TStringList;
    procedure SetVariable(const Name: String; Value: Variant);
    function GetVariable(const Name: String): Variant;
    procedure SetValue(Index: Integer; Value: Variant);
    function GetValue(Index: Integer): Variant;
    procedure SetName(Index: Integer; Value: String);
    function GetName(Index: Integer): String;
    function GetCount: Integer;
    procedure SetSorted(Value: Boolean);
    function GetSorted: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Value: TfrVariables);
    procedure Clear;
    procedure Delete(Index: Integer);
    function IndexOf(const Name: String): Integer;
    procedure Insert(Position: Integer; const Name: String);
    property Variable[const Name: String]: Variant
      read GetVariable write SetVariable; default;
    property Value[Index: Integer]: Variant read GetValue write SetValue;
    property Name[Index: Integer]: String read GetName write SetName;
    property Count: Integer read GetCount;
    property Sorted: Boolean read GetSorted write SetSorted;
  end;


// TfrFunctionSplitter is internal class, you typically don't need to use it.
// It intended for splitting expression onto several parts and checking
// if it contains some specified functions.
// TfrFunctionSplitter used when checking if objects has aggregate functions
// inside.

  TfrFunctionSplitter = class
  protected
    FMatchFuncs, FSplitTo: TStrings;
    FParser: TfrParser;
    FVariables: TfrVariables;
  public
    constructor Create(MatchFuncs, SplitTo: TStrings; Variables: TfrVariables);
    destructor Destroy; override;
    procedure Split(s: String);
  end;


function GetBrackedVariable(const s: String; var i, j: Integer): String;

implementation

uses SysUtils
{$IFDEF Delphi6}
, Variants
{$ENDIF};

type
  PVariable = ^TVariable;
  TVariable = record
    Value: Variant;
  end;

const
  ttGe = #1; ttLe = #2;
  ttNe = #3; ttOr = #4; ttAnd = #5;
  ttInt = #6;  ttFrac = #7;
  ttUnMinus = #9; ttUnPlus = #10; ttStr = #11;
  ttNot = #12; ttMod = #13; ttRound = #14;


function GetBrackedVariable(const s: String; var i, j: Integer): String;
var
  c: Integer;
  fl1, fl2: Boolean;
begin
  j := i; fl1 := True; fl2 := True; c := 0;
  Result := '';
  if (s = '') or (j > Length(s)) then Exit;
  Dec(j);
  repeat
    Inc(j);
    if fl1 and fl2 then
      if s[j] = '[' then
      begin
        if c = 0 then i := j;
        Inc(c);
      end
      else if s[j] = ']' then Dec(c);
    if fl1 then
      if s[j] = '"' then fl2 := not fl2;
    if fl2 then
      if s[j] = '''' then fl1 := not fl1;
  until (c = 0) or (j >= Length(s));
  Result := Copy(s, i + 1, j - i - 1);
end;


{ TfrVariables }

constructor TfrVariables.Create;
begin
  inherited Create;
  FList := TStringList.Create;
  FList.Duplicates := dupIgnore;
end;

destructor TfrVariables.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

procedure TfrVariables.Assign(Value: TfrVariables);
var
  i: Integer;
begin
  Clear;
  for i := 0 to Value.Count - 1 do
    SetVariable(Value.Name[i], Value.Value[i]);
end;

procedure TfrVariables.Clear;
begin
  while FList.Count > 0 do
    Delete(0);
end;

procedure TfrVariables.SetVariable(const Name: String; Value: Variant);
var
  i: Integer;
  p: PVariable;
begin
  i := IndexOf(Name);
  if i <> -1 then
    PVariable(FList.Objects[i]).Value := Value
  else
  begin
    New(p);
    p^.Value := Value;
    FList.AddObject(Name, TObject(p));
  end;
end;

function TfrVariables.GetVariable(const Name: String): Variant;
var
  i: Integer;
begin
  Result := Null;
  i := IndexOf(Name);
  if i <> -1 then
    Result := PVariable(FList.Objects[i]).Value;
end;

procedure TfrVariables.SetValue(Index: Integer; Value: Variant);
begin
  if (Index < 0) or (Index >= FList.Count) then Exit;
  PVariable(FList.Objects[Index])^.Value := Value;
end;

function TfrVariables.GetValue(Index: Integer): Variant;
begin
  Result := 0;
  if (Index < 0) or (Index >= FList.Count) then Exit;
  Result := PVariable(FList.Objects[Index])^.Value;
end;

function TfrVariables.IndexOf(const Name: String): Integer;
begin
  Result := FList.IndexOf(Name);
end;

procedure TfrVariables.Insert(Position: Integer; const Name: String);
begin
  SetVariable(Name, 0);
  FList.Move(FList.IndexOf(Name), Position);
end;

function TfrVariables.GetCount: Integer;
begin
  Result := FList.Count;
end;

procedure TfrVariables.SetName(Index: Integer; Value: String);
begin
  if (Index < 0) or (Index >= FList.Count) then Exit;
  FList[Index] := Value;
end;

function TfrVariables.GetName(Index: Integer): String;
begin
  Result := '';
  if (Index < 0) or (Index >= FList.Count) then Exit;
  Result := FList[Index];
end;

procedure TfrVariables.Delete(Index: Integer);
var
  p: PVariable;
begin
  if (Index < 0) or (Index >= FList.Count) then Exit;
  p := PVariable(FList.Objects[Index]);
  Dispose(p);
  FList.Delete(Index);
end;

procedure TfrVariables.SetSorted(Value: Boolean);
begin
  FList.Sorted := Value;
end;

function TfrVariables.GetSorted: Boolean;
begin
  Result := FList.Sorted;
end;


{ TfrParser }

{$WARNINGS OFF}

function TfrParser.CalcOPZ(const s: String): Variant;
var
  i, j, k, i1, st, ci, cn: Integer;
  s1, s2, s3, s4: String;
  nm: Array[1..32] of Variant;
  v: Double;
begin
  st := 1;
  i := 1;
  nm[1] := 0;
  Result := 0;
  while i <= Length(s) do
  begin
    j := i;
    case s[i] of
      '+':
        nm[st - 2] := nm[st - 2] + nm[st - 1];
      ttOr:
        nm[st - 2] := nm[st - 2] or nm[st - 1];
      '-':
        nm[st - 2] := nm[st - 2] - nm[st - 1];
      '*', ttAnd:
        nm[st - 2] := nm[st - 2] * nm[st - 1];
      '/':
        if nm[st - 1] <> 0 then
          nm[st - 2] := nm[st - 2] / nm[st - 1] else
          nm[st - 2] := 0;
      '>':
        if nm[st - 2] > nm[st - 1] then nm[st - 2] := 1
        else nm[st - 2] := 0;
      '<':
        if nm[st - 2] < nm[st - 1] then nm[st - 2] := 1
        else nm[st - 2] := 0;
      '=':
        if nm[st - 2] = nm[st - 1] then nm[st - 2] := 1
        else nm[st - 2] := 0;
      ttNe:
        if nm[st - 2] <> nm[st - 1] then nm[st - 2] := 1
        else nm[st - 2] := 0;
      ttGe:
        if nm[st - 2] >= nm[st - 1] then nm[st - 2] := 1
        else nm[st - 2] := 0;
      ttLe:
        if nm[st - 2] <= nm[st - 1] then nm[st - 2] := 1
        else nm[st - 2] := 0;
      ttInt:
        begin
          v := nm[st - 1];
          if Abs(Round(v) - v) < 1e-10 then
            v := Round(v) else
            v := Int(v);

          nm[st - 1] := v;
        end;
      ttFrac:
        begin
          v := nm[st - 1];
          if Abs(Round(v) - v) < 1e-10 then
            v := Round(v);

          nm[st - 1] := Frac(v);
        end;
      ttRound:
        nm[st - 1] := Integer(Round(nm[st - 1]));
      ttUnMinus:
        nm[st - 1] := -nm[st - 1];
      ttUnPlus:;
      ttStr:
        begin
          if nm[st - 1] <> Null then
            s1 := nm[st - 1] else
            s1 := '';
          nm[st - 1] := s1;
        end;
      ttNot:
        if nm[st - 1] = 0 then nm[st - 1] := 1 else nm[st - 1] := 0;
      ttMod:
        nm[st - 2] := nm[st - 2] mod nm[st - 1];
      ' ': ;
      '[':
        begin
          k := i;
          s1 := GetBrackedVariable(s, k, i);
          if Assigned(FOnGetValue) then
            FOnGetValue(s1, nm[st]);
          Inc(st);
        end
      else
        begin
          if s[i] = '''' then
          begin
            s1 := GetString(s, i);
            s1 := Copy(s1, 2, Length(s1) - 2);
            while Pos('''' + '''', s1) <> 0 do
              Delete(s1, Pos('''' + '''', s1), 1);
            nm[st] := s1;
            k := i;
          end
          else
          begin
            k := i;
            s1 := GetIdentify(s, k);
            if (s1 <> '') and (s1[1] in ['0'..'9', '.', ',']) then
            begin
              for i1 := 1 to Length(s1) do
                if s1[i1] in ['.', ','] then s1[i1] := DecimalSeparator;
              nm[st] := StrToFloat(s1);
            end
            else if AnsiCompareText(s1, 'TRUE') = 0 then
              nm[st] := True
            else if AnsiCompareText(s1, 'FALSE') = 0 then
              nm[st] := False
            else if s[k] = '[' then
            begin
              s1 := 'GETARRAY(' + s1 + ', ' + GetBrackedVariable(s, k, i) + ')';