paxscripter.pas

来自「Delphi脚本控件」· PAS 代码 · 共 1,898 行 · 第 1/5 页

///////////////////////////////////////////////////////////////////////////
// PAXScript Interpreter
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: PaxScripter.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////

{$I PaxScript.def}
unit PaxScripter;

interface

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}

{$IFDEF WIN32}
  Windows,
{$ENDIF}
  SysUtils,
  TypInfo,
  Classes,
//  ComCtrls,
{$ifdef obsolete}
  Forms,
{$endif}

{$ifdef FP}
  dynlibs,
{$ENDIF}

  BASE_CONSTS,
  BASE_SYS,
  BASE_SYNC,
  BASE_CODE,
  BASE_PARSER,
  BASE_CLASS,
  BASE_SCRIPTER,
  BASE_CALL,
  BASE_EXTERN,
  BASE_EVENT,
  BASE_REGEXP,
  PaxImport;
const
  rmRun = 0;
  rmStepOver = 1;
  rmTraceInto = 2;
  rmRunToCursor = 3;
  rmTraceToNextSourceLine = 4;

  paxVersion: Double = 3.0;
  paxBuild = '';
  paxCompiledModuleVersion: Integer = BASE_SYS._CompiledModuleVersion;
  MaxModuleNumber = 255;
type
  TScripterState =
  (
  ssInit, // scripter is not assigned by a script
  ssReadyToCompile, // scripter is assigned by a script and ready to compile it.
  ssCompiling, // compiles script
  ssCompiled, // all modules were compiled
  ssLinking, // links modules in a script
  ssReadyToRun, // script was linked and it is ready to run now
  ssRunning, // runs script
  ssPaused, // script was paused
  ssTerminated // script was terminated
  );

  TPaxScripter = class;
  TPaxLanguage = class;

  TCallStackRecord = class
  public
    ModuleName: String;
    LineNumber: Integer;
    ProcName: String;
    Parameters: TStringList;
    constructor Create;
    destructor Destroy; override;
  end;

  TCallStack = class
  private
    fScripter: TPAXBaseScripter;
    fRecords: TList;
    function GetCount: Integer;
    function GetRecord(Index: Integer): TCallStackRecord;
    procedure Clear;
    constructor Create(PaxScripter: TPaxScripter);
    procedure Add(R: TCallStackRecord);
  public
    destructor Destroy; override;
    property Count: Integer read GetCount;
    property Records[I: Integer]: TCallStackRecord read GetRecord;
  end;

  TPaxScripterEvent = procedure (Sender: TPaxScripter) of object;
  TPaxCompilerProgressEvent = procedure(Sender: TPaxScripter; ModuleNumber: Integer) of object;
  TPaxScripterPrintEvent = procedure (Sender: TPaxScripter;
                                      const S: String) of object;
  TPaxScripterDefineEvent = procedure (Sender: TPaxScripter;
                                       const S: String) of object;
  TPaxScripterReadEvent = procedure (Sender: TPaxScripter;
                                     var S: String) of object;

  TPaxScripterVarEvent = procedure (Sender: TPaxScripter; ID: Integer) of object;
  TPaxScripterVarEventEx = procedure (Sender: TPaxScripter; ID: Integer; var Mode: Integer) of object;

  TPaxCodeEvent = procedure(Sender: TPaxScripter;
                            N: Integer;
                            var Handled: Boolean) of object;

  TPaxUsedModuleEvent = procedure(Sender: TPaxScripter; const UsedModuleName, FileName: String;
                                  var SourceCode: String) of object;

  TPaxIncludeEvent = procedure(Sender: TObject; const IncludedFileName: String;
                            var SourceCode: String) of object;

  TPaxLoadSourceCodeEvent = procedure(Sender: TPaxScripter; const UsedModuleName, FileName: String;
                                      var SourceCode: String) of object;

  TPaxScanPropertiesEvent = procedure(Sender: TPaxScripter; const PropName: String;
                                       var Value: Variant) of object;

  TPAXMemberKind = (mkUnknown, mkConst, mkField, mkProp, mkParam, mkResult,
                    mkMethod, mkClass, mkStructure, mkEnum, mkNamespace, mkEvent);

  TPAXCallConv = (ccRegister, ccPascal, ccCDecl, ccStdCall, ccSafeCall);

  TPaxMemberCallback = procedure (const Name: String;
                                  ID: Integer;
                                  Kind: TPAXMemberKind;
                                  ml: TPAXModifierList;
                                  Data: Pointer) of object;

  TPaxInstruction = record
    N, Op, Arg1, Arg2, Res: Integer;
  end;

  PPaxTreeNodeData = ^TPaxTreeNodeData;
  TPaxTreeNodeData = record
    Value: Variant;
    Modified: Boolean;
    ID: Integer;
    Prop: TPaxProperty;
  end;

  TPaxScripterStreamEvent = procedure(Sender: TPaxScripter; Stream: TStream;
                            const ModuleName: String) of object;

  TPaxScripterChangeStateEvent = procedure(Sender: TPaxScripter; OldState, NewState: Integer) of object;

  TPaxScripterInstanceEvent = procedure(Sender: TPaxScripter; Instance: TObject) of object;

  TPaxLoadDllEvent = procedure(Sender: TPaxScripter; const DllName, ProcName: String;
                         var Address: Pointer) of object;

  TPaxVarArray = array of Variant;

  TPaxVirtualObjectMethodCallEvent = function(Sender: TPaxScripter; const ObjectName,
      PropName: String; const Params: TPaxVarArray): Variant of object;

  TPaxVirtualObjectPutPropertyEvent = procedure(Sender: TPaxScripter; const ObjectName,
      PropName: String; const Params: TPaxVarArray; const Value: Variant) of object;

  TPaxOverrideHandlerMode = (Replace, Before, After);

  TPaxScripter = class(TComponent)
  private
    fCallStack: TCallStack;
    fSearchPathes: TStrings;

    fOnAssignScript,
    fOnAfterCompileStage,
    fOnAfterRunStage,
    fOnBeforeCompileStage,
    fOnBeforeRunStage,
    fOnHalt: TPaxScripterEvent;
    fOnScanProperties: TPaxScanPropertiesEvent;

    function GetModules: TStringList;

    function GetScripterState: TScripterState;
    procedure SetScripterState(Value: TScripterState);

    function GetOverrideHandlerMode: TPaxOverrideHandlerMode;
    procedure SetOverrideHandlerMode(Value: TPaxOverrideHandlerMode);

    procedure ExtractCallStack;
    function GetSourceCode(const ModuleName: String): String;
    procedure SetSourceCode(const ModuleName, SourceCode: String);
    function GetOnCompilerProgress: TPaxCompilerProgressEvent;
    procedure SetOnCompilerProgress(Value: TPaxCompilerProgressEvent);
    function GetOnPrint: TPaxScripterPrintEvent;
    procedure SetOnPrint(Value: TPaxScripterPrintEvent);
    function GetOnDefine: TPaxScripterDefineEvent;
    procedure SetOnDefine(Value: TPaxScripterDefineEvent);
    function GetOnChangedVariable: TPaxScripterVarEvent;
    procedure SetOnChangedVariable(Value: TPaxScripterVarEvent);
    function GetOnRunning: TPaxCodeEvent;
    procedure SetOnRunning(Value: TPaxCodeEvent);
    function GetOnInclude: TPaxIncludeEvent;
    procedure SetOnInclude(Value: TPaxIncludeEvent);
    function GetOnHalt: TPaxScripterEvent;
    procedure SetOnHalt(Value: TPaxScripterEvent);

    function GetOnLoadDll: TPaxLoadDllEvent;
    procedure SetOnLoadDll(Value: TPaxLoadDllEvent);

    function GetOnVirtualObjectMethodCallEvent: TPaxVirtualObjectMethodCallEvent;
    procedure SetOnVirtualObjectMethodCallEvent(Value: TPaxVirtualObjectMethodCallEvent);

    function GetOnVirtualObjectPutPropertyEvent: TPaxVirtualObjectPutPropertyEvent;
    procedure SetOnVirtualObjectPutPropertyEvent(Value: TPaxVirtualObjectPutPropertyEvent);

{$IFDEF ONRUNNING}
    // See BASE_SCRIPTER.pas for details.
    function GetOnRunningUpdate: TPaxScripterEvent;
    procedure SetOnRunningUpdate(Value: TPaxScripterEvent);
    function GetOnRunningUpdateActive: Boolean;
    procedure SetOnRunningUpdateActive(Value: Boolean);
    function GetOnRunningSync: TPaxScripterEvent;
    procedure SetOnRunningSync(Value: TPaxScripterEvent);
{$ENDIF}

{$IFDEF UNDECLARED_EX}
    function GetOnUndeclaredIdentifier: TPaxScripterVarEventEx;
    procedure SetOnUndeclaredIdentifier(Value: TPaxScripterVarEventEx);
{$ELSE}
    function GetOnUndeclaredIdentifier: TPaxScripterVarEvent;
    procedure SetOnUndeclaredIdentifier(Value: TPaxScripterVarEvent);
{$ENDIF}

    function GetOnReadExtraData: TPaxScripterStreamEvent;
    procedure SetOnReadExtraData(Value: TPaxScripterStreamEvent);
    function GetOnWriteExtraData: TPaxScripterStreamEvent;
    procedure SetOnWriteExtraData(Value: TPaxScripterStreamEvent);
    function GetOnUsedModule: TPaxUsedModuleEvent;
    procedure SetOnUsedModule(Value: TPaxUsedModuleEvent);
    function GetOnLoadSourceCode: TPaxLoadSourceCodeEvent;
    procedure SetOnLoadSourceCode(Value: TPaxLoadSourceCodeEvent);
    function GetOnChangeState: TPaxScripterChangeStateEvent;
    procedure SetOnChangeState(Value: TPaxScripterChangeStateEvent);

    function GetOnDelphiInstanceCreate: TPaxScripterInstanceEvent;
    procedure SetOnDelphiInstanceCreate(Value: TPaxScripterInstanceEvent);
    function GetOnDelphiInstanceDestroy: TPaxScripterInstanceEvent;
    procedure SetOnDelphiInstanceDestroy(Value: TPaxScripterInstanceEvent);


    function GetTotalLineCount: Integer;
    function GetErrorClassType: TClass;
    function GetErrorDescription: String;
    function GetErrorModuleName: String;
    function GetErrorTextPos: Integer;
    function GetErrorPos: Integer;
    function GetErrorLine: Integer;
    function GetErrorMethodId: Integer;
    procedure InvokeOnAssignScript;
    function GetCurrentSourceLine: Integer;
    function GetCurrentModuleName: String;
    procedure RegisterLanguages;
    procedure UnregisterLanguages;
    procedure SetStackSize(Value: Integer);
    function GetStackSize: Integer;
    procedure SetOptimization(Value: Boolean);
    function GetOptimization: Boolean;
    function GetLanguage(I: Integer): TPaxLanguage;
    procedure SetSearchPathes(const Value: TStrings);
    procedure Unregister(What: TPAXDefKind; const Name: String; Owner: Integer = -1);
  protected
    function GetParam(const ParamName: String): Variant; virtual;
    procedure SetParam(const ParamName: String; const Value: Variant); virtual;
    function GetValue(const Name: String): Variant; virtual;
    procedure SetValue(const Name: String; const Value: Variant); virtual;
    function RegisterParser(ParserClass: TPAXParserClass; const LanguageName, FileExt: String;
                            CallConvention: TPAXCallConv): Integer;
    procedure SetUpSearchPathes; virtual;
  public
    fScripter: TPAXBaseScripter;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindTempObject(const Key: TVarRec): TObject;
    function AddTempObject(const Key: TVarRec; Obj: TObject): Integer;
    function AddModule(const ModuleName, LanguageName: String): Integer;
    procedure AddCode(const ModuleName, Code: String);
    procedure AddCodeLine(const ModuleName, Code: String);
    procedure AddCodeFromFile(const ModuleName, FileName: String);
    procedure AddDelphiForm(const DfmFileName, UnitFileName: String;
                            const PaxLanguage: String = 'paxPascal'); overload;
    procedure AddDelphiForm(const DfmFileName: String; UsedUnits: TStringList;
                                const PaxLanguage: String = 'paxPascal'); overload;
    procedure AddDelphiForm(const ModuleName: String; Dfm, Source: TStream;
                            const PaxLanguage: String = 'paxPascal'); overload;
    procedure LoadProject(const FileName: String);
    function CompileModule(const ModuleName: String;
                            SyntaxCheckOnly: Boolean = false): Boolean;
    function Compile(SyntaxCheckOnly: Boolean = false): Boolean;
    procedure Run(RunMode: Integer = rmRun; const ModuleName: String = ''; LineNumber: Integer = 0);
    procedure RunInstruction;
    function InstructionCount: Integer;
    function CurrentInstructionNumber: Integer;
    function GetInstruction(N: Integer): TPaxInstruction;
    procedure SetInstruction(N: Integer; I: TPaxInstruction);
    function Eval(const Expression, LanguageName: String; var Res: Variant): Boolean;
    function EvalStatementList(const Expression, LanguageName: String): Boolean;
    function EvalJS(const Expression: String): Boolean;
    function CallFunction(const Name: String; const Params: array of const;
                          AnObjectName: String = ''): Variant;
    function CallFunctionEx(const Name: String;
                            const Params: array of const;
                            const StrTypes: array of String;
                            AnObjectName: String = ''): Variant;
    function CallFunctionByID(SubID: Integer; const Params: array of const;
                              ObjectID: Integer = 0): Variant;
    function CallFunctionByIDEx(SubID: Integer; const Params: array of const;
                                const StrTypes: array of String;
                                ObjectID: Integer = 0): Variant;
    function CallMethod(const Name: String; const Params: array of const; Instance: TObject): Variant; overload;
    function CallMethod(const Name: String; const Params: array of const; const This: Variant): Variant; overload;
    function CallMethodByID(SubID: Integer;
                           const Params: array of const; Instance: TObject): Variant; overload;
    function CallMethodByID(SubID: Integer;
                            const Params: array of const; const This: Variant): Variant; overload;
    function GetLastResult: Variant;
    procedure CancelCompiling(const AMessage: String);
    procedure Dump;
    procedure RemoveAllBreakpoints;
    function AddBreakpoint(const ModuleName: String;
                           LineNumber: Integer; const Condition: String = ''; PassCount: Integer = 0): Boolean;
    function RemoveBreakpoint(const ModuleName: String; LineNumber: Integer): Boolean;
    procedure RegisterConstant(const Name: String; Value: Variant; Owner: Integer = -1);
    procedure RegisterVariable(const Name, TypeName: String; Address: Pointer; Owner: Integer = -1);
    procedure RegisterObject(const Name: String; Instance: TObject; Owner: Integer = -1);
    procedure RegisterVirtualObject(const Name: String; Owner: Integer = -1);
    procedure RegisterObjectSimple(const Name: String; Instance: TObject; Owner: Integer = -1);
    procedure RegisterInterfaceVar(const Name: String; PIntf: PUnknown;
                                   const guid: TGUID;
                                   Owner: Integer = -1);
    procedure UnregisterConstant(const Name: String; Owner: Integer = -1);
    procedure UnregisterVariable(const Name: String; Owner: Integer = -1);
    procedure UnregisterObject(const Name: String; Owner: Integer = -1); overload;
    procedure UnregisterObject(Instance: TObject; Owner: Integer = -1); overload;
    procedure UnregisterAllVariables;
    procedure UnregisterAllObjects;
    procedure UnregisterAllConstants;

    procedure ForbidAllPublishedProperties(AClass: TClass);
    procedure ForbidPublishedProperty(AClass: TClass; const PropName: String);

    procedure RegisterField(const ObjectName: String;
                            ObjectType: String;
                            FieldName: String;
                            FieldType: String;
                            Address: Pointer);
    function ToString(const V: Variant): String;

    procedure ResetScripter;
    procedure ResetScripterEx;
    procedure Terminate;
    procedure DisconnectObjects;

    function IsError: Boolean;
    procedure DiscardError;

    function GetMemberID(const Name: String): Integer;
    function GetParamID(SubID, ParamIndex: Integer): Integer;
    function GetResultID(SubID: Integer): Integer;
    function GetParamCount(SubID: Integer): Integer;
    function GetTypeName(ID: Integer): String;
    function GetParamTypeName(SubID, ParamIndex: Integer): String;
    function GetSignature(SubID: Integer): String;
    function GetParamName(SubID, ParamIndex: Integer): String;
    function GetTypeID(ID: Integer): Integer;
    function GetName(ID: Integer): String;