qrexpr.pas

delphi7报表打印控件源码 可以设计报表

{ :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  :: QuickReport 4.0 for Delphi and C++Builder               ::
  ::                                                         ::
  :: QRExpr - EXPRESSION EVALUATOR                           ::
  ::                                                         ::
  :: Copyright (c) 2003 A Lochert / QBS Software             ::
  :: All Rights Reserved                                     ::
  ::                                                         ::
  :: web: http://www.qusoft.com                              ::
  ::                                                         ::
  ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: }

{$I QRDEFS.INC}

unit QRExpr;

{$R-}
{$T-}
{$B-}

interface

uses
  Windows, Sysutils, Classes, DB, Forms, Math, QR4Const;

type
  TQRLibraryItemClass = class of TObject;

  TQRLibraryEntry = class
  private
    FDescription : string;
    FData : string;
    FItem : TQRLibraryItemClass;
    FName : string;
    FVendor : string;
  public
    property Data : string read FData write FData;
    property Description : string read FDescription write FDescription;
    property Name : string read FName write FName;
    property Vendor : string read FVendor write FVendor;
    property Item : TQRLibraryItemClass read FItem write FItem;
  end;

  TQRLibrary = class
  protected
    Entries : TStrings;
    function GetEntry(Index : integer) : TQRLibraryEntry; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(aItem : TQRLibraryItemClass; AName, ADescription, AVendor, AData : string);
    property EntryList : TStrings read Entries write Entries;
    property Entry[Index : integer] : TQRLibraryEntry read GetEntry;
  end;

  TQREvElementFunction = class;
  TQREvElement = class;
  TQREvEnvironment = class;
  TQREvaluator = class;

  TQREvOperator = (opLess, opLessOrEqual, opGreater, opGreaterOrEqual, opEqual,
                   opUnequal, opPlus, opMinus, opOr, opMul, opDiv, opAnd);

  TQREvResultType = (resInt, resDouble, resString, resBool, resError);

  TQREvResult = record
    case Kind : TQREvResultType of
      resInt    : (intResult : longint);
      resDouble : (dblResult : double);
      resString : (strResult : string[255]);
      resBool   : (booResult : boolean);
  end;

  TQREvResultClass = class
  public
    EvResult : TQREvResult;
  end;

  TQRFiFo = class
  private
    FAggreg : boolean;
    FiFo : TList;
    FNextItem : integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Put(Value : TObject);
    procedure Start;
    function Get : TObject;
    function GetAndFree : TObject;
    property Aggreg : boolean read FAggreg write FAggreg;
  end;

  TQREvElement = class
  private
    FIsAggreg : boolean;
  public
    constructor Create; virtual;
    function Value(FiFo : TQRFiFo) : TQREvResult; virtual;
    procedure Reset; virtual;
    property IsAggreg : boolean read FIsAggreg write FIsAggreg;
  end;

  TQREvElementFunction = class(TQREvElement)
  private
  protected
    ArgList : TList;
    function ArgumentOK(Value : TQREvElement) : boolean;
    function Argument(Index : integer) : TQREvResult;
    procedure FreeArguments;
    procedure GetArguments(FiFo : TQRFiFo);
    procedure Aggregate; virtual;
    function Calculate : TQREvResult; virtual;
  public
    constructor Create; override;
    destructor Destroy; override;
    function FunctionName : string; virtual;
    function FunctionDescription : string; virtual;
    function FunctionVendor : string; virtual;
    function FunctionArguments : string; virtual;
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
  end;

  TQREvElementFunctionClass = class of TQREvElementFunction;

  {$warnings off}
  TQREvElementWrapper = class(TQREvElement)
  private
    FEmbeddedFunction : TQREvElement;
  public
    constructor Create(AEmbeddedFunction : TQREvElement);
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
    property EmbeddedFunction : TQREvElement read FEmbeddedFunction;
  end;

  TQREvEmbeddedFunction = class(TQREvElement)
  private
    Evaluator : TQREvaluator;
    FExpression : string;
    FInEvaluate : boolean;
  public
    constructor Create(Expression : string);
    destructor Destroy; override;
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
    procedure Reset; override;
    function Peek(Index : integer) : TQREvElement;
    function Expression : string;
  end;
  {$warnings on}

  TQREvElementArgumentEnd = class(TQREvElement);

  TQREvElementDataField = class(TQREvElement)
  private
    FDataSet : TDataSet;
    FFieldNo : integer;
    FField : TField;
  public
    constructor CreateField(aField : TField); virtual;
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
  end;

  {$warnings off}
  TQREvElementError = class(TQREvElement)
  private
    FErrorMessage : string;
  public
    constructor Create(ErrorMessage : string);
    function Value(FiFo : TQRFiFo) : TQREvResult; override;
  end;
  {$warnings on}

  { TQREvaluator }
  TQREvaluator = class (TObject)
  private
    OwnDataSets : TList;
    FDataSets : TList;
    FiFo : TQRFiFo;
    FPrepared : boolean;
    FEnvironment : TQREvEnvironment;
    function  EvalEnvironment(strVariable : string) : TQREvResult;
    function  EvalFunctionExpr(const strFunc : string) : TQREvResult;
    function  EvalSimpleExpr(const strSimplExpr : string) : TQREvResult;
    function  EvalTerm(const strTermExpr : string) : TQREvResult;
    function  EvalFactor(strFactorExpr : string) : TQREvResult;
    function  EvalString(const strString : string) : TQREvResult;
    function  EvalConstant(const strConstant : string) : TQREvResult;
    function  GetAggregate : boolean;
    function  Evaluate(const strExpr : string) : TQREvResult;
    procedure FindDelimiter(strArg : string; var Pos : integer);
    procedure SetAggregate(Value : boolean);
    procedure TrimString(var strString : string);
  protected
    function EvalFunction(strFunc : string; const strArg : string) : TQREvResult; virtual;
    function EvalVariable(strVariable : string) : TQREvResult; virtual;
    function GetIsAggreg : boolean;
    function GetDatasets : TList;
    procedure SetDatasets(Value : TList);
  public
    constructor Create;
    destructor Destroy; override;
    function Calculate(const StrExpr : string) : TQREvResult;
    function Value : TQREvResult;
    function AsString : string;
    function AsInteger : integer;
    function AsFloat : extended;
    function AsBoolean : boolean;
    function AsVariant : Variant;
    procedure Prepare(const StrExpr : string);
    procedure Reset;
    procedure UnPrepare;
    procedure DoAggregate;
    property Environment : TQREvEnvironment read FEnvironment write FEnvironment;
    property IsAggreg : boolean read GetIsAggreg;
    property Aggregate : boolean read GetAggregate write SetAggregate;
    property DataSets : TList read GetDatasets write SetDataSets;
    property Prepared : boolean read FPrepared write FPrepared;
  end;

  { TQREvEnvironment }
  TQREvEnvironment = class(TStringList)
  private
    PrepareCount : integer;
    OwnDataSets : TList;
    FDatasets : TList;
  protected
    procedure DefineProperties(Filer : TFiler); override;
    procedure ReadProperties(Reader : TReader);
    procedure WriteProperties(Writer : TWriter);
    function GetDatasets : TList;
    procedure SetDatasets(Value : TList);
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddFunction(AName, AExpression : string);
    procedure Clear; override;
    procedure DeleteFunction(AName : string);
    procedure Update;
    procedure Prepare;
    procedure UpdateConstant(Name : string; Value : TQREvResult);
    procedure SetConstant(Constant : TQREvElement; Value : TQREvResult);
    procedure SetStringConstant(Constant : TQREvElement; Value : string);
    procedure SetIntegerConstant(Constant : TQREvElement; Value : integer);
    procedure SetFloatConstant(Constant : TQREvElement; Value : double);
    procedure SetBooleanConstant(Constant : TQREvElement; Value : boolean);
    procedure Unprepare;
    function Prepared : boolean;
    function Value(Name : string) : TQREvResult;
    function Element(Name : string) : TQREvElement;
    function GetConstant(Name : string) : TQREvElement;
    property Datasets : TList read GetDatasets write SetDatasets;
  end;

  { TQRFunctionLibrary }
  TQRFunctionLibrary = class(TQRLibrary)
  public
    function GetFunction(Name : string) : TQREvElement;
  end;

  procedure UpdateConstant(AConstant : TQREvElement; Value : TQREvResult);

  procedure RegisterQRFunction(FunctionClass : TQRLibraryItemClass; Name, Description, Vendor, Arguments : string);
  procedure RegisterQRFunctionEx(FunctionClass : TQRLibraryItemClass);
  
  function QREvResultToString(const AValue : TQREvResult) : string;
  function QREvResultToInt(const AValue : TQREvResult) : integer;
  function QREvResultToFloat(const AValue : TQREvResult) : extended;
  function QREvResultToVariant(const AValue : TQREvResult) : Variant;

  function QRGlobalEnvironment : TQREvEnvironment;

var
  ArgSeparator : Char;
  QRFunctionLibrary : TQRFunctionLibrary;
  UnpreparingGlobalEnvironment : boolean;

implementation

uses
  StrUtils;

var
  FGlobalEnvironment : TQREvEnvironment;

function QREvResultToString(const AValue : TQREvResult) : string;
begin
  case AValue.Kind of
    resString : Result := AValue.StrResult;
    resInt : Result := IntToStr(AValue.IntResult);
    resDouble : Result := FloatToStr(AValue.DblResult);
    resBool : if AValue.booResult then
                   Result := SqrTrue
                 else
                   Result := SqrFalse;
  else
    Raise Exception.Create(Format(SqrExpError, [AValue.strResult]));
  end;
end;

function QREvResultToInt(const AValue : TQREvResult) : integer;
begin
  case AValue.Kind of
    resInt : Result := AValue.IntResult;
    resDouble : Result := Round(AValue.DblResult);
  else
    Raise Exception.Create(Format(SqrNotValue, [SqrExpNumeric]));
  end;
end;

function QREvResultToFloat(const AValue : TQREvResult) : extended;
begin
  case AValue.Kind of
    resInt : Result := AValue.IntResult;
    resDouble : Result := AValue.DblResult;
  else
    Raise Exception.Create(Format(SqrNotValue, [SqrExpNumeric]));
  end;
end;

function QREvResultToBoolean(const AValue : TQREvResult) : boolean;
begin
  case AValue.Kind of
    resBool : Result := AValue.BooResult;
    resString : if AnsiUppercase(AValue.StrResult) = 'TRUE' then // Do not translate
                  Result := true
                else
                  if AnsiUppercase(AValue.StrResult) = 'FALSE' then // Do not translate
                    Result := false
                  else
                    Raise Exception.Create(Format(SqrNotValue, [SqrExpBoolean]));
  else
    Raise Exception.Create(Format(SqrNotValue, [SqrExpBoolean]));
  end;
end;

function QREvResultToVariant(const AValue : TQREvResult) : Variant;
begin
  case AValue.Kind of
    resString : Result := AValue.StrResult;
    resInt : Result := AValue.IntResult;
    resDouble : Result := AValue.dblResult;
    resBool : Result := AValue.BooResult;
  else
    Raise Exception.Create(Format(SqrExpError, [AValue.StrResult]));
  end;
end;


function QRGlobalEnvironment : TQREvEnvironment;
begin
  Result := FGlobalEnvironment;
end;

{ TQRLibrary }

constructor TQRLibrary.Create;
begin
  inherited Create;
  Entries := TStringList.Create;
end;

destructor TQRLibrary.Destroy;
var
  I : integer;
begin
  for I := 0 to Entries.Count - 1 do
    Entries.Objects[I].Free;
  Entries.Free;
  inherited Destroy;
end;

procedure TQRLibrary.Add(aItem : TQRLibraryItemClass; AName, ADescription, AVendor, AData : string);
var
  aLibraryEntry : TQRLibraryEntry;
begin
  aLibraryEntry := TQRLibraryEntry.Create;
  with aLibraryEntry do
  begin
    Name := AName;
    Description := ADescription;
    Vendor := AVendor;
    Data := AData;
    Item := aItem;
  end;
  Entries.AddObject(aName,aLibraryEntry);
end;

function TQRLibrary.GetEntry(Index : integer) : TQRLibraryEntry;
begin
  if Index <= Entries.Count then
    result := TQRLibraryEntry(Entries.Objects[Index])
  else
    result := nil;
end;

{ TQRFunctionLibrary }

function TQRFunctionLibrary.GetFunction(Name : string) : TQREvElement;
var
  I : integer;
  AObject : TQREvElementFunctionClass;
  aLibraryEntry : TQRLibraryEntry;
begin
  I := Entries.IndexOf(Name);
  if I >= 0 then
  begin
    aLibraryEntry := TQRLibraryEntry(Entry[I]);
    aObject := TQREvElementFunctionClass(aLibraryEntry.Item);
    result := aObject.Create;
  end else
    result := TQREvElementError.Create(Format(SqrExpUnknownFunction, [Name]));
end;

{ TQREvaluator }

constructor TQRFiFo.Create;
begin
  FiFo := TList.Create;
  FAggreg := false;
  FNextItem := 0;
end;

destructor TQRFiFo.Destroy;
var
  I : integer;
begin
  for I := 0 to FiFo.Count-1 do
    TObject(FiFo[I]).Free;
  FiFo.Free;
  inherited Destroy;
end;

procedure TQRFiFo.Start;
begin
  FNextItem := 0;
end;

procedure TQRFiFo.Put(Value : TObject);
begin
  FiFo.Add(Value);
end;

function TQRFiFo.GetAndFree : TObject;
begin
  if FiFo.Count>0 then
  begin
    result := FiFo[0];
    FiFo.Delete(0);
  end else
    result := nil;
end;

function TQRFiFo.Get : TObject;
begin
  if FNextItem<FiFo.Count then
  begin
    result := FiFo[FNextItem];
    inc(FNextItem);
  end else
    result := nil;
end;