rm_parser.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 865 行 · 第 1/2 页

{*****************************************}
{                                         }
{          Report Machine v2.0            }
{             Report Pars                 }
{                                         }
{*****************************************}

unit RM_Parser;

{$I RM.INC}

interface

uses
  Windows, SysUtils, Classes, Forms, DB
  {$IFDEF Delphi6}, Variants{$ENDIF};

type
  TRMGetPValueEvent = procedure(aVariableName: string; var aValue: Variant) of object;
  TRMFunctionEvent = procedure(aFunctionName: string; aParams: array of Variant;
    var val: Variant; var aFound: Boolean) of object;

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

  PRMVariable = ^TRMVariable;
  TRMVariable = record
    Value: Variant;
    IsExpression: Boolean;
  end;

  { TRMVariables }
  TRMVariables = class(TObject)
  private
    FList: TStringList;

    function GetVariable(const Name: string): Variant;
    function GetValue(Index: Integer): Variant;
    function GetName(Index: Integer): string;
    function GetCount: Integer;
    function GetSorted: Boolean;

    procedure SetVariable(const Name: string; Value: Variant);
    procedure SetStringVariable(const Name: string; Value: Variant);
    procedure SetValue(Index: Integer; Value: Variant);
    procedure SetName(Index: Integer; Value: string);
    procedure SetSorted(Value: Boolean);
  public
    constructor Create;
    destructor Destroy; override;

    function IndexOf(const Name: string): Integer;
    procedure Assign(Value: TRMVariables);
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Insert(Index: Integer; const Name: string);

    property Items: TStringList read FList;
    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 AsString[const Name: string]: Variant read GetVariable write SetStringVariable;
    property Count: Integer read GetCount;
    property Sorted: Boolean read GetSorted write SetSorted;
  end;

  // TRMParser 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 TRMParser.Calc(Expression) to get expression value.

   { TRMParser }
  TRMParser = class
  private
    FInScript: Boolean;
    FParentReport: TComponent;
    FOnGetValue: TRMGetPValueEvent;
    FOnFunction: TRMFunctionEvent;
    function GetIdentify(const s: string; var i: Integer): string;
    function GetString(const s: string; var i: Integer): string;
    procedure GetParameters(const s: string; var Index: Integer; var params: array of Variant);
  public
    function Str2OPZ(s: string): string;
    function CalcOPZ(const s: string): Variant;
    function Calc(s: Variant): Variant;

    property ParentReport: TComponent read FParentReport write FParentReport;
    property OnGetValue: TRMGetPValueEvent read FOnGetValue write FOnGetValue;
    property OnFunction: TRMFunctionEvent read FOnFunction write FOnFunction;
    property InScript: Boolean read FInScript write FInScript;
  end;

  // TRMFunctionSplitter 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.
  // TRMFunctionSplitter used when checking if objects has aggregate functions
  // inside.

  TRMFunctionSplitter = class
  protected
    FMatchFuncs, FSplitTo: TStrings;
    FParser: TRMParser;
    FVariables: TRMVariables;
  public
    constructor Create(MatchFuncs, SplitTo: TStrings; Variables: TRMVariables);
    destructor Destroy; override;
    procedure Split(s: string);
  end;

implementation

uses RM_Const, RM_Utils, RM_Class;

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;

  {------------------------------------------------------------------------------}
  {------------------------------------------------------------------------------}
  {TRMVariables}

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

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

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

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

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

procedure TRMVariables.SetStringVariable(const Name: string; Value: Variant);
var
  i: Integer;
  p: PRMVariable;
begin
  i := IndexOf(Name);
  Value := '''' + Value + '''';
  if i >= 0 then
    p := PRMVariable(FList.Objects[i])
  else
  begin
    New(p);
    FList.AddObject(Name, TObject(p));
  end;
  p^.Value := Value;
  p^.IsExpression := True;
end;

function TRMVariables.GetVariable(const Name: string): Variant;
var
  i: Integer;
begin
  i := IndexOf(Name);
  if i >= 0 then
    Result := PRMVariable(FList.Objects[i]).Value
  else
    Result := Null;
end;

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

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

function TRMVariables.IndexOf(const Name: string): Integer;
begin
  Result := FList.IndexOf(Name);
end;

procedure TRMVariables.Insert(Index: Integer; const Name: string);
begin
  SetVariable(Name, 0);
  FList.Move(FList.IndexOf(Name), Index);
end;

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

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

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

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

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

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

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMParser}

function TRMParser.CalcOPZ(const s: string): Variant;
var
  i, j, k, i1, st: Integer;
  s1: string;
  lParams: array[0..10] of Variant;
  nm: array[1..11] of Variant;
  v: Double;
  lFound: Boolean;

  procedure _RMSetNullValue;

    procedure _SetValue(var aValue1: Variant; const aValue2: Variant);
    begin
      if (TVarData(aValue2).VType = varString) or (TVarData(aValue2).VType = varOleStr) then
        aValue1 := ''
      else if TVarData(aValue2).VType = varBoolean then
        aValue1 := False
      else
        aValue1 := 0;
    end;

  begin
		if (FParentReport = nil) or TRMReport(FParentReport).ConvertNulls then Exit;
//    if not RMUseNull then Exit;

    if (nm[st - 2] = Null) or (nm[st - 1] = Null) then
    begin
      if nm[st - 2] = Null then
      begin
        _SetValue(nm[st - 2], nm[st - 1]);
      end
      else if nm[st - 1] = Null then
      begin
        _SetValue(nm[st - 1], nm[st - 2]);
      end;
    end;
  end;

begin
  st := 1;
  i := 1;
  nm[1] := 0;
  while i <= Length(s) do
  begin
    j := i;
    case s[i] of
      '+', ttOr:
        begin
          _RMSetNullValue;
          nm[st - 2] := nm[st - 2] + nm[st - 1];
        end;
      '-':
        begin
          _RMSetNullValue;
          nm[st - 2] := nm[st - 2] - nm[st - 1];
        end;
      '*', ttAnd:
        begin
          _RMSetNullValue;
          nm[st - 2] := nm[st - 2] * nm[st - 1];
        end;
      '/':
        begin
          _RMSetNullValue;
          if nm[st - 1] <> 0 then
            nm[st - 2] := nm[st - 2] / nm[st - 1]
          else
            nm[st - 2] := 0;
        end;
      '>':
        begin
          _RMSetNullValue;
          if nm[st - 2] > nm[st - 1] then
            nm[st - 2] := 1
          else
            nm[st - 2] := 0;
        end;
      '<':
        begin
          _RMSetNullValue;
          if nm[st - 2] < nm[st - 1] then
            nm[st - 2] := 1
          else
            nm[st - 2] := 0;
        end;
      '=':
        begin
          _RMSetNullValue;
          if nm[st - 2] = nm[st - 1] then
            nm[st - 2] := 1
          else
            nm[st - 2] := 0;
        end;
      ttNe:
        begin
          _RMSetNullValue;
          if nm[st - 2] <> nm[st - 1] then
            nm[st - 2] := 1
          else
            nm[st - 2] := 0;
        end;
      ttGe:
        begin
          _RMSetNullValue;
          if nm[st - 2] >= nm[st - 1] then
            nm[st - 2] := 1
          else
            nm[st - 2] := 0;
        end;
      ttLe:
        begin
          _RMSetNullValue;
          if nm[st - 2] <= nm[st - 1] then
            nm[st - 2] := 1
          else
            nm[st - 2] := 0;
        end;
      ttInt:
        begin
          _RMSetNullValue;
          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
          _RMSetNullValue;
          v := nm[st - 1];
          if Abs(Round(v) - v) < 1E-10 then
            v := Round(v);
          nm[st - 1] := Frac(v);
        end;
      ttRound:
        begin
          if nm[st - 1] = Null then
            nm[st - 1] := 0;

          nm[st - 1] := Integer(Round(nm[st - 1]));
        end;
      ttUnMinus:
        begin
          if nm[st - 1] = Null then
            nm[st - 1] := 0;

          nm[st - 1] := -nm[st - 1];
        end;
      ttUnPlus: ;
      ttStr:
        begin
          if nm[st - 1] <> Null then
            s1 := nm[st - 1]
          else
            s1 := '';