base_extern.pas

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

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

{$I PaxScript.def}
unit BASE_EXTERN;
interface

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

{$ifdef FP}
  dynlibs,
{$ENDIF}

{$IFDEF WIN32}
  Windows,
{$ENDIF}
  Classes, SysUtils, TypInfo,
  BASE_CONSTS,
  BASE_SYNC,
  BASE_SYS, BASE_CONV, BASE_DLL;
type
  TPAXMethodBody = class;
  TPAXDefinition = class;

  TPAXMethodImpl = procedure (MethodBody: TPAXMethodBody);

  TPAXDefKind = (dkClass, dkMethod, dkProperty, dkVariable, dkObject, dkField,
                 dkInterface,
                 dkRecordField,
                 dkConstant, dkRTTIType, dkVirtualObject, dkAny);

  TPAXDefinitionList = class;

  TPAXParameter = class
  private
    Scripter: Pointer;
    function GetAsString: String;
    procedure SetAsString(const Value: String);
    function GetAsInteger: Integer;
    procedure SetAsBoolean(Value: Boolean);
    function GetAsBoolean: Boolean;
    procedure SetAsInteger(Value: Integer);
    function GetAsDouble: Double;
    procedure SetAsDouble(Value: Double);
    function GetAsCardinal: Cardinal;
    procedure SetAsCardinal(Value: Cardinal);
    function GetAsPointer: Pointer;
    procedure SetAsPointer(Value: Pointer);
    function GetAsTObject: TObject;
    procedure SetAsTObject(Value: TObject);
    function GetAsVariant: Variant;
    procedure SetAsVariant(const Value: Variant);
    procedure Clear;
  public
    VType: Integer;
    PValue: PVariant;
    constructor Create(AScripter: Pointer);
    destructor Destroy; override;
    property AsInteger: Integer read GetAsInteger write SetAsInteger;
    property AsDouble: Double read GetAsDouble write SetAsDouble;
    property AsCardinal: Cardinal read GetAsCardinal write SetAsCardinal;
    property AsPointer: Pointer read GetAsPointer write SetAsPointer;
    property AsString: String read GetAsString write SetAsString;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsTObject: TObject read GetAsTObject write SetAsTObject;
    property AsVariant: Variant read GetAsVariant write SetAsVariant;
  end;

  TPAXParameterList = class(TList)
  public
    Scripter: Pointer;
    constructor Create(AScripter: Pointer);
    procedure Clear; override;
  end;

  PObject = ^TObject;

  TPAXMethodBody = class
  private
    fResult: TPAXParameter;
    fParameterList: TPAXParameterList;
    fParamCount: Integer;
    fFieldCount: Integer;
    function GetParameter(I: Integer): TPAXParameter;
    procedure SetParameter(I: Integer; Value: TPAXParameter);
    function GetField(I: Integer): TPAXParameter;
    procedure SetField(I: Integer; Value: TPAXParameter);
    function GetSelf: TObject;
    procedure SetSelf(Value: TObject);
    procedure AddParameters(K: Integer);
  public
    PSelf: Pointer;
    Scripter: Pointer;
    Name: String;
    constructor Create(Scripter: Pointer);
    destructor Destroy; override;
    procedure Clear;
    function DefaultValue: Variant;
    function FindNestedClass(const NamespaceName, ClassName: String): Pointer;
    property ParamCount: Integer read fParamCount write fParamCount;
    property FieldCount: Integer read fFieldCount write fFieldCount;
    property Params[I: Integer]: TPAXParameter read GetParameter write SetParameter;
    property Fields[I: Integer]: TPAXParameter read GetField write SetField;
    property Result: TPAXParameter read fResult write fResult;
    property Self: TObject read GetSelf write SetSelf;
  end;

  TPAXDefinition = class
  public
    DefValue: Variant;
  protected
    function GetValue: Variant; virtual;
    function PValue: PVariant; virtual;
    procedure SetValue(const AValue: Variant); virtual;
  public
    Name: String;
    DefKind: TPAXDefKind;
    ml: TPAXModifierList;
    Owner: TPAXDefinition;
    DefList: TPAXDefinitionList;
    Index: Integer;
    UserData: Integer;
    Module: Integer;
    ResultType: String;
    constructor Create(DefList: TPAXDefinitionList;
                       const Name: String; Owner: TPAXDefinition; DefKind: TPAXDefKind);
    procedure Dump(var T: TextFile); virtual; abstract;
    procedure AddToScripter(Scripter: Pointer); virtual;
    procedure AddToScripterList;
    function FullName: String;
    property Value: Variant read GetValue write SetValue;
  end;

  TPAXMethodDefinition = class(TPAXDefinition)
  public
    NP: Integer;
    Proc: TPAXMethodImpl;

    PClass: TClass;
    DirectProc: Pointer;
    CallConv: Integer;
    Header: String;
    Types: array of Integer;
    ExtraTypes: array of Integer;
    StrTypes: array of String;
    ParamNames: array of String;
    ByRefs: array of Boolean;
    Consts: array of Boolean;
    TypeSub: TPAXTypeSub;
    Sizes: array of Integer;
    Fake: Boolean;
    NewFake: Boolean;
    IsStatic: Boolean;
    ReturnsDynamicArray: Boolean;

    DefParamList: TPaxVarList;
    IsIntf: Boolean;
    MethodIndex: Integer;
    intf_pti: PTypeInfo;
    Guid: TGuid;

    constructor Create(DefList: TPAXDefinitionList; const Name: String;
                       Proc: TPAXMethodImpl; NP: Integer; Owner: TPAXDefinition;
                       IsStatic: Boolean);
    destructor Destroy; override;
    procedure Dump(var T: TextFile); override;
    function Duplicate: TPAXMethodDefinition;
    procedure AddToScripter(Scripter: Pointer); override;
    function GetScriptType(ParamNumber: Integer): Integer;
    function LoadFromDll(Scripter: Pointer; SubID: Integer): Boolean;
  end;

  TPAXClassDefinition = class(TPAXDefinition)
  public
    Ancestor: TPAXDefinition;
    PClass: TClass;
    GetPropDef, PutPropDef: TPAXMethodDefinition;
    ClassKind: TPAXClassKind;
    ElType, ElSize: Integer; // dynamic array
    ElTypeName: String;
    IsStaticArray: Boolean;

    IsSet: Boolean; // set
    PtiSet: PTypeInfo;

    RecordSize: Integer; // record;
    pti: PTypeInfo;
    guid: TGuid;

    OwnerList: TStringList;

    constructor Create(DefList: TPAXDefinitionList; const Name: String;
                       Owner, Ancestor: TPAXDefinition);
    destructor Destroy; override;
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
    procedure CreateOwnerList;
    function FindClassRec(Scripter: Pointer): Pointer;
  end;

  TPAXFieldDefinition = class(TPAXDefinition)
  public
    PClass: TClass;
    FieldType: String;
    Offset: Integer;
    TypeID: Integer;
    constructor Create(DefList: TPAXDefinitionList; PClass: TClass; const FieldName,
                       FieldType: String; Offset: Integer);
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
    function GetFieldValue(SO: pointer): Variant;
    procedure SetFieldValue(SO: pointer; const Value: Variant);
    function GetFieldAddress(SO: pointer): Pointer;
  end;

  TPAXRecordFieldDefinition = class(TPAXDefinition)
  public
    FieldType: String;
    Offset: Integer;
    TypeID: Integer;
    constructor Create(DefList: TPAXDefinitionList;
                       Owner: TPaxClassDefinition;
                       const FieldName, FieldType: String;
                       Offset: Integer);
    function GetFieldAddress(Scripter, Address: pointer): Pointer;
    function GetFieldValue(Scripter, Address: pointer): Variant;
    procedure SetFieldValue(Scripter, Address: pointer; const Value: Variant);
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXRTTITypeDefinition = class(TPAXDefinition)
  private
    function GetFinalType: Integer;
  public
    pti: PTypeInfo;
    FinalType: Integer;
    constructor Create(DefList: TPAXDefinitionList; pti: PTypeInfo);
    procedure Dump(var T: TextFile); override;
  end;

  TPAXPropertyDefinition = class(TPAXDefinition)
  public
    PClass: TClass;
    ReadDef, WriteDef: TPAXDefinition;
    PropDef: String;
    PropType: String;
    NP: Integer;
    constructor Create(DefList: TPAXDefinitionList;
                       const Name: String; Owner: TPAXDefinition;
                       PClass: TClass; ReadDef, WriteDef: TPAXDefinition);
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXVariableDefinition = class(TPAXDefinition)
  public
    TypeID: Integer;
    Address: Pointer;
    TypeName: String;
    constructor Create(DefList: TPAXDefinitionList;
                       const Name, TypeName: String;
                       Address: Pointer;
                       Owner: TPAXDefinition);
    function GetValue(Scripter: Pointer): Variant; reintroduce;
    procedure SetValue(Scripter: Pointer; const AValue: Variant); reintroduce;
    function GetAddress: Pointer;
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXObjectDefinition = class(TPAXDefinition)
  public
    Instance: TObject;
    constructor Create(DefList: TPAXDefinitionList;
                       const Name: String;
                       Instance: TObject;
                       Owner: TPAXDefinition);
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXVirtualObjectDefinition = class(TPAXDefinition)
  public
    constructor Create(DefList: TPAXDefinitionList;
                       const Name: String;
                       Owner: TPAXDefinition);
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXInterfaceVarDefinition = class(TPAXDefinition)
  public
    PIntf: PUnknown;
    guid: TGUID;
    constructor Create(DefList: TPAXDefinitionList;
                       const Name: String;
                       PIntf: PUnknown;
                       const guid: TGUID;
                       Owner: TPAXDefinition);
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXConstantDefinition = class(TPAXDefinition)
  public
    TypeID: Integer;
    ck: TPAXClassKind;
    constructor Create(DefList: TPAXDefinitionList;
                       const Name: String;
                       const Value: Variant;
                       Owner: TPAXDefinition);
    function GetAddress: Pointer;
    procedure Dump(var T: TextFile); override;
    procedure AddToScripter(Scripter: Pointer); override;
  end;

  TPAXDefinitionList = class(TList)
  public
    _LastIndex: Integer;
    ClassIdx: TPaxIds;
    ConstIdx: TPaxIds;
    Global: Boolean;
    MethodIdx: TStringList;
    FieldIdx: TStringList;
    RTTITypeDefIdx: TStringList;
    ConstantIdx: TStringList;
    GUIDIdx: TStringList;
  private
    function GetRecord(Index: Integer): TPAXDefinition;
    function NewIndex: Integer;
  public
    constructor Create(Global: Boolean);
    destructor Destroy; override;
    function Lookup(const Name: String;
                    DefKind: TPAXDefKind;
                    Owner: TPAXDefinition;
                    Scripter: Pointer = nil): TPAXDefinition;
    function LookupAll(const Name: String;
                       DefKind: TPAXDefKind;
                       Owner: TPAXDefinition;
                       Scripter: Pointer = nil): TList;
    function LookupFullName(const FullName: String): TPAXDefinition;
    procedure Clear; override;
    function FindClassDef(PClass: TClass): TPAXClassDefinition;
    function FindInterfaceTypeDef(const Guid: TGuid): TPAXClassDefinition;
    function FindClassDefByPTI(pti: PTypeInfo): TPAXClassDefinition;
    function FindClassDefByName(const Name: String): TPAXClassDefinition;
    function FindRTTITypeDef(pti: PTypeInfo): TPAXRTTITypeDefinition;
    function FindRTTITypeDefByName(const Name: String): TPAXRTTITypeDefinition;
    function FindObjectDef(Instance: TObject; Owner: TPaxDefinition): TPAXObjectDefinition;
    function AddField(PClass: TClass; const FieldName, FieldType: String; Offset: Integer): TPaxFieldDefinition;
    function AddRecordField(Owner: TPaxClassDefinition; const FieldName,
                            FieldType: String;
                            Offset: Integer): TPaxRecordFieldDefinition;
    function FindMethod(const ClassName, MethodName: String): TPAXMethodDefinition;
    function FindField(const ClassName, FieldName: String): TPAXFieldDefinition;
    function AddNamespace(const Name: String; Owner: TPAXClassDefinition): TPAXClassDefinition;
    function AddClass1(const Name: String; Owner, Ancestor: TPAXClassDefinition;
                      ReadProp, WriteProp: TPAXMethodImpl): TPAXClassDefinition;
    function AddClass2(PClass: TClass;
                      Owner: TPAXClassDefinition;
                      ReadProp, WriteProp: TPAXMethodImpl;
                      ClassKind: TPAXClassKind = ckClass): TPAXClassDefinition;
    function AddMethod1(const Header: String; Address: Pointer;
                       Owner: TPAXDefinition; Static: Boolean = false): TPAXMethodDefinition;
    function AddMethod2(PClass: TClass; const Header: String; Address: Pointer;
                       Static: Boolean = false): TPAXMethodDefinition;
    function AddMethod3(const Name: String;
                       Proc: TPAXMethodImpl;
                       NP: Integer;
                       Owner: TPAXClassDefinition;
                       Static: Boolean = false): TPAXMethodDefinition;
    function AddMethod4(PClass: TClass;
                       const Name: String;
                       Proc: TPAXMethodImpl;
                       NP: Integer;
                       Static: Boolean = false): TPAXMethodDefinition;
    function AddMethod5(pti: PTypeInfo; const Header: String): TPAXMethodDefinition;
    function AddMethod6(const Guid: TGuid; const Header: String;
                        InitMethodIndex: Integer = -1): TPAXMethodDefinition;
    function AddFakeMethod(PClass: TClass; const Header: String; Address: Pointer;
                       Static: Boolean = false): TPAXMethodDefinition;
    function AddProperty1(PClass: TClass;
                         const Name: String;
                         ProcRead: TPAXMethodImpl;
                         NPRead: Integer;
                         ProcWrite: TPAXMethodImpl;
                         NPWrite: Integer;
                         Default: Boolean = false): TPAXPropertyDefinition; overload;
    function AddProperty2(PClass: TClass; const Name: String;
                         ReadDef, WriteDef: TPAXMethodDefinition;
                         Default: Boolean = false): TPAXPropertyDefinition; overload;
    function AddProperty3(PClass: TClass; const PropDef: String): TPAXPropertyDefinition; overload;
    function AddInterfaceProperty(const guid: TGUID; const PropDef: String): TPAXPropertyDefinition;
    function AddVariable(const Name, TypeName: String;
                         Address: Pointer;
                         Owner: TPAXClassDefinition;
                         Scripter: Pointer = nil): TPAXVariableDefinition;
    function AddObject(const Name: String;
                       Instance: TObject;
                       Owner: TPAXClassDefinition;
                       Scripter: Pointer = nil): TPAXObjectDefinition;
    function AddVirtualObject(const Name: String;
                              Owner: TPAXClassDefinition;
                              Scripter: Pointer = nil): TPAXVirtualObjectDefinition;
    function AddInterfaceVar(const Name: String;
                                            PIntf: PUnknown;
                                            const guid: TGUID;
                                            Owner: TPAXClassDefinition;
                                            Scripter: Pointer = nil): TPAXInterfaceVarDefinition;
    function AddConstant(const Name: String;
                         const Value: Variant;
                         Owner: TPAXClassDefinition;
                         Static: Boolean = true;
                         ck: TPAXClassKind = ckNone;
                         Scripter: Pointer = nil): TPAXConstantDefinition;
    function AddRTTIType(pti: PTypeInfo): TPAXRTTITypeDefinition;
    function AddInterfaceType(const Name: String; Guid: TGuid;
                              const ParentName: String; ParentGuid: TGUID;
                              Owner: TPaxClassDefinition): TPAXClassDefinition;

    function AddEnumTypeByDef(const TypeDef: WideString): TPAXClassDefinition;
    function AddDynamicArrayType(const TypeName, ElementTypeName: String;
                                 Owner: TPaxDefinition):TPAXClassDefinition;
    function AddRecordType(const TypeName: String;
                           Size: Integer;
                           Owner: TPaxDefinition):TPAXClassDefinition;
    procedure Dump(const FileName: String);

    function GetKind(Index: Integer): Integer;
    function GetCount(Index: Integer): Integer;
    function GetName(Index: Integer): String;
    function GetParamTypeName(Index, ParamIndex: Integer): String;
    function GetParamName(Index, ParamIndex: Integer): String;
    function GetTypeName(Index: Integer): String;
    function GetFullName(Index: Integer): String;
    function GetNameIndex(Index: Integer; Scripter: Pointer): Integer;

    function GetAddress(Scripter: Pointer; Index: Integer): Pointer;
    function GetUserData(Scripter: Pointer; Index: Integer): Integer;
    function GetVariant(Scripter: Pointer; Index: Integer): Variant;
    procedure PutVariant(Scripter: Pointer; Index: Integer; const Value: Variant);
    function GetPVariant(Scripter: Pointer; Index: Integer): PVariant;
    function GetRecordByIndex(Index: Integer): TPAXDefinition;
    procedure Unregister(const Name: String;
                         DefKind: TPAXDefKind;
                         Owner: TPAXDefinition;
                         Scripter: Pointer = nil);
    procedure UnregisterAll(DefKind: TPAXDefKind;
                            Scripter: Pointer);
    procedure UnregisterObject(Instance: TObject; Owner: TPaxDefinition);

    function UnregisterNamespace(const Namespacename: String): Boolean;
    property Records[Index: Integer]: TPAXDefinition read GetRecord;
  end;

  TPAXFieldRec = class
  public
    ObjectName: String;
    ObjectType: String;
    FieldName: String;
    FieldType: String;
    Address: Pointer;
  end;

  TPAXFieldList = class
  private
    fList: TList;
    function GetRecord(Index: Integer): TPAXFieldRec;
  public
    constructor Create;
    destructor Destroy; override;
    function Count: Integer;
    procedure AddRec(const ObjectName: String;
                     ObjectType: String;
                     FieldName: String;