base_scripter.pas

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

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


{$I PaxScript.def}
unit BASE_SCRIPTER;

interface

uses
{$IFDEF WIN32}
  Windows,
{$ENDIF}

{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils, Classes,

  {$ifndef FP}
  SyncObjs,
  {$endif}

  BASE_CONSTS,
  BASE_SYNC,
  BASE_SYS, BASE_SCANNER, BASE_PARSER, BASE_SYMBOL, BASE_CODE, BASE_CLASS,
  BASE_EXTERN, BASE_EVENT, BASE_REGEXP, BASE_DLL, BASE_DFM;

type
  TPAXBaseScripter = class;

  TPAXModule = class(TStringList)
  public
    Name: String;
    FileName: String;
    LanguageName: String;
    Namespaces: TPAXIds;
    S1, P1, C1, S2, P2, C2: Integer;
    IsSource: Boolean;
    BuffStream: TStream;
    Scripter: TPaxBaseScripter;
    constructor Create(Scripter: TPaxBaseScripter);
    destructor Destroy; override;
    procedure AddNamespace(ID: Integer);
    function GetTextPos(LineNumber, Position: Integer): Integer;
    procedure _SaveToStream(S: TStream);
    procedure _LoadFromStream(S: TStream);
  end;

  TPAXModules = class(TStringList)
  private
    Scripter: TPaxBaseScripter;
    function GetModule(Index: Integer): TPAXModule;
    function GetSourceCode: String;
  public
    constructor Create(Scripter: TPaxBaseScripter);
    procedure Clear; reintroduce;
    function IndexOf(const Name: String): Integer; override;
    function Add(const Name, LanguageName: String): Integer; reintroduce;
    procedure Delete(Index: Integer); reintroduce;
    procedure _SaveToStream(S: TStream);
    procedure _LoadFromStream(S: TStream);
    destructor Destroy; override;
    procedure Dump(const FileName: String);
    property Items[Index: Integer]: TPAXModule read GetModule;
    property SourceCode: String read GetSourceCode;
  end;

  TScripterEvent = procedure(Sender: TObject) of object;
  TCompilerProgressEvent = procedure(Sender: TObject; ModuleNumber: Integer) of object;
  TPrintEvent = procedure(Sender: TObject; const S: String) of object;
  TReadEvent = procedure(Sender: TObject; var S: String) of object;

  TVarEvent = procedure (Sender: TObject; ID: Integer) of object;

  TVarEventEx = procedure (Sender: TObject; ID: Integer; var Mode: Integer) of object;


  TCodeEvent = procedure(Sender: TObject;
                         N: Integer;
                         var Handled: Boolean) of object;

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

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

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

  TStreamEvent = procedure(Sender: TObject; Stream: TStream;
                           const ModuleName: String) of object;

  TOnDefineEvent = procedure(Sender: TObject; const DirectiveName: String) of object;

  TOnChangeStateEvent = procedure(Sender: TObject; OldState, NewState: TPaxScripterState) of object;

  TOnInstanceEvent = procedure(Sender: TObject; Instance: TObject) of object;

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

  TVarArray = array of Variant;

  TVirtualObjectMethodCallEvent = function(Sender: TObject; const ObjectName,
     PropName: String; const Params: TVarArray): Variant of object;

  TVirtualObjectPutPropertyEvent = procedure(Sender: TObject; const ObjectName,
     PropName: String; const Params: TVarArray; const Value: Variant) of object;

  TPAXBaseScripter = class
  private
    fOnHalt: TScripterEvent;
    fOnShowError: TScripterEvent;
    fOnCompilerProgress: TCompilerProgressEvent;
    fOnRunning: TCodeEvent;
    fOnPrint: TPrintEvent;
    fOnRead: TReadEvent;
{$IFDEF UNDECLARED_EX}
    fOnUndeclaredIdentifier: TVarEventEx;
{$ELSE}
    fOnUndeclaredIdentifier: TVarEvent;
{$ENDIF}
    fOnChangedVariable: TVarEvent;
    fOnReadExtraData, fOnWriteExtraData: TStreamEvent;
    fOnUsedModule: TUsedModuleEvent;
    fOnInclude: TIncludeEvent;
    fOnLoadSourceCode: TLoadSourceCodeEvent;
    fOnDefine: TOnDefineEvent;
    fOnChangeState: TOnChangeStateEvent;
    fOnDelphiInstanceCreate: TOnInstanceEvent;
    fOnDelphiInstanceDestroy: TOnInstanceEvent;
    fOnLoadDll: TLoadDllEvent;
    fOnVirtualObjectMethodCall: TVirtualObjectMethodCallEvent;
    fOnVirtualObjectPutProperty: TVirtualObjectPutPropertyEvent;

    SignDefs: Boolean;

    fOverrideHandlerMode: Integer;
{$IFDEF ONRUNNING}
    // Event to replace OnRunning event.  Event will be executed when
    // fOnRunningUpdateActive is enabled and the event is assigned.
    fOnRunningUpdate: TScripterEvent;

    // Flag used to fire the OnRunningUpdate event.  This allows scripter
    // to run quickly when flag is disabled (False).  Flag can be
    // enabled/disabled during script run-time.
    fOnRunningUpdateActive: Boolean;

    // Event fires when executing a function or property and UserData is non-zero.
    // Used for multi-thread applications.
    fOnRunningSync: TScripterEvent;
{$ENDIF}
    procedure SetState(Value: TPAXScripterState);
    procedure CopyLevelStack(Parser: TPAXParser);
  public
    EvalCount: Integer;
    Owner: TObject;
    Modules: TPAXModules;
    SymbolTable: TPAXSymbolTable;
    Code: TPAXCode;
    ClassList: TPAXClassList;
    EventHandlerList: TPAXEventHandlerList;
    MethodBody: TPAXMethodBody;
    VariantStack: TPaxVariantStack;
    NegVarList: TPaxVarList;

    ScriptObjectList: TPAXScriptObjectList;
    ActiveXObjectList: TPaxObjectList;
    CompileTimeHeap: TPAXCompileTimeHeap;

    fState: TPAXScripterState;
    Error: Variant;

    ErrorInstance: TPAXError;
    RegisteredFieldList: TPAXFieldList;
    ParserList: TPAXParserList;

    ExtraCodeList: TPAXCodeList;

    fTotalLineCount: Integer;

    ParamList: TPAXParamList;

    ArrayClassRec: TPAXClassRec;

    LastResultID: Integer;
    fLastResult: Variant;

    DoNotDestroyList: TPAXIds;
    TempObjectList: TPAXAssocList;

    ForbiddenPublishedProperties: TList;
    ForbiddenPublishedPropertiesEx: TStringList;

    PrototypeNameIndex: Integer;
    ConstructorNameIndex: Integer;

    fStackSize: Integer;
    fLongStrLiterals: Boolean;

    CurrModule: Integer;

    OwnerEventHandlerMethod: TMethod;

    AllowedEvents: Boolean;
    Visited: TList;
    ExtraModuleList: TStringList;
    DefList: TStringList;

    RunList: TPaxStack;
    fSearchPathes: TStringList;
    DefaultParameterList: TDefaultParameterList;

    UnknownTypes: TPaxIDRecList;
    CallRecList: TPaxCallRecList;
    TypeAliasList: TPaxAssociativeList;
    NameList: TPAXNameList;
    LocalDefinitions: TPAXDefinitionList;

    TempVariant: Variant;
    CancelMessage: String;

    _ObjCount: Int64;
    LastDefinitionListCount: Integer;

    IgnoreBreakpoints: Boolean;

    constructor Create(Owner: TObject);
    destructor Destroy; override;
    procedure AddDefs;
    procedure AddLocalDefs;
    function AddModule(const ModuleName, LanguageName: String): Integer;
    procedure AddCode(const ModuleName, Code: String);
    procedure AddCodeFromFile(const ModuleName, FileName: String);
    function CompileModule(const Name: String; Parser: TPAXParser;
                           SyntaxCheckOnly: Boolean = false): Boolean;
    procedure CompileExtraCode;
    procedure Link(reallocate: boolean);
    procedure Run(RunMode: Integer = _rmRun; DestLine: Integer = 0);
    procedure ResetCompileStage;
    procedure ResetScripterEx;
    procedure InitRunStage;
    procedure ResetRunStage;
    procedure DiscardError;
    function IsError: boolean;
    function AddBreakpoint(const ModuleName: String; SourceLineNumber: Integer;
                           const Condition: String; PassCount: Integer): Boolean;
    function RemoveBreakpoint(const ModuleName: String; SourceLineNumber: Integer;
                           const Condition: String; PassCount: Integer): Boolean;
    procedure RemoveAllBreakpoints;
    function SourceLineToPCodeLine(const ModuleName: String; SourceLineNumber: Integer): Integer;
    procedure CreateErrorObject(const Message: String; PosNumber: Integer);
    procedure ShowError;
    function CallMethod(SubID: Integer;
                        const This: Variant;
                        const P: array of const;
                        IsEventHandler: Boolean = false): Variant;
    function CallMethodEx(SubID: Integer;
                          const This: Variant;
                          const P: array of const;
                          const StrTypes: array of String;
                          IsEventHandler: Boolean = false): Variant;
    function AssignedObject(SO: TPAXScriptObject): Boolean;
    procedure DisconnectObjects;
    procedure Dump;
    function GetProperty(const ScriptObject: Variant; PropertyName: String): Variant;
    function Eval(const SourceCode: String; Parser: TPAXParser): Variant;
    procedure EvalStatementList(const SourceCode: String; Parser: TPAXParser);
    function GetName(NameIndex: Integer): String;
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream);

    procedure SaveCompiledModuleToStream(M: TPaxModule; S: TStream);
    procedure LoadCompiledModuleFromStream(M: TPaxModule; S: TStream);

    property State: TPAXScripterState read fState write SetState;
    property TotalLineCount: Integer read fTotalLineCount write fTotalLineCount;
    procedure AddExtraModule(const ModuleName, SourceCode: String;
                                          SyntaxCheckOnly: Boolean; const PaxLanguage: String);
    procedure RunEx(ExtendedRun: Boolean);
    function FindFullName(const FileName: String): String;
    function IsCompiledScript(const FileName: String): Boolean;
    procedure CreateRunList;
    procedure CheckForUndeclared;
    procedure CheckCalls;
    function GetTypeID(ID: Integer): Integer;

    function MatchAssignment(T1, T2: Integer): Boolean;
    function MatchAssignmentStrict(T1, T2: Integer): Boolean;
    function OpResultType(T1, T2: Integer): Integer;
    function MatchTypes(T1, T2: Integer): Integer;
    function strIncompatibleTypes(T1, T2: Integer): String;

    function ConvertDelphiForm1(const DfmFileName, UnitFileName, PaxLanguage: String): String;
    function ConvertDelphiForm2(const DfmFileName: String; UsedUnits: TStringList; const PaxLanguage: String): String;
    procedure AddDelphiForm(const DfmFileName, UnitFileName, PaxLanguage: String);
    function HasForbiddenPublishedProperty(C: TClass; const PropName: String): Boolean;

    property OverrideHandlerMode: Integer read fOverrideHandlerMode write fOverrideHandlerMode;

    property OnHalt: TScripterEvent read fOnHalt write fOnHalt;
    property OnShowError: TScripterEvent read fOnShowError write fOnShowError;
    property OnCompilerProgress: TCompilerProgressEvent read fOnCompilerProgress write fOnCompilerProgress;
    property OnPrint: TPrintEvent read fOnPrint write fOnPrint;
    property OnRead: TReadEvent read fOnRead write fOnRead;
{$IFDEF UNDECLARED_EX}
    property OnUndeclaredIdentifier: TVarEventEx read fOnUndeclaredIdentifier write fOnUndeclaredIdentifier;
{$ELSE}
    property OnUndeclaredIdentifier: TVarEvent read fOnUndeclaredIdentifier write fOnUndeclaredIdentifier;
{$ENDIF}
    property OnChangedVariable: TVarEvent
               read fOnChangedVariable write fOnChangedVariable;
    property OnRunning: TCodeEvent read fOnRunning write fOnRunning;
{$IFDEF ONRUNNING}
    // See variable definitions above for details.
    property OnRunningUpdate: TScripterEvent read fOnRunningUpdate write fOnRunningUpdate;
    property OnRunningUpdateActive: Boolean read fOnRunningUpdateActive write fOnRunningUpdateActive;
    property OnRunningSync: TScripterEvent read fOnRunningSync write fOnRunningSync;
{$ENDIF}
    property OnReadExtraData: TStreamEvent read fOnReadExtraData write fOnReadExtraData;
    property OnWriteExtraData: TStreamEvent read fOnWriteExtraData write fOnWriteExtraData;
    property OnUsedModule: TUsedModuleEvent read fOnUsedModule write fOnUsedModule;
    property OnInclude: TIncludeEvent read fOnInclude write fOnInclude;
    property OnLoadSourceCode: TLoadSourceCodeEvent read fOnLoadSourceCode write fOnLoadSourceCode;
    property OnDefine: TOnDefineEvent read fOnDefine write fOnDefine;
    property OnChangeState: TOnChangeStateEvent read fOnChangeState write fOnChangeState;
    property OnDelphiInstanceCreate: TOnInstanceEvent read fOnDelphiInstanceCreate write fOnDelphiInstanceCreate;
    property OnDelphiInstanceDestroy: TOnInstanceEvent read fOnDelphiInstanceDestroy write fOnDelphiInstanceDestroy;
    property OnLoadDll: TLoadDllEvent read fOnLoadDll write fOnLoadDll;
    property OnVirtualObjectMethodCall: TVirtualObjectMethodCallEvent read fOnVirtualObjectMethodCall write fOnVirtualObjectMethodCall;
    property OnVirtualObjectPutProperty: TVirtualObjectPutPropertyEvent read fOnVirtualObjectPutProperty write fOnVirtualObjectPutProperty;
  end;

var
  __Self: TObject;
  __Scripter: TObject;
  ScripterList: TList;
  DllList: TPaxDllList;

  CurrScripter: TPAXBaseScripter;

function _Eval(const SourceCode: String;
              Scripter: TPAXBaseScripter;
              Parser: TPAXParser): Variant;

implementation

uses
  PASCAL_PARSER, PAX_JAVASCRIPT;

constructor TPAXModule.Create(Scripter: TPaxBaseScripter);
begin
  inherited Create;
  Self.Scripter := Scripter;
  Namespaces := TPAXIds.Create(false);
  IsSource := true;
  BuffStream := TMemoryStream.Create;
end;

destructor TPAXModule.Destroy;
begin
  Namespaces.Free;
  BuffStream.Free;
  inherited;
end;

procedure TPAXModule.AddNamespace(ID: Integer);
begin
  if Namespaces.IndexOf(ID) = -1 then
    Namespaces.Add(ID);
end;

function TPAXModule.GetTextPos(LineNumber, Position: Integer): Integer;
var
  S: String;
  P, LineCount: Integer;
begin
  result := 0;
  P := 1;
  LineCount := 1;

  S := Text + #255;

  while S[P] <> #255 do
  begin
    if S[P] in [#10,#13] then
    begin
      Inc(LineCount);
      if S[P] = #13 then
        Inc(P);
    end;

    if LineCount = LineNumber then
    begin
      while S[P] in [#10,#13] do
        Inc(P);

      result := P + Position;
      Exit;
    end;

    Inc(P);
  end;
end;

procedure TPAXModule._SaveToStream(S: TStream);
begin
  SaveString(Name, S);
  SaveString(FileName, S);
  SaveString(LanguageName, S);
  SaveInteger(Count, S);
  Namespaces.SaveToStream(S);

  SaveInteger(S1, S);
  SaveInteger(S2, S);

  SaveInteger(P1, S);
  SaveInteger(P2, S);

  SaveInteger(C1, S);
  SaveInteger(C2, S);
end;

procedure TPAXModule._LoadFromStream(S: TStream);
var
  I, K: Integer;
  St: String;
begin
  Name := LoadString(S);
  FileName := LoadString(S);
  LanguageName := LoadString(S);
  K := LoadInteger(S);
  Namespaces.LoadFromStream(S);

  S1 := LoadInteger(S);
  S2 := LoadInteger(S);

  P1 := LoadInteger(S);
  P2 := LoadInteger(S);

  C1 := LoadInteger(S);
  C2 := LoadInteger(S);

  if Assigned(Scripter.fOnLoadSourceCode) then
  begin
    Scripter.fOnLoadSourceCode(Scripter.Owner, Name, FileName, St);
    Text := St;
  end
  else
  begin
    if FileExists(FileName) then
      LoadFromFile(FileName)
    else
      for I:=0 to K - 1 do
        Add('##' + IntToStr(I) + '##');
  end;

  IsSource := false;
end;

constructor TPAXModules.Create(Scripter: TPaxBaseScripter);
begin
  inherited Create;
  Self.Scripter := Scripter;
end;