fs_iinterpreter.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

    property IsOptional: Boolean read FIsOptional;
    property IsVarParam: Boolean read FIsVarParam;
  end;

{ TfsProcVariable is a local internal procedure/function. Formal parameters
  are in Params, and statement to execute is in Prog: TfsScript }

  TfsProcVariable = class(TfsCustomVariable)
  private
    FExecuting: Boolean;
    FIsFunc: Boolean;
    FProgram: TfsScript;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
    destructor Destroy; override;

    property Executing: Boolean read FExecuting;
    property IsFunc: Boolean read FIsFunc;
    property Prog: TfsScript read FProgram;
  end;

  TfsCustomExpression = class(TfsCustomVariable)
  end;

{ TfsCustomHelper is the generic class for the "helpers". Helper is
  a object that takes the data from the parent object and performs some
  actions. Helpers needed for properties, methods and arrays }

  TfsCustomHelper = class(TfsCustomVariable)
  private
    FParentRef: TfsCustomVariable;
    FParentValue: Variant;
    FProgram: TfsScript;
  public
    property ParentRef: TfsCustomVariable read FParentRef write FParentRef;
    property ParentValue: Variant read FParentValue write FParentValue;
    property Prog: TfsScript read FProgram write FProgram;
  end;

{ TfsArrayHelper performs access to array elements }

  TfsArrayHelper = class(TfsCustomHelper)
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const AName: String; DimCount: Integer; Typ: TfsVarType;
      const TypeName: String);
  end;

{ TfsStringHelper performs access to string elements }

  TfsStringHelper = class(TfsCustomHelper)
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create;
  end;

{ TfsPropertyHelper gets/sets the property value. Object instance is
  stored as Integer in the ParentValue property }

  TfsPropertyHelper = class(TfsCustomHelper)
  private
    FClassRef: TClass;
    FIsPublished: Boolean;
    FOnGetValue: TfsGetValueEvent;
    FOnSetValue: TfsSetValueEvent;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    property IsPublished: Boolean read FIsPublished;
    property OnGetValue: TfsGetValueEvent read FOnGetValue write FOnGetValue;
    property OnSetValue: TfsSetValueEvent read FOnSetValue write FOnSetValue;
  end;

{ TfsMethodHelper gets/sets the method value. Object instance is
  stored as Integer in the ParentValue property. SetValue is called
  if the method represents the indexes property. }

  TfsMethodHelper = class(TfsCustomHelper)
  private
    FCategory: String;
    FClassRef: TClass;
    FDescription: String;
    FIndexMethod: Boolean;
    FOnCall: TfsCallMethodEvent;
    FSyntax: String;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const Syntax: String; CallEvent: TfsCallMethodEvent;
      Script: TfsScript);

    property Category: String read FCategory write FCategory;
    property Description: String read FDescription write FDescription;
    property IndexMethod: Boolean read FIndexMethod;
    property Syntax: String read FSyntax;
    property OnCall: TfsCallMethodEvent read FOnCall write FOnCall;
  end;

{ TfsComponentHelper gets the component inside an owner, e.g. Form1.Button1 }

  TfsComponentHelper = class(TfsCustomHelper)
  private
    FComponent: TComponent;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(Component: TComponent);
  end;

{ Event helper maintains VCL events }

  TfsCustomEvent = class(TObject)
  private
    FHandler: TfsProcVariable;
    FInstance: TObject;
  protected
    procedure CallHandler(Params: array of const);
  public
    constructor Create(AObject: TObject; AHandler: TfsProcVariable); virtual;
    function GetMethod: Pointer; virtual; abstract;
    property Handler: TfsProcVariable read FHandler;
    property Instance: TObject read FInstance;
  end;

  TfsEventClass = class of TfsCustomEvent;

  TfsEventHelper = class(TfsCustomHelper)
  private
    FClassRef: TClass;
    FEvent: TfsEventClass;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const Name: String; AEvent: TfsEventClass);
  end;

{ TfsClassVariable holds information about external class. Call to
  AddXXX methods adds properties and methods items to the items list }

  TfsClassVariable = class(TfsCustomVariable)
  private
    FAncestor: String;
    FClassRef: TClass;
    FDefProperty: TfsCustomHelper;
    FMembers: TfsItemList;
    FProgram: TfsScript;
    procedure AddComponent(c: TComponent);
    procedure AddPublishedProperties(AClass: TClass);
    function GetMembers(Index: Integer): TfsCustomHelper;
    function GetMembersCount: Integer;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(AClass: TClass; const Ancestor: String);
    destructor Destroy; override;

    { Adds a contructor. Example:
        AddConstructor('constructor Create(AOwner: TComponent)', MyCallEvent) }
    procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
    { Adds a property. Example:
        AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) }
    procedure AddProperty(const Name, Typ: String;
      GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil);
    { Adds a default property. Example:
        AddDefaultProperty('Cell', 'Integer,Integer', 'String', MyCallEvent)
      will describe real property Cell[Index1, Index2: Integer]: String
      Note: in the CallEvent you'll get the MethodName parameter
      'CELL.GET' and 'CELL.SET', not 'CELL' }
    procedure AddDefaultProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
    { Adds an indexed property. Example and behavior are the same as
      for AddDefaultProperty }
    procedure AddIndexProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
    { Adds a method. Example:
        AddMethod('function IsVisible: Boolean', MyCallEvent) }
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
    { Adds an event. Example:
        AddEvent('OnClick', TfsNotifyEvent) }
    procedure AddEvent(const Name: String; AEvent: TfsEventClass);
    function Find(const Name: String): TfsCustomHelper;

    property Ancestor: String read FAncestor;
    property ClassRef: TClass read FClassRef;
    property DefProperty: TfsCustomHelper read FDefProperty;
    property Members[Index: Integer]: TfsCustomHelper read GetMembers;
    property MembersCount: Integer read GetMembersCount;
  end;

{ TfsDesignator holds the parts of function/procedure/variable/method/property
  calls. Items are of type TfsDesignatorItem.
  For example, Table1.FieldByName('N').AsString[1] will be represented as
    items[0]: name 'Table1', no params
    items[1]: name 'FieldByName', 1 param: 'N'
    items[2]: name 'AsString', no params
    items[3]: name '[', 1 param: '1'
  Call to Value calculates and returns the designator value }

  TfsDesignatorKind = (dkOther, dkVariable, dkStringArray, dkArray);

  TfsDesignatorItem = class(TfsItemList)
  private
    FFlag: Boolean;          { needed for index methods }
    FRef: TfsCustomVariable;
    FSourcePos: String;
    function GetItem(Index: Integer): TfsCustomExpression;
  public
    property Items[Index: Integer]: TfsCustomExpression read GetItem; default;
    property Flag: Boolean read FFlag write FFlag;
    property Ref: TfsCustomVariable read FRef write FRef;
    property SourcePos: String read FSourcePos write FSourcePos;
  end;

  TfsDesignator = class(TfsCustomVariable)
  private
    FKind: TfsDesignatorKind;
    FMainProg: TfsScript;
    FProgram: TfsScript;
    FRef1: TfsCustomVariable;
    FRef2: TfsDesignatorItem;
    FLateBindingXmlSource: TfsXMLItem;
    procedure CheckLateBinding;
    function DoCalc(const AValue: Variant; Flag: Boolean): Variant;
    function GetItem(Index: Integer): TfsDesignatorItem;
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  public
    constructor Create(AProgram: TfsScript);
    procedure Borrow(ADesignator: TfsDesignator);
    procedure Finalize;
    property Items[Index: Integer]: TfsDesignatorItem read GetItem; default;
    property Kind: TfsDesignatorKind read FKind;
    property LateBindingXmlSource: TfsXMLItem read FLateBindingXmlSource
      write FLateBindingXmlSource;
  end;

  TfsVariableDesignator = class(TfsDesignator)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  end;

  TfsStringDesignator = class(TfsDesignator)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  end;

  TfsArrayDesignator = class(TfsDesignator)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  end;

{ TfsSetExpression represents a set of values like ['_', '0'..'9'] }

  TfsSetExpression = class(TfsCustomVariable)
  private
    function GetItem(Index: Integer): TfsCustomExpression;
  protected
    function GetValue: Variant; override;
  public
    function Check(const Value: Variant): Boolean;
    property Items[Index: Integer]: TfsCustomExpression read GetItem;
  end;

{ TfsEventList maintains all event handlers attached to a VCL controls }

  TfsEventList = class(TfsItemList)
  public
    procedure FreeObjectEvents(Instance: TObject);
  end;


function fsGlobalUnit: TfsScript;
function fsEventList: TfsEventList;


implementation

//{$DEFINE Trial}

uses
  TypInfo, fs_isysrtti, fs_iexpression, fs_iparser, fs_iilparser,
  fs_itools, fs_iconst
{$IFDEF CLX}
, QForms, QDialogs, Types
{$ELSE}
  {$IFDEF NOFORMS}
, Windows, Messages
  {$ELSE}
, Windows, Forms, Dialogs
  {$ENDIF}
{$ENDIF};


var
  FGlobalUnit: TfsScript;
  FEventList: TfsEventList;
  FGlobalUnitDestroyed: Boolean = False;


{ TfsItemsList }

constructor TfsItemList.Create;
begin
  FItems := TList.Create;
end;

destructor TfsItemList.Destroy;
begin
  Clear;
  FItems.Free;
  inherited;
end;

procedure TfsItemList.Clear;
begin
  while FItems.Count > 0 do
  begin
    TObject(FItems[0]).Free;
    FItems.Delete(0);
  end;
end;

function TfsItemList.Count: Integer;
begin
  Result := FItems.Count;
end;

procedure TfsItemList.Add(Item: TObject);
begin
  FItems.Add(Item);
end;

procedure TfsItemList.Remove(Item: TObject);
begin
  FItems.Remove(Item);
end;


{ TfsCustomVariable }

constructor TfsCustomVariable.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String);
begin
  inherited Create;
  FName := AName;
  FTyp := ATyp;
  FTypeName := ATypeName;
  FValue := Null;
  FNeedResult := True;
end;

function TfsCustomVariable.GetValue: Variant;
begin
  Result := FValue;
end;

procedure TfsCustomVariable.SetValue(const Value: Variant);
begin
  if not FIsReadOnly then
    if FTyp = fvtFloat then
      FValue := VarAsType(Value, varDouble)
    else
      FValue := Value;
end;

function TfsCustomVariable.GetParam(Index: Integer): TfsParamItem;
begin
  Result := FItems[Index];
end;

function TfsCustomVariable.GetPValue: PVariant;
begin
  Result := @FValue;
end;

function TfsCustomVariable.GetFullTypeName: String;
begin
  case FTyp of
    fvtInt: Result := 'Integer';
    fvtBool: Result := 'Boolean';
    fvtFloat: Result := 'Extended';
    fvtChar: Result := 'Char';
    fvtString: Result := 'String';
    fvtClass: Result := 'Class ' + FTypeName;
    fvtArray: Result := 'Array';
    fvtEnum: Result := FTypeName;
  else
    Result := 'Variant';
  end;
end;

function TfsCustomVariable.GetNumberOfRequiredParams: Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to Count - 1 do
    if not Params[i].IsOptional then
      Inc(Result);
end;


{ TfsStringVariable }

function TfsStringVariable.GetValue: Variant;
begin
  Result := FStr;
end;

procedure TfsStringVariable.SetValue(const Value: Variant);
begin
  FStr := Value;
end;


{ TfsParamItem }

constructor TfsParamItem.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
begin
  inherited Create(AName, ATyp, ATypeName);
  FIsOptional := AIsOptional;
  FIsVarParam := AIsVarParam;
  FDefValue := Null;
end;


{ TfsProcVariable }

constructor TfsProcVariable.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
begin
  inherited Create(AName, ATyp, ATypeName);
  FIsReadOnly := True;
  FIsFunc := AIsFunc;
  FProgram := TfsScript.Create(nil);
  FProgram.Parent := AParent;
  if FIsFunc then
  begin
    FRefItem := TfsVariable.Create('Result', ATyp, ATypeName);
    FProgram.Add('Result', FRefItem);
  end;
end;

destructor TfsProcVariable.Destroy;
var
  i: Integer;
begin
  { avoid destroying the param objects twice }
  for i := 0 to Count - 1 do
    FProgram.FItems.Delete(FProgram.FItems.IndexOfObject(Params[i]));

  FProgram.Free;
  inherited;
end;

function TfsProcVariable.GetValue: Variant;
var
  Temp: Boolean;
  ParentProg, SaveProg: TfsScript;
begin
  Temp := FExecuting;
  FExecuting := True;

  ParentProg := FProgram;
  SaveProg := nil;
  while ParentProg <> nil do
    if ParentProg.FMainProg then
    begin
      SaveProg := ParentProg.FProgRunning;
      ParentProg.FProgRunning := FProgram;
      break;
    end
    else
      ParentProg := ParentProg.FParent;