rm_jvinterpreter.pas.~3~

这是一个功能强大

    destructor Destroy; override;
  end;

  TJvInterpreterEventClass = class of TJvInterpreterEvent;

  { variable holder }
  TJvInterpreterVar = class(TObject)
  public
    UnitName: string;
    Identifier: string;
    Typ: string;
    VTyp: Word;
    Value: Variant;
  public
    destructor Destroy; override;
  end;

  { variables list }
  TJvInterpreterVarList = class(TList)
  public
    destructor Destroy; override;
    procedure Clear; override;
    procedure AddVar(const UnitName, Identifier, Typ: string; VTyp: Word;
      const Value: Variant; DataType: IJvInterpreterDataType);
    function FindVar(const UnitName, Identifier: string): TJvInterpreterVar;
    procedure DeleteVar(const UnitName, Identifier: string);
    function GetValue(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean;
    function SetValue(const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean;
    procedure Assign(source: TJvInterpreterVarList);
  end;
 { notes about TJvInterpreterVarList implementation:
   - list must allow to contain more than one Var with same name;
   - FindVar must return last added Var with given name;
   - DeleteVar must delete last added Var with given name; }

  TJvInterpreterIdentifier = class(TObject)
  public
    UnitName: string;
    Identifier: string;
    Data: Pointer; // provided by user when call to adapter's addxxx methods
  end;

  TJvInterpreterIdentifierList = class(TList)
  private
    FDuplicates: TDuplicates;
  public
    function IndexOf(const UnitName, Identifier: string): TJvInterpreterIdentifier;
    function Find(const Identifier: string; var Index: Integer; const ClassName: string = ''): Boolean;
    procedure Sort(Compare: TListSortCompare = nil); virtual;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  end;

  TJvInterpreterMethodList = class(TJvInterpreterIdentifierList)
  public
    procedure Sort(Compare: TListSortCompare = nil); override;
  end;

  IJvInterpreterDataType = interface
    ['{8C5E4071-65AB-11D7-B235-00A0D2043DC7}']
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  //move from implementation section to  interface section
  TParamCount = -1..cJvInterpreterMaxArgs;

  TCallConvention = set of (ccFastCall, ccStdCall, ccCDecl, ccDynamic,
    ccVirtual, ccClass);

  { Adapter classes - translates data from rm_JvInterpreter calls to Delphi functions }
  TJvInterpreterSrcUnit = class(TJvInterpreterIdentifier)
  private
    FSource: string;
    FUsesList: TNameArray;
  public
    {$IFNDEF BCB}
    function UsesList: TNameArray;
    {$ENDIF}
    property Source: string read FSource;
    // Removed because BCB doesn't support it
    //property UsesList: TNameArray read FUsesList;
  end;

  TJvInterpreterMethod = class(TJvInterpreterIdentifier)
  protected
    FClassType: TClass;
    ParamCount: TParamCount;
    ParamTypes: TTypeArray; { varInteger, varString, .. }
    ResTyp: Word; { varInteger, varString, .. }
    Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }
  end;

  TJvInterpreterIntfMethod = class(TJvInterpreterIdentifier)
  protected
    IID: TGUID;
    ParamCount: TParamCount;
    ParamTypes: TTypeArray; { varInteger, varString, .. }
    ResTyp: Word; { varInteger, varString, .. }
    Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }
  end;

  TJvInterpreterDMethod = class(TJvInterpreterMethod)
  protected
    ResTyp: Word;
    CallConvention: TCallConvention;
  end;

  TJvInterpreterClass = class(TJvInterpreterIdentifier)
  private
    FClassFields:TJvInterpreterVarList;   
  protected
    FClassType: TClass;
  public
    property ClassFields:TJvInterpreterVarList read FClassFields;
    constructor Create;
    destructor Destroy; override;
  end;

  TJvInterpreterConst = class(TJvInterpreterIdentifier)
  protected
    Value: Variant;
  end;

  TJvInterpreterRecFields = array [0..cJvInterpreterMaxRecFields] of TJvInterpreterRecField;

  TJvInterpreterRecord = class(TJvInterpreterIdentifier)
  protected
    RecordSize: Integer; { SizeOf(Rec^) }
    FieldCount: Integer;
    Fields: TJvInterpreterRecFields;
    CreateFunc: TJvInterpreterAdapterNewRecord;
    DestroyFunc: TJvInterpreterAdapterDisposeRecord;
    CopyFunc: TJvInterpreterAdapterCopyRecord;
    procedure AddField(const UnitName, Identifier, Typ: string; VTyp: Word;
      const Value: Variant; DataType: IJvInterpreterDataType);
    procedure NewRecord(var Value: Variant);
  end;

  TJvInterpreterRecMethod = class(TJvInterpreterIdentifier)
  protected
    JvInterpreterRecord: TJvInterpreterRecord;
    ParamCount: TParamCount;
    ParamTypes: TTypeArray; { varInteger, varString and so one .. }
    ResTyp: Word; { varInteger, varString, .. }
    Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }
  end;

  TJvInterpreterRecHolder = class(TJvInterpreterIdentifier)
  protected
    FRecordType: string;
    JvInterpreterRecord: TJvInterpreterRecord;
    Rec: Pointer; { data }
  public
    constructor Create(const ARecordType: string; ARec: Pointer);
    destructor Destroy; override;
    property RecordType: string read FRecordType;
  end;

  TJvInterpreterArrayValues = array [0..JvInterpreter_MAX_ARRAY_DIMENSION - 1] of Integer;

  PJvInterpreterArrayRec = ^TJvInterpreterArrayRec;
  TJvInterpreterArrayRec = packed record
    Dimension: Integer; {number of dimensions}
    BeginPos: TJvInterpreterArrayValues; {starting range for all dimensions}
    EndPos: TJvInterpreterArrayValues; {ending range for all dimensions}
    ItemType: Integer; {array type}
    DT: IJvInterpreterDataType;
    ElementSize: Integer; {size of element in bytes}
    Size: Integer; {number of elements in array}
    Memory: Pointer; {pointer to memory representation of array}
  end;

  { interpreter function }
  TJvInterpreterSrcFunction = class(TJvInterpreterIdentifier)
  private
    FFunctionDesc: TJvInterpreterFunctionDesc;
  public
    constructor Create;
    destructor Destroy; override;
    property FunctionDesc: TJvInterpreterFunctionDesc read FFunctionDesc; //Move From Private section
  end;

  { external function }
  TJvInterpreterExtFunction = class(TJvInterpreterSrcFunction)
  protected
    DllInstance: HINST;
    DllName: string;
    FunctionName: string;
    {or}
    FunctionIndex: Integer;
    function CallDll(Args: TJvInterpreterArgs): Variant;
  end;

  TJvInterpreterEventDesc = class(TJvInterpreterIdentifier)
  protected
    EventClass: TJvInterpreterEventClass;
    Code: Pointer;
  end;

  TJvInterpreterRecordDataType = class(TInterfacedObject, IJvInterpreterDataType)
  protected
    FRecordDesc: TJvInterpreterRecord;
  public
    constructor Create(ARecordDesc: TJvInterpreterRecord);
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  TJvInterpreterArrayDataType = class(TInterfacedObject, IJvInterpreterDataType)
  protected
    FArrayBegin, FArrayEnd: TJvInterpreterArrayValues;
    FDimension: Integer;
    FArrayType: Integer;
    FDT: IJvInterpreterDataType;
  public
    constructor Create(AArrayBegin, AArrayEnd: TJvInterpreterArrayValues;
      ADimension: Integer; AArrayType: Integer; ADT: IJvInterpreterDataType);
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  TJvInterpreterSimpleDataType = class(TInterfacedObject, IJvInterpreterDataType)
  protected
    FTyp: TVarType;
  public
    constructor Create(ATyp: TVarType);
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  PMethod = ^TMethod;

  { function context - stack }
  PFunctionContext = ^TFunctionContext;
  TFunctionContext = record
    PrevFunContext: PFunctionContext;
    LocalVars: TJvInterpreterVarList;
    Fun: TJvInterpreterSrcFunction;
  end;

  { TJvInterpreterAdapter - route rm_JvInterpreter calls to Delphi functions }
  TJvInterpreterAdapter = class(TObject)
  private
    FOwner: TJvInterpreterExpression;
    FSrcUnitList: TJvInterpreterIdentifierList; // rm_JvInterpreter-units sources
    FExtUnitList: TJvInterpreterIdentifierList; // internal units; like "system" in delphi
    FGetList: TJvInterpreterIdentifierList; // methods
    FSetList: TJvInterpreterIdentifierList; // write properties
    FIGetList: TJvInterpreterIdentifierList; // read indexed properties
    FISetList: TJvInterpreterIdentifierList; // write indexed properties
    FIDGetList: TJvInterpreterIdentifierList; // read default indexed properties
    FIDSetList: TJvInterpreterIdentifierList; // write default indexed properties
    FIntfGetList: TJvInterpreterIdentifierList; // interface methods
    FDirectGetList: TJvInterpreterIdentifierList; // direct get list
    FClassList: TJvInterpreterIdentifierList; // delphi classes
    FConstList: TJvInterpreterIdentifierList; // delphi consts
    FFunctionList: TJvInterpreterIdentifierList; // functions, procedures
    FRecordList: TJvInterpreterIdentifierList; // records
    FRecordGetList: TJvInterpreterIdentifierList; // read record field
    FRecordSetList: TJvInterpreterIdentifierList; // write record field
    FOnGetList: TJvInterpreterIdentifierList; // chain
    FOnSetList: TJvInterpreterIdentifierList; // chain
    FSrcFunctionList: TJvInterpreterIdentifierList; // functions, procedures in rm_JvInterpreter-source
    FExtFunctionList: TJvInterpreterIdentifierList;
    FEventHandlerList: TJvInterpreterIdentifierList;
    FEventList: TJvInterpreterIdentifierList;
    FSrcVarList: TJvInterpreterVarList; // variables, constants in rm_JvInterpreter-source
    FSrcClassList: TJvInterpreterIdentifierList; // rm_JvInterpreter-source classes
    FDisableExternalFunctions: Boolean;
    FSorted: Boolean;
    procedure CheckArgs(var Args: TJvInterpreterArgs; ParamCount: Integer;
      var ParamTypes: TTypeArray);
    function GetRec(const RecordType: string): TObject;
    {$IFDEF JvInterpreter_OLEAUTO}
    function DispatchCall(const Identifier: string; var Value: Variant;
      Args: TJvInterpreterArgs; Get: Boolean): Boolean; stdcall;
    {$ENDIF JvInterpreter_OLEAUTO}
    function GetValueRTTI(const Identifier: string; var Value: Variant;
      Args: TJvInterpreterArgs): Boolean;
    function SetValueRTTI(const Identifier: string; const Value: Variant;
      Args: TJvInterpreterArgs): Boolean;
  protected
    procedure CheckAction(Expression: TJvInterpreterExpression; Args: TJvInterpreterArgs;
      Data: Pointer); virtual;
    function GetValue(Expression: TJvInterpreterExpression; const Identifier: string;
      var Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual;
    function SetValue(Expression: TJvInterpreterExpression; const Identifier: string;
      const Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual;
    function GetElement(Expression: TJvInterpreterExpression; const Variable: Variant;
      var Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual;
    function SetElement(Expression: TJvInterpreterExpression; var Variable: Variant;
      const Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual;
    function NewRecord(const RecordType: string; var Value: Variant): Boolean; virtual;
    function FindFunDesc(const UnitName, Identifier: string;
      const ClassIdentifier:string=''): TJvInterpreterFunctionDesc; virtual;
    procedure CurUnitChanged(const NewUnitName: string; var Source: string); virtual;
    function UnitExists(const Identifier: string): Boolean; virtual;
    function IsEvent(Obj: TObject; const Identifier: string): Boolean; virtual;
    function NewEvent(const UnitName, FunctionName, EventType: string;
      AOwner: TJvInterpreterExpression; AObject: TObject;
      const APropName: string): TSimpleEvent; virtual;
    procedure ClearSource; dynamic;
    procedure ClearNonSource; dynamic;
    procedure Sort; dynamic;
  protected
    { for internal use }
    procedure AddSrcClass(JvInterpreterSrcClass: TJvInterpreterIdentifier); virtual;
    function GetSrcClass(const Identifier: string): TJvInterpreterIdentifier; virtual;
  public
    constructor Create(AOwner: TJvInterpreterExpression);
    destructor Destroy; override;
    function SetRecord(var Value: Variant): Boolean; virtual;
    procedure Clear; dynamic;
    procedure Assign(Source: TJvInterpreterAdapter); dynamic;
    procedure AddSrcUnit(const Identifier, Source, UsesList: string); dynamic;
    procedure AddSrcUnitEx(const Identifier, Source, UsesList: string;
      Data: Pointer); dynamic;
    procedure AddExtUnit(const Identifier: string); dynamic;
    procedure AddExtUnitEx(const Identifier: string; Data: Pointer); dynamic;
    procedure AddClass(const UnitName: string; AClassType: TClass; const Identifier: string); dynamic;
    procedure AddClassEx(const UnitName: string; AClassType: TClass; const Identifier: string;
      Data: Pointer); dynamic;
    procedure AddIntfGet(IID: TGUID; const Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word);
    procedure AddIntfGetEx(IID: TGUID; const Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer);
    procedure AddGet(AClassType: TClass; const Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddGetEx(AClassType: TClass; const Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;
    procedure AddSet(AClassType: TClass; const Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word); dynamic;
    procedure AddSetEx(AClassType: TClass; const Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;