TObject = class
//创建
constructor Create;
//释放
procedure Free;
//初始化实列
class function InitInstance(Instance: Pointer): TObject;
//清除实列
procedure CleanupInstance;
//获得类的类型
function ClassType: TClass;
//获得了的名称
class function ClassName: ShortString;
//判断类的名称
class function ClassNameIs(const Name: string): Boolean;
//类的父类
class function ClassParent: TClass;
//类的信息指针
class function ClassInfo: Pointer;
//当前类的实列大小
class function InstanceSize: Longint;
//判断是否从一个类继承下来
class function InheritsFrom(AClass: TClass): Boolean;
//根据方法的名称获得方法的地址
class function MethodAddress(const Name: ShortString): Pointer;
//根据地址或的方法的名称
class function MethodName(Address: Pointer): ShortString;
//根据名称获得属性的地址
function FieldAddress(const Name: ShortString): Pointer;
//查询接口
function GetInterface(const IID: TGUID; out Obj): Boolean;
//获得接口的入口
class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
//获得接口表
class function GetInterfaceTable: PInterfaceTable;
//安全调用例外
function SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult; virtual;
//创建之后的执行
procedure AfterConstruction; virtual;
//释放之前的执行
procedure BeforeDestruction; virtual;
//分派消息
procedure Dispatch(var Message); virtual;
//默认的句柄
procedure DefaultHandler(var Message); virtual;
//新的实列
class function NewInstance: TObject; virtual;
//释放实列
procedure FreeInstance; virtual;
//释放
destructor Destroy; virtual;
end;
//初始化实列
class function TObject.InitInstance(Instance: Pointer): TObject;
{$IFDEF PUREPASCAL}
var
IntfTable: PInterfaceTable;
ClassPtr: TClass;
I: Integer;
begin
//分配需要的内存的大小
FillChar(Instance^, InstanceSize, 0);
//实列化分配好的内存
PInteger(Instance)^ := Integer(Self);
ClassPtr := Self;
//如果成功
while ClassPtr <> nil do
begin
//获得接口表
IntfTable := ClassPtr.GetInterfaceTable;
//遍历接口
if IntfTable <> nil then
for I := 0 to IntfTable.EntryCount-1 do
//初始化每个接口函数的具体实现
with IntfTable.Entries[I] do
begin
if VTable <> nil then
PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable);
end;
ClassPtr := ClassPtr.ClassParent;
end;
Result := Instance;
end;
//清除实列
procedure TObject.CleanupInstance;
{$IFDEF PUREPASCAL}
var
ClassPtr: TClass;
InitTable: Pointer;
begin
//获得当前的类型
ClassPtr := ClassType;
//获得初始化标的地址
InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^;
//如果当前类存在 并且初始化表也存在
while (ClassPtr <> nil) and (InitTable <> nil) do
begin
//释放所有的信息
_FinalizeRecord(Self, InitTable);
//如果当前类有父类 则清楚父类的信息
ClassPtr := ClassPtr.ClassParent;
if ClassPtr <> nil then
InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^;
end;
end;
//获得当前类的类型
function TObject.ClassType: TClass;
begin
//就是返回当前类的指针
Pointer(Result) := PPointer(Self)^;
end;
//获得当前类的类名
class function TObject.ClassName: ShortString;
{$IFDEF PUREPASCAL}
begin
//根据虚拟方发表返回指定的地址
Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^;
end;
// 判断当前类的类名
class function TObject.ClassNameIs(const Name: string): Boolean;
{$IFDEF PUREPASCAL}
var
Temp: ShortString;
I: Byte;
begin
Result := False;
//获得当前类的类名得指针
Temp := ClassName;
//根据字符串的长度比较每个字符 区分大小写
for I := 0 to Byte(Temp[0]) do
if Temp[I] <> Name[I] then Exit;
Result := True;
end;
//获得当前类的父类
class function TObject.ClassParent: TClass;
{$IFDEF PUREPASCAL}
begin
//根据虚拟方法表或的父的地址指针
Pointer(Result) := PPointer(Integer(Self) + vmtParent)^;
//如果存在父类 则返回
if Result <> nil then
Pointer(Result) := PPointer(Result)^;
end;
{$ELSE}
asm
MOV EAX,[EAX].vmtParent
TEST EAX,EAX
JE @@exit
MOV EAX,[EAX]
@@exit:
end;
//获得类型信息
class function TObject.ClassInfo: Pointer;
begin
Result := PPointer(Integer(Self) + vmtTypeInfo)^;
end;
//获得实列大小
class function TObject.InstanceSize: Longint;
begin
Result := PInteger(Integer(Self) + vmtInstanceSize)^;
end;
//判断是否从一个类继承下来
class function TObject.InheritsFrom(AClass: TClass): Boolean;
{$IFDEF PUREPASCAL}
var
ClassPtr: TClass;
begin
ClassPtr := Self;
//当前类是否存在 并且和比较的类不等
while (ClassPtr <> nil) and (ClassPtr <> AClass) do
//获得这个类的父类
ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^;
Result := ClassPtr = AClass;
end;
{$ELSE}
asm
{ -> EAX Pointer to our class }
{ EDX Pointer to AClass }
{ <- AL Boolean result }
JMP @@haveVMT
@@loop:
MOV EAX,[EAX]
@@haveVMT:
CMP EAX,EDX
JE @@success
MOV EAX,[EAX].vmtParent
TEST EAX,EAX
JNE @@loop
JMP @@exit
@@success:
MOV AL,1
@@exit:
end;
//根据方法名称获得地址
class function TObject.MethodAddress(const Name: ShortString): Pointer;
asm
{ -> EAX Pointer to class }
{ EDX Pointer to name }
PUSH EBX
PUSH ESI
PUSH EDI
XOR ECX,ECX //清零
XOR EDI,EDI //清零
MOV BL,[EDX] //获得字符串的长度
JMP @@haveVMT //判断是否有虚拟方发表
@@outer: { upper 16 bits of ECX are 0 ! }
MOV EAX,[EAX]
@@haveVMT:
MOV ESI,[EAX].vmtMethodTable //获得虚拟方发表的地址
TEST ESI,ESI |