fs_iinterpreter.pas

这个是功能强大的报表软件

    FIsMacro: Boolean;
    FIsReadOnly: Boolean;
    FName: String;
    FNeedResult: Boolean;
    FRefItem: TfsCustomVariable;
    FSourcePos: String;
    FSourceUnit: String;
    FTyp: TfsVarType;
    FTypeName: String;
    FUppercaseName: String;
    FValue: Variant;
    FOnGetVarValue: TfsGetVariableValueEvent;
    function GetParam(Index: Integer): TfsParamItem;
    function GetPValue: PVariant;
  protected
    procedure SetValue(const Value: Variant); virtual;
    function GetValue: Variant; virtual;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String);
    function GetFullTypeName: String;
    function GetNumberOfRequiredParams: Integer;

    property AddedBy: TObject read FAddedBy write FAddedBy;
    property IsMacro: Boolean read FIsMacro write FIsMacro;
    property IsReadOnly: Boolean read FIsReadOnly write FIsReadOnly;
    property Name: String read FName;
    property NeedResult: Boolean read FNeedResult write FNeedResult;
    property Params[Index: Integer]: TfsParamItem read GetParam; default;
    property PValue: PVariant read GetPValue;
    property RefItem: TfsCustomVariable read FRefItem write FRefItem;
    property SourcePos: String read FSourcePos write FSourcePos;
    property SourceUnit: String read FSourceUnit write FSourceUnit;
    property Typ: TfsVarType read FTyp write FTyp;
    property TypeName: String read FTypeName write FTypeName;
    property Value: Variant read GetValue write SetValue;
    property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue;
  end;

{ TfsVariable represents constant or variable }

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

  TfsTypeVariable = class(TfsCustomVariable)
  end;

  TfsStringVariable = class(TfsVariable)
  private
    FStr: String;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  end;

{ TfsParamItem describes one parameter of procedure/function/method call }

  TfsParamItem = class(TfsCustomVariable)
  private
    FDefValue: Variant;
    FIsOptional: Boolean;
    FIsVarParam: Boolean;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
    property DefValue: Variant read FDefValue write FDefValue;
    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);
    destructor Destroy; override;
  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;
    FOnGetValueNew: TfsGetValueNewEvent;
    FOnSetValueNew: TfsSetValueNewEvent;
  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;
    property OnGetValueNew: TfsGetValueNewEvent read FOnGetValueNew write FOnGetValueNew;
    property OnSetValueNew: TfsSetValueNewEvent read FOnSetValueNew write FOnSetValueNew;
  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;
    FOnCallNew: TfsCallMethodNewEvent;
    FSetValue: Variant;
    FSyntax: String;
    FVarArray: Variant;
    function GetVParam(Index: Integer): Variant;
    procedure SetVParam(Index: Integer; const Value: Variant);
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const Syntax: String; Script: TfsScript);
    destructor Destroy; override;

    property Category: String read FCategory write FCategory;
    property Description: String read FDescription write FDescription;
    property IndexMethod: Boolean read FIndexMethod;
    property Params[Index: Integer]: Variant read GetVParam write SetVParam; default;
    property Syntax: String read FSyntax;
    property OnCall: TfsCallMethodEvent read FOnCall write FOnCall;
    property OnCallNew: TfsCallMethodNewEvent read FOnCallNew write FOnCallNew;
  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: TfsCallMethodNewEvent); overload;
    procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent); overload;
    { Adds a property. Example:
        AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) }
    procedure AddProperty(const Name, Typ: String;
      GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil);
    procedure AddPropertyEx(const Name, Typ: String;
      GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent = 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: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload;
    procedure AddDefaultProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload;
    { Adds an indexed property. Example and behavior are the same as
      for AddDefaultProperty }
    procedure AddIndexProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload;
    procedure AddIndexProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload;
    { Adds a method. Example:
        AddMethod('function IsVisible: Boolean', MyCallEvent) }
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent); overload;
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent); overload;
    { 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);
    destructor Destroy; override;
    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;

  TfsRTTIModule = class(TObject)
  private
    FScript: TfsScript;
  public
    constructor Create(AScript: TfsScript); virtual;
    property Script: TfsScript read FScript;
  end;


function fsGlobalUnit: TfsScript;
function fsRTTIModules: TList;


implementation

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

var
  FGlobalUnit: TfsScript = nil;
  FGlobalUnitDestroyed: Boolean = False;
  FRTTIModules: TList = nil;
  FRTTIModulesDestroyed: 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;
  FUppercaseName := AnsiUppercase(FName);