base_class.pas

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

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


{$I PaxScript.def}
unit BASE_CLASS;
interface

uses
{$IFDEF WIN32}
  Windows,
{$ENDIF}
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils,
  Classes,
  TypInfo,
  BASE_CONSTS,
  BASE_SYS,
  BASE_EXTERN;

type
  TPAXScriptObject = class;

  TPAXScriptObjectClass = class of TPAXScriptObject;

  TPAXMemberRec = class;
  TPAXClassRec = class;
  TPAXClassList = class;

  TPAXProperty = class
  private
    SO: TPAXScriptObject;
    fUpCaseIndex: Integer;
    ExtraDef: TPAXDefinition;
    Scripter: Pointer;
    Val: Variant;
    function GetValue(NParams: Integer): Variant;
    procedure PutValue(NParams: Integer; const AValue: Variant);
    function GetReadID: Integer;
    function GetWriteID: Integer;
  public
    MemberRec: TPAXMemberRec;
    fValue: PVariant;
    constructor Create(SO: TPAXScriptObject; PValue: PVariant;
                       MemberRec: TPAXMemberRec);
    function IsImported: Boolean;
    function IsStatic: Boolean;
    function Definition: TPAXDefinition;
    function PTerminalValue: PVariant;
    function GetAddress(NParams: Integer): PVariant;
    function GetKind: Integer;
    property ReadID: Integer read GetReadID;
    property WriteID: Integer read GetWriteID;
    property Value[NParams: Integer]: Variant read GetValue write PutValue;
    property UpCaseIndex: Integer read fUpCaseIndex;
  end;

  TPAXPropertyList = class(TPAXIndexedList)
  private
    Scripter: Pointer;
    function GetProperty(I: Integer): TPAXProperty;
    function GetName(I: Integer): String;
  public
    constructor Create(Scripter: Pointer);
    function FindProperty(PropertyNameIndex: Integer): TPAXProperty;
    function GetDefaultProperty: TPAXProperty;
    property Names[I: Integer]: String read GetName;
    property Properties[I: Integer]: TPAXProperty read GetProperty;
  end;

  TPAXScriptObject = class(TPersistent)
  public
    PropertyList: TPAXPropertyList;
    ClassRec: TPAXClassRec;

    HasFordiddenProperties: Boolean;

    function GetClassDef: TPAXClassDefinition;
  public
    Instance: TObject;
    PClass: TClass;
    RefCount: Integer;
    IsClass: Boolean;
    Intf: IUnknown;
    PIntf: PUnknown;

    ExtraPtr: Pointer;
    ExtraPtrSize: Integer;
    ExternalExtraPtr: Boolean;

    ThreadID: Cardinal;

    _ObjCount: Int64;

    constructor Create(ClassRec: TPAXClassRec); virtual;
    destructor Destroy; override;
    function HasProperty(const PropertyName: String): Boolean; virtual;
    function Get(PropertyNameIndex: Integer): TPAXProperty;
    function SafeGet(PropertyNameIndex: Integer): TPAXProperty; virtual;
    function Put(PropertyNameIndex: Integer;
                 const Value: Variant; NParams: Integer): TPAXProperty;
    function GetAddress(PropertyNameIndex: Integer;
                        NParams: Integer): PVariant;
    procedure ClearProperty(PropertyNameIndex: Integer);
    function GetProperty(PropertyNameIndex: Integer;
                         NParams: Integer): Variant; virtual;
    procedure PutProperty(PropertyNameIndex: Integer;
                          const Value: Variant; NParams: Integer); virtual;
    function GetDefaultProperty(NParams: Integer): Variant;
    procedure PutDefaultProperty(const Value: Variant; NParams: Integer);
    function CreateProperty(PropertyNameIndex: Integer;
                            PValue: PVariant;
                            MemberRec: TPAXMemberRec): TPAXProperty;
    procedure PutPublishedProperty(const PropertyName: String; const Value: Variant);
    function GetPublishedProperty(const PropertyName: String; NParams: Integer): Variant;
    function HasPublishedProperty(const PropertyName: String): Boolean;

    function Duplicate: TPAXScriptObject;
    function ToString: String; virtual;
    function Scripter: Pointer;
    function IsImported: Boolean;
    function DefaultValue: Variant; virtual;
    function GetPropertyName(Index: Integer): String; virtual;
    function ExtraInstance: TObject; virtual;
    procedure CallAutoDestructor;
    procedure SetDefaultValue(const V: Variant); virtual;
    procedure FreeExtraPtr;
    property ClassDef: TPAXClassDefinition read GetClassDef;
  end;

  TPAXMemberRec = class
  public
    ID, ReadID, WriteID, InitN: Integer;
    ml: TPAXModifierList;
    Kind: Integer;
    Definition: TPAXDefinition;
    UpCaseIndex: Integer;
    fClassRec: TPAXClassRec;
    IsSource: Boolean;
    IsPublished: Boolean;
    NParams: Integer;
    IsImplementationSection: Boolean;
    constructor Create(ID: Integer; ClassRec: TPAXClassRec);
    destructor Destroy; override;
    function Scripter: Pointer;
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream;
                             DS: Integer = 0; DP: Integer = 0);
    function IsStatic: boolean;
    function IsDefault: Boolean;
    function IsImported: Boolean;
    function IsImportedObject: Boolean;
    procedure CheckAccess;
    function GetName: String;
    function GetNameIndex: Integer;
  end;

  TPAXMemberList = class(TPAXIndexedList)
  private
    Owner: TPAXClassRec;
    function GetRecord(Index: Integer): TPAXMemberRec;
    function Scripter: Pointer;
  public
    constructor Create(Owner: TPAXClassRec);
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream;
                             DS: Integer = 0; DP: Integer = 0);
    function GetMemberID(const Name: String; UpCase: Boolean = true): Integer;
    function IndexOfMember(const Name: String; UpCase: Boolean = true): Integer;
    function GetMemberRec(const Name: String; UpCase: Boolean = true): TPAXMemberRec;
    function GetMemberRecByID(MemberID: Integer): TPAXMemberRec;
    function UpperCaseIndexOf(UpCaseIndex: Integer): Integer;
    procedure DeleteMember(const Name: String; UpCase: Boolean = true);
    property Records[Index: Integer]: TPAXMemberRec read GetRecord; default;
  end;

  TPAXHeapItem = class(TPersistent)
  public
    constructor Create(H: TPaxObjectList);
  end;

  TPAXCompileTimeHeap = class(TPaxObjectList)
  public
    procedure ResetCompileStage;
  end;

  TPAXClassRec = class
  public
    NameIdx: Integer;
    UpCaseIndex: Integer;
    AncestorClassRec: TPAXClassRec;
    ClassObject: TPAXScriptObject;
    Name: String;
    OwnerName, AncestorName: String;
    Scripter: Pointer;
    ClassID: Integer;
    ModuleID: Integer;
    ml: TPAXModifierList;
    MemberList: TPAXMemberList;
    ck: TPAXClassKind;
    IsStaticArray: Boolean;
    OwnerClassRec: TPAXClassRec;
    fClassDef: TPAXClassDefinition;

    UsingInitList: TPaxIds;
    AutoDestructorID: Integer;

    isSet: Boolean;
    PtiSet: PTypeInfo;

    fHasRunTimeProperties: Boolean;

    constructor Create(AScripter: Pointer; kc: TPAXClassKind);
    destructor Destroy; override;
    procedure ResetCompileStage;
    procedure SaveToStream(S: TStream);
    procedure LoadFromStream(S: TStream;
                             DS: Integer = 0; DP: Integer = 0);
    function GetClassDef: TPAXClassDefinition;
    function AddField(ID: Integer; ml: TPAXModifierList): TPAXMemberRec;
    function AddMethod(ID: Integer; ml: TPAXModifierList): TPAXMemberRec;
    function AddProperty(ID: Integer; ml: TPAXModifierList): TPAXMemberRec;
    function AddNestedClass(ID: Integer; ml: TPAXModifierList): TPAXMemberRec;
    function CreateScriptObject(const ObjectName: String = ''): TPAXScriptObject;
    procedure CreateClassObject;
    function GetMember(MemberNameIndex: Integer; UpCaseOn: Boolean = true): TPAXMemberRec;
    function FindMember(MemberNameIndex: Integer; ma: TPAXMemberAccess; UpCaseOn: Boolean = true): TPAXMemberRec;
    function FindMemberEx(MemberNameIndex: Integer;
                         ma: TPAXMemberAccess;
                         var FoundInBaseClass: Boolean;
                         UpCaseON: Boolean = true): TPAXMemberRec;
    function IsNestedClass(ClassID: Integer): Boolean;
    function FindNestedClassID(ClassNameIndex: Integer): Integer;
    function AddHostMethod(D: TPAXMethodDefinition): TPAXMemberRec;
    function AddHostProperty(D: TPAXPropertyDefinition): TPAXMemberRec;
    function AddHostConstant(D: TPAXConstantDefinition): TPAXMemberRec;
    function AddHostVariable(D: TPAXVariableDefinition): TPAXMemberRec;
    function AddHostObject(D: TPAXObjectDefinition): TPAXMemberRec;
    function AddVirtualObject(D: TPAXVirtualObjectDefinition): TPAXMemberRec;
    function AddHostInterfaceVar(D: TPAXInterfaceVarDefinition): TPAXMemberRec;
    function AddHostField(D: TPAXFieldDefinition): TPAXMemberRec;
    function AddHostRecordField(D: TPAXRecordFieldDefinition): TPAXMemberRec;
    function FindOverloadedSubID(NameIndex: Integer; ma: TPAXMemberAccess; NP: Integer): Integer;
    procedure FindOverloadedSubList(NameIndex: Integer;
                                    ma: TPAXMemberAccess;
                                    Ids: TPaxIds);
    function IsImported: Boolean;
    function InheritsFromClass(AClassID: Integer): Boolean;
    procedure DeleteMember(ID: Integer);
    function GetConstructorID: Integer;
    function GetConstructorIDEx: Integer; overload;
    function GetConstructorIDEx(const Params: array of const): Integer; overload;
    function GetClassList: TPAXClassList;
    procedure InitStaticFields;
    function ModuleName: String;
    function IsStatic: Boolean;
    function DelphiClass: TClass;
    function DelphiClassEx: TClass;
    function HasPublishedProperty(const PropertyName: String): Boolean;
    function HasPublishedPropertyEx(const PropertyName: String; var AClassName: String): Boolean;
    function FindBinaryOperatorID(const OperName: String; T1, T2: Integer): Integer;
    function FindUnaryOperatorID(const OperName: String; T: Integer): Integer;
    function HasRunTimeProperties: Boolean;
  end;

  TPAXClassList = class(TPAXIndexedList)
  private
    Scripter: Pointer;
    SaveCount: Integer;

    function GetRecord(Index: Integer): TPAXClassRec;
    function GetSourceClassList: TList;
  public
    DelegateClassRec,
    ObjectClassRec, BooleanClassRec, StringClassRec, NumberClassRec,
    DateClassRec, FunctionClassRec, ArrayClassRec,
    ActiveXClassRec: TPAXClassRec;

    constructor Create(AScripter: Pointer);
    destructor Destroy; override;
    procedure SaveToStream(S: TStream; I1, I2: Integer);
    procedure LoadFromStream(S: TStream);
    procedure Reset;
    procedure ResetCompileStage;

    procedure InitRunStage;
    procedure ResetRunStage;

    function AddClass(ClassID: Integer;
                      const AClassName, OwnerName, AncestorName: String;
                      ml: TPAXModifierList; ck: TPAXClassKind; UpCase: boolean): TPAXClassRec;
    function FindClass(ClassID: Integer): TPAXClassRec;
    function FindClassByGuid(const guid: TGUID): TPAXClassRec;
    function FindImportedClass(PClass: TClass): TPAXClassRec;
    function ExistsClassByName(const Name: String): boolean;
    function FindClassByName(const Name: String): TPAXClassRec;
    function FindClassByInstance(Instance: TObject): TPAXClassRec;
    function FindNestedClass(OwnerList: TStringList; const Name: String): TPAXClassRec;
    function CreateScriptObject(ClassID: Integer): TPAXScriptObject;
    function FindMember(ClassID, MemberNameIndex: Integer; ma: TPAXMemberAccess): TPAXMemberRec;
    procedure CreateClassObjects(StartRecNo: Integer);
    procedure InitStaticFields(StartRecNo: Integer);
    procedure AddDefinitionList(L: TPAXDefinitionList; N: Integer);

    function CreateBooleanObject(const AValue: Variant): TPaxScriptObject;
    function CreateNumberObject(const AValue: Variant): TPaxScriptObject;
    function CreateStringObject(const AValue: Variant): TPaxScriptObject;
    function CreateDateObject(const AValue: Variant): TPaxScriptObject;
    function CreateFunctionObject(const AValue: Variant): TPaxScriptObject;

    procedure Dump(const FileName: String);
    property Records[Index: Integer]: TPAXClassRec read GetRecord; default;
  end;

  TPAXScriptObjectList = class
  private
    fPaxObjects: TList;
    _Scripter: Pointer;
     function GetCount: Integer;
     function GetItem(I: Integer): TPaxScriptObject;
  public
    constructor Create(_Scripter: Pointer);
    destructor Destroy; override;
    procedure Clear;
    procedure Add(SO: TPaxScriptObject);
    procedure Delete(I: Integer);

    function IndexOfDelphiObject(DelphiInstance: TObject): Integer;
    function FindScriptObject(DelphiInstance: TObject): TPAXScriptObject;
    function FindScriptObjectByIntf(PIntf: PUnknown): TPAXScriptObject;
    procedure ResetCompileStage(FreeHost: boolean = false);
    procedure RemoveObject(SO: TPAXScriptObject);
    procedure RemoveStructure(const V: Variant);
    procedure ResetRunStage(FreeHost: Boolean = false);
    procedure RemoveTail(K: Integer; ThreadID: Cardinal = 0);
    function HasObject(SO: TPAXScriptObject): Boolean;
    property PaxObjects: TList read fPaxObjects;
    property Count: Integer read GetCount;
    property Items[I: Integer]: TPaxScriptObject read GetItem; default;
  end;

  TPAXDelegate = class(TPAXHeapItem)
  public
    SubID, N: Integer;
    D: TPAXMethodDefinition;
    fName: String;
    constructor Create(Scripter: Pointer;
                       SubID, N: Integer; D: TPAXMethodDefinition);
    destructor Destroy; override;
  published
    property Name: String read fName write fName;
  end;

  TPAXError = class(TPersistent)
  private
    fScriptTime: String;
    fDescription: String;
    fModuleName: String;
    fFileName: String;
    fLine: String;
    fLineNumber: Integer;
    fPosition: Integer;
    fTextPosition: Integer;
    fMethodId: Integer;
    fErrClassType: TClass;
  public
    constructor Create;
  published
    property ScriptTime: String read fScriptTime write fScriptTime;
    property Description: String read fDescription write fDescription;
    property Message: String read fDescription write fDescription;
    property ModuleName: String read fModuleName write fModuleName;
    property FileName: String read fFileName write fFileName;
    property Line: String read fLine write fLine;
    property LineNumber: Integer read fLineNumber write fLineNumber;
    property Position: Integer read fPosition write fPosition;
    property TextPosition: Integer read fTextPosition write fTextPosition;
    property MethodId: Integer read fMethodId write fMethodId;
    property ErrClassType: TClass read fErrClassType write ferrClassType;
  end;

  ActiveXObject = class
  public
    D: Variant;
    constructor Create(Scripter: Pointer);
  end;

function ScriptObjectToVariant(const Value: TPAXScriptObject): Variant;
function VariantToScriptObject(const Value: Variant): TPAXScriptObject;
function ToStr(Scripter: Pointer; const V: Variant): String;
function _ToStr(Scripter: Pointer; const V: Variant): String;
function ToInteger(const V: Variant): Integer;
function CreateNameIndex(const Name: String; Scripter: Pointer): Integer;
function NameIndexToUpperCaseIndex(NameIndex: Integer; Scripter: Pointer): Integer;
function DuplicateObject(const V: Variant): Variant;
function IsPaxArray(const V: Variant): Boolean;
function IsDynamicArray(const V: Variant): Boolean;

function ToObject(const Value: Variant; Scripter: Pointer): Variant;
function ToPrimitive(const V: Variant): Variant;
function ToString(const Value: Variant): String;
function ToNumber(const V: Variant): Variant;
function ToDate(const V: Variant): Variant;
function ToInt32(const V: Variant): Variant;
function ToInt64(const V: Variant): Variant;
function ToBoolean(const V: Variant): Variant;
function IsNaN(const V: Variant): boolean;
function RelationalComparison(const V1, V2: Variant): Variant;
function EqualityComparison(const V1, V2: Variant): TBoolean;
function StrictEqualityComparison(const V1, V2: Variant): TBoolean;
procedure SortVariants(var A: array of Variant);
function StringValueToVariant(const S: String; const Dest: Variant): Variant;
function UntypedValueToVariant(P: Pointer; Count: Integer; const Dest: Variant): Variant;
procedure VariantToUntypedValue(const V: Variant; P: Pointer; Count: Integer);
function TVarRecToVariant(const P: TVarRec; Scripter: Pointer): Variant;

function IsDateObject(const V: Variant): Boolean;
function IsStringObject(const V: Variant): Boolean;
function IsNumberObject(const V: Variant): Boolean;
function IsBooleanObject(const V: Variant): Boolean;
function IsFunctionObject(const V: Variant): Boolean;

function IsHostObject(const V: Variant): Boolean;

function DelphiInstanceToScriptObject(Instance: TObject; Scripter: Pointer;
                                      RaiseException: boolean = true): TPAXScriptObject;
function DelphiClassToScriptObject(AClass: TClass; Scripter: Pointer): TPAXScriptObject;
function InterfaceToScriptObject(const I: IUnknown; Scripter: Pointer;
                                 const InterfaceClassName: String = ''): TPaxScriptObject;

var
  BooleanClass: TPAXScriptObjectClass = nil;
  NumberClass: TPAXScriptObjectClass = nil;
  StringClass: TPAXScriptObjectClass = nil;
  DateClass: TPAXScriptObjectClass = nil;
  FunctionClass: TPAXScriptObjectClass = nil;

implementation

uses
  BASE_SCRIPTER, BASE_SYMBOL, BASE_CODE, BASE_EVENT, BASE_REGEXP, BASE_CONV;