Salutations à tous ceux qui ont commencé à lire cet article! Je veux vous inviter (et dans une large mesure aux fans d'Object Pascal, amoureux des astuces de programmation, des techniques et des raffinements syntaxiques) à vous familiariser avec la traduction du post plutôt ancien (2007) "Hack # 17: Variables de classe virtuelles, Partie I" et "Hack # 17: Variables de classe virtuelle, partie II , par Hallvard Vassbotn, développeur renommé et auteur de nombreuses techniques orientées Delphi.
Le message de Hallward est consacré à l'un des sujets les plus intéressants - la possibilité de placer et d'utiliser des données associées à une classe particulière d'objets d'application. Si vous avez pensé aux constantes ou aux variables de classe, vous aurez raison, mais seulement partiellement.
Cet article concerne la classe virtual var., en russe, cette phrase sonne comme une variable virtuelle d'une classe (c'est précisément cette phrase qui est placée au nom de cette traduction). Vous direz qu'il n'y a pas une telle construction syntaxique dans Object Pascal, et vous aurez absolument raison. De plus, je suis sûr que des experts et des développeurs dans d'autres langages de programmation OO déclareront: dans ma pratique, je n'ai jamais entendu, rencontré ou utilisé quelque chose comme ça. Comme tout je "ne vois pas de gopher ...", mais je soutiendrai qu'il peut exister. Et cela sera discuté dans le texte de la traduction proposée.
Préface du traducteur
Au cours des nombreuses années qui se sont écoulées depuis la première fois que j'ai lu le post Hallward, je n'ai pas pu décider d'utiliser sa merveilleuse idée dans mes projets. Mais sa beauté et la solution de contournement offerte par Hallward ne m'ont pas laissé et ne me laissent toujours pas tranquille.
Il était temps de collecter des pierres: j'avais une tâche pour laquelle la meilleure solution pour sa mise en œuvre serait juste un «hack» (et j'appellerais encore de tels hacks des méthodes technologiques) de Hallward. Une fois que vous pouvez l'utiliser, vous devez vous préparer à l'imprévu - étudier à nouveau le matériel, relire la charte, les instructions ...
Je voudrais clarifier mes motivations pour travailler sur la traduction des messages Hallward.
( 1, 2) , , , , ( aka GunSmoker , - ), – . , , ( : « , .»).
. Borland ( 1998 !) Object Pascal. - 2007 Object Pascal ( Delphi 2005-Delphi 2007). , (Patrick van Logchem) – .
. , . , .
, …
# 17. . I
Object Pascal- class var Delphi 8 .NET, Delphi 2005 Win32. class var Object Pascal ( ) , . , Delphi-, , .
, . Delphi 7 :
type
TFruit = class
public
constructor Create;
class function InstanceCount: integer;
end;
implementation
var
FInstanceCount: integer;
constructor TFruit.Create;
begin
inherited Create;
Inc(FInstanceCount);
end;
class function TFruit.InstanceCount: integer;
begin
Result := FInstanceCount;
end;
FInstanceCount « ». , () , . (, , , NewInstance FreeInstance , . , – HV).
Delphi 2007, , class var ( Delphi 8 for .NET).
type
TFruit = class
private
class var FInstanceCount: integer;
public
constructor Create;
class property InstanceCount: integer read FInstanceCount;
end;
implementation
constructor TFruit.Create;
begin
inherited Create;
Inc(FInstanceCount);
end;
, InstanceCount . . 10 D4DNP [1] ( [2]).
, , -, ( ) . FInstanceCount . , TFruit -.
, , , , - :
type
TApple = class(TFruit)
end;
TOrange = class(TFruit)
end;
procedure Test;
var
List: TList;
begin
List := TList.Create;
List.Add(TApple.Create);
List.Add(TApple.Create);
List.Add(TOrange.Create);
Writeln('Apples: ', TApple.InstanceCount);
Writeln('Oranges: ', TOrange.InstanceCount);
readln;
end;
2 1 , :
Apples: 3
Oranges: 3
, , , TFruit, TApple TOrange.
. , . :
type
TFruit = class
private
class var FInstanceCount: integer;
public
constructor Create;
class function InstanceCount: integer; virtual;
end;
TApple = class(TFruit)
private
class var FInstanceCount: integer;
public
constructor Create;
class function InstanceCount: integer; override;
end;
TOrange = class(TFruit)
private
class var FInstanceCount: integer;
public
constructor Create;
class function InstanceCount: integer; override;
end;
implementation
constructor TFruit.Create;
begin
inherited Create;
Inc(FInstanceCount);
end;
class function TFruit.InstanceCount: integer;
begin
Result := FInstanceCount;
end;
constructor TApple.Create;
begin
inherited Create;
Inc(FInstanceCount);
end;
class function TApple.InstanceCount: integer;
begin
Result := FInstanceCount;
end;
constructor TOrange.Create;
begin
inherited Create;
Inc(FInstanceCount);
end;
class function TOrange.InstanceCount: integer;
begin
Result := FInstanceCount;
end;
, , , , , :
Apples: 2
Oranges: 1
(, -), , . InstanceCount — ?
, , – , , V. (virtual class var) – , – , . :
class var FInstanceCount: integer; virtual;
, , «virtual» . , «virtual» , , virtual . - :
TFruit = class
private
class virtual var FInstanceCount: integer;
public
constructor Create;
class property InstanceCount: integer read FInstanceCount;
end;
TApple = class(TFruit)
end;
TOrange = class(TFruit)
end;
implementation
constructor TFruit.Create;
begin
inherited Create;
Inc(FInstanceCount);
end;
class function TFruit.InstanceCount: integer;
begin
Result := FInstanceCount;
end;
procedure Test;
var
List: TList;
begin
List := TList.Create;
List.Add(TApple.Create);
List.Add(TApple.Create);
List.Add(TOrange.Create);
Writeln('Apples: ', TApple.InstanceCount);
Writeln('Oranges: ', TOrange.InstanceCount);
readln;
end;
, , :
Apples: 2
Oranges: 1
, 1998 ( Delphi 4 ) Borland . (that has been Closed with As Designed ages ago — , [ , ! – . .]):
, . . :
type
TFoo = class
private
class FBar: integer;
class procedure SetBar(Value: integer);
public
class property Bar: integer read FBar write SetBar;
end;
class procedure TFoo.SetBar(Value: integer);
begin
if Value <> FBar then
begin
FBar := Value;
end;
end;
. , , , , . , . .
( , ClassName InstanceSize ). , . , ?
TFoo = class
private
class FBar: integer; const;
( ), , . , ; . (Borland/CodeGear) , , , ( ?).
? , ( ): VMT . VMT . ( BASM VMTINDEX) VMT- .
VMT-
VMT ? . , VMT ( 100% ). , , VMT - .
[3], , DEP (Data Execution Protection — ), . , , . « », . :
procedure PatchCodeDWORD(Code: PDWORD; Value: DWORD);
var
RestoreProtection, Ignore: DWORD;
begin
if VirtualProtect(Code, SizeOf(Code^), PAGE_EXECUTE_READWRITE,
RestoreProtection) then
begin
Code^ := Value;
VirtualProtect(Code, SizeOf(Code^), RestoreProtection, Ignore);
FlushInstructionCache(GetCurrentProcess, Code, SizeOf(Code^));
end;
end;
. «», , . , , . .
Class Field Table
- V , — . , . VMT - – ClassFieldTable (, , VMT). (), . , , -. — ClassFieldTable- V .
-. ClassFieldTable - V , / .
, «» ( AnsiString, WideString, , Variant ) .
, , , . , 3 . -
type
TFruit = class
private
class virtual var FInstanceCount: integer;
public
constructor Create;
class property InstanceCount: integer read FInstanceCount;
end;
TCitrus = class(TFruit)
end;
TOrange = class(TCitrus)
private
class virtual var ClassDescription: string;
end;
-, , , :
type
TFruit = class
private
class virtual var FInstanceCount: integer;
public
constructor Create;
class property InstanceCount: integer read FInstanceCount;
end;
TCitrus = class(TFruit)
end;
TOrange = class(TCitrus)
private
class virtual var ClassDescription: string;
end;
var
FruitClassVars = record
FInstanceCount: integer;
end;
CitrusClassVars = record
FInstanceCount: integer;
end;
OrangeClassVars = record
FInstanceCount: integer;
ClassDescription: string;
end;
TFruitVMT = record
ClassVarTable := @FruitClassVars;
end;
TCitrusVMT = record
ClassVarTable := @CitrusClassVars;
end;
TOrangeVMT = record
ClassVarTable := @OrangeClassVars;
end;
, . :
:
. , , , , ( ).
-- V:
ClassInstanceSize: Integer;
ClassInstanceData: Pointer;
ClassInstanceSize , . ClassInstanceData , . .
VMT. , ClassInstanceSize = Parent.ClassInstanceSize + SizeOf ( ).
, ClassInstanzeSize ( ClassVarTableSize) . , . , . ( , .dcu), , , , VirtualMethodCount V. ClassVarTable-.
...
, , . , , .
HALLVARD VASSBOTN , 04 2007
# 17. . II
I , , (Delphi 2007 ) Object Pascal ( ). . , , Delphi, . Logchem [4].
, CodeGear (Embarcadero) Delphi ?
(Logchem) everyangle.com. :
[...] , Delphi 2005, - : . , — :
TClass1 = class(TObject)
public
class property Variable: Type;
end;
TClass2 = class(TClass1);
TClass1.Variable <> TClass2.Variable. : , .
, I. Delphi, , — . :
, , . , VMT ! :
type
PClass = ^TClass;
TClassInfo = class(TObject);
TBasicObject = class(TObject)
strict private
procedure VMT_Placeholder1; virtual;
protected
class procedure SetClassInfo(const aClassInfo: TClassInfo);
public
class procedure InitVMTPlaceholders; virtual;
function GetClassInfo: TClassInfo; inline;
class function ClassGetClassInfo: TClassInfo; inline;
end;
PBasicObjectOverlay = ^RBasicObjectOverlay;
RBasicObjectOverlay = packed record
OurClassInfo: TClassInfo;
end;
procedure PatchCodeDWORD(Code: PDWORD; Value: DWORD);
var
RestoreProtection, Ignore: DWORD;
begin
if VirtualProtect(Code, SizeOf(Code^), PAGE_EXECUTE_READWRITE,
RestoreProtection) then
begin
Code^ := Value;
VirtualProtect(Code, SizeOf(Code^), RestoreProtection, Ignore);
FlushInstructionCache(GetCurrentProcess, Code, SizeOf(Code^));
end;
end;
class procedure TBasicObject.InitVMTPlaceholders;
begin
if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
begin
PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(nil));
Assert(ClassGetClassInfo = nil, 'Failed cleaning VMT of ' + ClassName);
end
else
Assert(ClassGetClassInfo = nil,
'Illegal value when checking initialized VMT of ' + ClassName);
end;
function TBasicObject.GetClassInfo: TClassInfo;
begin
Result := PBasicObjectOverlay(PClass(Self)^).OurClassInfo;
end;
class function TBasicObject.ClassGetClassInfo: TClassInfo;
begin
Result := PBasicObjectOverlay(Self).OurClassInfo;
end;
class procedure TBasicObject.SetClassInfo(const aClassInfo: TClassInfo);
begin
PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(aClassInfo));
end;
procedure TBasicObject.VMT_Placeholder1;
begin
Assert(False);
VMT_Placeholder1;
end;
initialization
TBasicObject.InitVMTPlaceholders;
end.
, GetClassInfo :
MOV EAX, [EAX] // Go from instance to VMT
MOV EAX, [EAX+12] // read from the VMT at some offset (!)
, !
, , !
, . , , , TBasicObject. , , . – (strict private) ( VMT_Placeholder1), . (override) – , VMT – ( ).
V
V? , , , ! GetClassInfo ( ClassGetClassInfo) TClassInfo, ( , .NET). :
function TBasicObject.GetClassInfo: TClassInfo;
begin
Result := PBasicObjectOverlay(PClass(Self)^).OurClassInfo;
end;
. , GetClassInfo ( , TBasicObject) TObject, . , 4 TClass, VMT . PClass(Self)^ V. VMT . TObject «» VMT ( VMT [5]).
TClass , , , , , , , ClassName. , , TClass RBasicObjectOverlay . , 4- OurClassInfo, , , , TClassInfo. VMT_Placeholder1 TBasicObject, TBasicObject TObject ( , .. VMT- ), OurClassInfo VMT-, VMT_Placeholder1. ?
, , , VMT- VMT_Placeholder1 TClassInfo. , ( @TBasicObject VMT_Placeholder1 – , strict private, ). , «» VMT [6]( , ?). — TBasicObject V-, :
class procedure TBasicObject.InitVMTPlaceholders;
begin
if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
begin
PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(nil));
Assert(ClassGetClassInfo = nil, 'Failed cleaning VMT of ' + ClassName);
end
else
Assert(ClassGetClassInfo = nil,
'Illegal value when checking initialized VMT of ' + ClassName);
end;
initialization
TBasicObject.InitVMTPlaceholders;
end.
-, , , VMT-, , . TBasicObject.VMT_Placeholder1, , , , . .
PatchCodeDWORD nil VMT- ( - ). , , , Assert, - .
, . nil- TClassInfo, .
TClassInfo , VMT-. : , , , - . SetClassInfo. , TClassInfo :
type
TClassInfo = class(TObject)
public
A: integer;
constructor Create(Value: integer);
end;
constructor TClassInfo.Create(Value: integer);
begin
inherited Create;
A := Value;
end;
initialization
TBasicObject.InitVMTPlaceholders;
TBasicObject.SetClassInfo(TClassInfo.Create(42));
GetClassInfo InitVMTPlaceholders, , SetClassInfo :
class procedure TBasicObject.SetClassInfo(const aClassInfo: TClassInfo);
begin
PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(aClassInfo));
end;
VMT- , TClassInfo. . , TClassInfo GetClassInfo, , , TClassInfo - . TClassInfo , , .
, TClassInfo- , . TBasicObject, InitVMTPlaceholders TClassInfo SetClassInfo. «» I, :
type
TFruitClassInfo = class(TClassInfo)
private
var FInstanceCount: integer;
end;
TFruit = class(TBasicObject)
protected
class function FruitClassInfo: TFruitClassInfo; inline;
public
constructor Create;
class function InstanceCount: integer;
end;
TApple = class(TFruit)
end;
TOrange = class(TFruit)
end;
constructor TFruit.Create;
begin
inherited Create;
Inc(FruitClassInfo.FInstanceCount);
end;
class function TFruit.FruitClassInfo: TFruitClassInfo;
begin
Result := ClassGetClassInfo as TFruitClassInfo;
end;
class function TFruit.InstanceCount: integer;
begin
Result := FruitClassInfo.FInstanceCount;
end;
initialization
TFruit.SetClassInfo(TFruitClassInfo.Create);
TApple.SetClassInfo(TFruitClassInfo.Create);
TOrange.SetClassInfo(TFruitClassInfo.Create);
end.
, . InstanceCount TFruit – TApple TOrange . , .
, VMT- nil ( InitVMTPlaceholders ). .
, TClassInfo . , TFruitClassInfo, - (FruitClassInfo), .
ClassInfo
, TClassInfo, , , TClassInfo. , ( «», , as-).
(inlining)
GetClassInfo , , «» ( ) . , . , – . TBasicObject.InitVMTPlaceholders ClassGetClassInfo, - , , . – . «» — . Delphi - , . , . , , (). InitVMTPlaceholders ClassGetClassInfo, . , .
, GetClassInfo TClassInfo :
ClassInfo := Apple.GetClassInfo;
// With inlinging and optimization enabled
// this compiles into
asm
MOV EAX,[EAX]
MOV EAX,[EAX]
end;
, TClassInfo . TObject TClass, V- (.. 0). , — !
?
, , - - . -, ?
, , .
:
— , , ?
, , , . - TClass: TClassInfo .
, , VMT- , VMT-, AutoTable — Delphi 2, , . VMT ( ):
type
PVmt = ^TVmt;
TVmt = packed record
SelfPtr : TClass;
IntfTable : Pointer;
AutoTable : Pointer;
InitTable : Pointer;
TypeInfo : Pointer;
FieldTable : Pointer;
MethodTable : Pointer;
DynamicTable : Pointer;
ClassName : PShortString;
InstanceSize : PLongint;
Parent : PClass;
SafeCallException : PSafeCallException;
AfterConstruction : PAfterConstruction;
BeforeDestruction : PBeforeDestruction;
Dispatch : PDispatch;
DefaultHandler : PDefaultHandler;
NewInstance : PNewInstance;
FreeInstance : PFreeInstance;
Destroy : PDestroy;
end;
AutoTable:
- nil ( Delphi 2-)
- , , TBasicObject.
, VMT-, , , , Delphi 3.
, Delphi 2-, . , Delphi COM- , COM- COM. Delphi , «» . COM, Delphi, QueryInterface, «» ( ).
, . RTTI , COM Delphi 2- . Delphi 3 (). , () . RTTI (, ).
RTTI , $METHODINFO ON . [7, 8, 9 10].
«» — AutoTable
VMT- AutoTable, VMT- , :
type
PClassVars = ^TClassVars;
TClassVars = class(TObject)
public
InstanceCount: integer;
end;
TBasicObject = class(TObject)
protected
class procedure SetClassVars(aClassVars: TClassVars);
public
class function GetClassVars: TClassVars; inline;
function ClassVars: TClassVars; inline;
end;
const
vmtClassVars = System.vmtAutoTable;
function TBasicObject.ClassVars: TClassVars;
begin
Result := PClassVars(PInteger(Self)^ + vmtClassVars)^;
end;
class function TBasicObject.GetClassVars: TClassVars;
begin
Result := PClassVars(Integer(Self) + vmtClassVars)^;
end;
class procedure TBasicObject.SetClassVars(aClassVars: TClassVars);
begin
PatchCodeDWORD(PDWORD(Integer(Self) + vmtClassVars), DWORD(aClassVars));
end;
strict private , , VMT- ( , AutoTable ). , System, vmtAutoTable, . System:
const
...
vmtSelfPtr = -76;
vmtIntfTable = -72;
vmtAutoTable = -68;
vmtInitTable = -64;
, AutoTable -68 ( -$44 ) TClass. ClassInfo ClassVars, TObject.ClassInfo, RTTI ( TypInfo). SetClassInfo ClassInfo — (, Self — TClass, ). ClassVar TClassVars, , .
, InstanceCount TClassVars ( -). , ClassVars, :
procedure RegisterClassVarsSupport(const Classes: array of TBasicObjectClass);
var
LClass: TBasicObjectClass;
begin
for LClass in Classes do
if LClass.GetClassVars = nil then
LClass.SetClassVars(TClassVars.Create)
else
raise Exception.CreateFmt(
'Class %s has automated section or duplicated registration', [LClass.ClassName]);
end;
«» :
type
TFruit = class(TBasicObject)
public
constructor Create;
function InstanceCount: integer; inline;
class function ClassInstanceCount: integer; inline;
end;
TApple = class(TFruit)
end;
TOrange = class(TFruit)
end;
………………………
………………………
………………………
………………………
constructor TFruit.Create;
begin
inherited Create;
Inc(ClassVars.InstanceCount);
end;
function TFruit.InstanceCount: integer;
begin
Result := ClassVars.InstanceCount;
end;
class function TFruit.ClassInstanceCount: integer;
begin
Result := GetClassVars.InstanceCount;
end;
initialization
RegisterClassVarsSupport([TFruit, TApple, TOrange]);
end.
, . , TClass TClassVar VMT, , (InstanceCount) :
Count := Apple.ClassInstanceCount;
asm
MOV EAX,[ESI]
ADD EAX,-$44
MOV EAX,[EAX]
MOV EBX,[EAX+$04]
end;
. , , , . , vmtAutoTable VMT, c .
MOV reg . :
Count := Apple.ClassInstanceCount;
asm
MOV EAX,[ESI]
MOV EAX,[EAX-$44]
MOV EBX,[EAX+$04]
end;
$44 , , . , .
, VMT AutoTable, TBasicObject, TFruit. .
— — , Windows Live Writer HTML HTML, Delphi2HTML . , 32 HTML ( 1982 ??!). (, ).
:
vmtAutoTable, . , , -, !
!
, .
[ , ].
HALLVARD VASSBOTN, , 16 2007
Shemitz J. .NET 2.0 for Delphi Programmers, 2006, 10 ( H. Vassbotn)
DN4DP#1: Getting classy, http://hallvards.blogspot.com/2006/08/dn4dp1-getting-classy_31.html
Vassbotn H. Hack#15: Overriding message and dynamic methods at run-time, http://hallvards.blogspot.com/2007/03/hack15-overriding-message-and-dynamic.html
http://www.vanlogchem.nl/archive_patrick.php
Vassbotn H. Hack #8: Explicit VMT calls, http://hallvards.blogspot.com/2006/03/hack-8-explicit-vmt-calls.html
Vassbotn H. Hack#15: Overriding message and dynamic methods at run-time, http://hallvards.blogspot.com/2007/03/hack15-overriding-message-and-dynamic.html
Vassbotn H. David Glassborow on extended RTTI, http://hallvards.blogspot.com/2006/05/david-glassborow-on-extended-rtti.html
Vassbotn H. Digging into SOAP and WebSnap, http://hallvards.blogspot.com/2006/06/digging-into-soap-and-websnap.html
Vassbotn H. Simple Interface RTTI, http://hallvards.blogspot.com/2006/06/simple-interface-rtti.html
Vassbotn H. Extended Class RTTI, http://hallvards.blogspot.com/2006/09/extended-class-rtti.html
( ), :
A. Borland/CodeGear/Embarcadero, Object Pascal virtual class var («…that has been Closed with As Designed ages ago»). , , Delphi. , Delphi Borland, , - ( , , ++, Java, JavaScript ..) ( helpr-). , : , ( – ), . , .
B. , ? – , 2007 ? , « » Embarcadero « »? , , , (pattern) «». ? – (: 2 4 , !).
C. ( )? – . ? . , virtual class var? — .
D. , « » – . «», – , , . , , , . , ( , «», , – - runtime, ?) , , , ? : Embarcadero ( Embarcadero) class ((static | <empty>) | virtual) var (, Free Pascal?). , class virtual var.
.
E. . ( ) . , (. ):
………………………………………
if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
………………………………………
………………………………………
( ) :
E.1. Addr(TBasicObject.VMT_Placeholder1) VMT-, VMT_Placeholder1() TBasicObject.
Pointer(ClassGetClassInfo) VMT-, VMT_Placeholder1() , TBasicObject. :
E.2. ClassGetClassInfo() – , VMT -, . , VMT -.
E.3. , (override), VMT- , VMT- ( « » ).
, VMT- VMT_Placeholder1 -.
, :
initialization
TBasicObject.InitVMTPlaceholders();
end.
, , :
initialization
TFruit.InitVMTPlaceholders();
TApple.InitVMTPlaceholders();
TOrange.InitVMTPlaceholders();
end.
, TBasicObject.InitVMTPlaceholders() .
E.4. VMT-, , , () , .
, ( ), — «» . , SetClassInfo:
class procedure TBasicObject.SetClassInfo(const AClassInfo: TClassInfo);
var
AVirtualClassInfo: TObject;
begin
if (Pointer(ClassGetClassInfo) <> Addr(TBasicObject.VMT_Placeholder)) then
begin
AVirtualClassInfo := ClassGetClassInfo();
PatchCodeDWORD(@PBasicObjectOverlay (Self).VarClassInfo, DWORD(nil));
System.SysUtils.FreeAndNil(AVirtualClassInfo);
end;
PatchCodeDWORD(@PBasicObjectOverlay(Self).VarClassInfo, DWORD(AClassInfo));
end;
F. , TBasicObject TObject TInterfacedObject, - , ? . , , , VMT- ( , , 4.2 4.3, ). , , «». .
? , ! ( — TVirtualClassVar). «» .
:
type
TVirtualClassVar = class
end;
TVirtualClassVarClass = class of TVirtualClassVar;
PVirtualClassVar = ^TVirtualClassVar;
TVirtualClassVarObject = class
protected
class procedure PatchCodeDWORD(ACode: PDWORD; AValue: DWORD); static;
class function GetAddress(): PDWORD; inline;
protected
class function ClassGetClassInfo(): TVirtualClassVar; inline;
public
constructor Create(); overload; virtual;
destructor Destroy(); override;
public
class function GetClassInfo<T: TVirtualClassVar>(): T; overload;
class function GetClassInfo(): TVirtualClassVar; overload; inline;
class procedure SetClassInfo(const AClassInfo: TVirtualClassVar); inline;
end;
TVirtualClassVarObjectClass = class of TVirtualClassVarObject;
:
constructor TVirtualClassVarObject.Create();
begin
inherited Create();
end;
destructor TVirtualClassVarObject.Destroy();
begin
inherited Destroy();
end;
class procedure TVirtualClassVarObject.PatchCodeDWORD(ACode: PDWORD; AValue: DWORD);
var
ARestoreProtection: DWORD;
AIgnore: DWORD;
begin
if (VirtualProtect(ACode, System.SizeOf(ACode^), PAGE_EXECUTE_READWRITE, ARestoreProtection)) then
begin
ACode^ := AValue;
VirtualProtect(ACode, System.SizeOf(ACode^), ARestoreProtection, AIgnore);
FlushInstructionCache(GetCurrentProcess, ACode, System.SizeOf(ACode^));
end;
end;
class function TVirtualClassVarObject.GetAddress(): PDWORD;
begin
Result := PDWORD(Integer(Self) + System.vmtAutoTable);
end;
class function TVirtualClassVarObject.ClassGetClassInfo(): TVirtualClassVar;
begin
Result := PVirtualClassVar(PInteger(Self)^ + System.vmtAutoTable)^;
end;
class function TVirtualClassVarObject.GetClassInfo<T>(): T;
begin
Result := (GetClassInfo() as T);
end;
class function TVirtualClassVarObject.GetClassInfo(): TVirtualClassVar;
begin
Result := PVirtualClassVar(Integer(Self) + System.vmtAutoTable)^;
end;
class procedure TVirtualClassVarObject.SetClassInfo(const AClassInfo: TVirtualClassVar);
var
AVirtualClassVar: TVirtualClassVar;
begin
AVirtualClassVar := GetClassInfo();
if (AVirtualClassVar <> nil) then
begin
if (AVirtualClassVar.Equals(AClassInfo)) then exit;
PatchCodeDWORD(GetAddress(), DWORD(nil));
System.SysUtils.FreeAndNil(AVirtualClassVar);
end;
PatchCodeDWORD(GetAddress(), DWORD(AClassInfo))
end;
TVirtualClassVarObject.SetClassInfo(…): .
, « ».
( , FInstanceName):
{$REGION 'TVirtualClassVarFruit'}
TVirtualClassVarFruit = class(TVirtualClassVar)
private
FInstanceName: string;
protected
function GetName(): string; overload; virtual;
procedure SetName(const AValue: string); overload; virtual;
public
constructor Create(const AName: string); overload; virtual;
destructor Destroy(); override;
published
property InstanceName: string read GetName write SetName;
end;
TVirtualClassVarFruitClass = class of TVirtualClassVarFruit;
{$ENDREGION 'TVirtualClassVarFruit'}
:
{$REGION 'TFruit'}
TFruit = class(TClassVarObject)
protected
class function FruitClassInfo(): TVirtualClassVarFruit; inline;
class procedure RegisterClassInfo(); static;
protected
class constructor Create();
public
constructor Create(); overload; virtual;
class function Name(): string;
end;
TFruitClass = class of TFruit;
{$ENDREGION 'TFruit'}
{$REGION 'TApple'}
TApple = class(TFruit)
public
constructor Create(); overload; override;
destructor Destroy(); override;
end;
TAppleClass = class of TApple;
{$ENDREGION 'TApple'}
{$REGION 'TOrange'}
TOrange = class(TFruit)
end;
TOrangeClass = class of TOrange;
{$ENDREGION 'TOrange'}
( !):
{$REGION 'TVirtualClassVarFruit'}
constructor TVirtualClassVarFruit.Create(const AName: string);
begin
inherited Create();
FInstanceName := AName;
end;
destructor TVirtualClassVarFruit.Destroy();
begin
inherited Destroy();
end;
function TVirtualClassVarFruit.GetName(): string;
begin
Result := FInstanceName;
end;
procedure TVirtualClassVarFruit.SetName(const AValue: string);
begin
FInstanceName := AValue;
end;
{$ENDREGION 'TVirtualClassVarFruit'}
:
{$REGION 'TFruit'}
class constructor TFruit.Create();
begin
TFruit.RegisterClassInfo();
end;
constructor TFruit.Create();
begin
inherited Create();
end;
class procedure TFruit.RegisterClassInfo();
begin
TFruit.SetClassInfo(TVirtualClassVarFruit.Create(''));
TApple.SetClassInfo(TVirtualClassVarFruit.Create(''));
TOrange.SetClassInfo(TVirtualClassVarFruit.Create(''));
TApple.SetClassInfo(TVirtualClassVarFruit.Create(' 2'));
end;
class function TFruit.FruitClassInfo(): TVirtualClassVarFruit;
begin
Result := (ClassGetClassInfo() as TVirtualClassVarFruit);
end;
class function TFruit.Name(): string;
begin
Result := System.SysUtils.format('%s: %s', [ClassName, FruitClassInfo().InstanceName]);
end;
{$ENDREGION 'TFruit'}
{$REGION 'TApple'}
constructor TApple.Create();
begin
inherited Create();
end;
destructor TApple.Destroy();
begin
inherited Destroy();
end;
{$ENDREGION 'TApple'}
, :
class constructor TFruit.Create();
begin
TFruit.RegisterClassInfo();
end;
…………………………………
…………………………………
…………………………………
class procedure TFruit.RegisterClassInfo();
begin
TFruit.SetClassInfo(TVirtualClassVarFruit.Create(''));
TApple.SetClassInfo(TVirtualClassVarFruit.Create(''));
TOrange.SetClassInfo(TVirtualClassVarFruit.Create(''));
TApple.SetClassInfo(TVirtualClassVarFruit.Create(' 2'));
end;
– . , , , , . ( «» , , : . TFruit.RegisterClassInfo).
G. (class property) ?
. , Object Pascal . , !
H. , – - «» ? , : 4 32- 8 64-. : « »!
I. «» TBasicObject TClassInfo? ? , :
TVirtualClassVarObject<TParentClass: lass, constructor> = class(TParentClass)
.........
protected
class procedure PatchCodeDWORD(ACode: PDWORD; AValue: DWORD); static;
class function GetAddress(): PDWORD; inline;
protected
class function ClassGetClassInfo(): TVirtualClassVar; inline;
public
constructor Create(); overload; virtual;
destructor Destroy(); override;
public
class function GetClassInfo<T: TVirtualClassVar>(): T; overload;
class function GetClassInfo(): TVirtualClassVar; overload; inline;
class procedure SetClassInfo(const AClassInfo: TVirtualClassVar); inline;
end;
TVirtualClassVarObject<TParentClass: TClass, constructor> = class(TParentClass)
.........
protected
class procedure PatchCodeDWORD(ACode: PDWORD; AValue: DWORD); static;
class function GetAddress(): PDWORD; inline;
protected
class function ClassGetClassInfo(): TVirtualClassVar; inline;
public
constructor Create(); overload; virtual;
destructor Destroy(); override;
public
class function GetClassInfo<T: TVirtualClassVar>(): T; overload;
class function GetClassInfo(): TVirtualClassVar; overload; inline;
class procedure SetClassInfo(const AClassInfo: TVirtualClassVar); inline;
end;
- ( TDesignate – ):
TMyAppClass = class(TVirtualClassVarObject<TDesignate>)
.......
.......
.......
end;
, , TMyAppClass .
, . () Object Pascal :
TMyGenericClass<T: lass, constructor> = class(T)
.........
end;
, ? ?
!
J. ?
.
:
THelperVirtualClassVarObject = class helper for TObject
protected
class procedure PatchCodeDWORD(ACode: PDWORD; AValue: DWORD); static;
class function GetAddress(): PDWORD; inline;
protected
class function ClassGetClassInfo(): TVirtualClassVar; inline;
public
class function GetClassVar<T: TVirtualClassVar>(): T; overload;
class function GetClassVar<T: class, constructor;V: TVirtualClassVar>(): V; overload;
class function GetClassVar(): TVirtualClassVar; overload; inline;
class procedure SetClassVar(const AClassInfo: TVirtualClassVar); inline;
end;
:
{$REGION 'THelperVirtualClassVarObject'}
class procedure THelperVirtualClassVarObject.PatchCodeDWORD(ACode: PDWORD;
AValue: DWORD);
var
ARestoreProtection: DWORD;
AIgnore: DWORD;
begin
if (VirtualProtect(ACode, System.SizeOf(ACode^), PAGE_EXECUTE_READWRITE, ARestoreProtection)) then
begin
ACode^ := AValue;
VirtualProtect(ACode, System.SizeOf(ACode^), ARestoreProtection, AIgnore);
FlushInstructionCache(GetCurrentProcess, ACode, System.SizeOf(ACode^));
end;
end;
class function THelperVirtualClassVarObject.GetAddress(): PDWORD;
begin
Result := PDWORD(Integer(Self) + System.vmtAutoTable);
end;
class function THelperVirtualClassVarObject.ClassGetClassInfo(): TVirtualClassVar;
begin
Result := PVirtualClassVar(PInteger(Self)^ + System.vmtAutoTable)^;
end;
class function THelperVirtualClassVarObject.GetClassVar<T>(): T;
begin
Result := (GetClassVar() as T);
end;
class function THelperVirtualClassVarObject.GetClassVar<T, V>(): V;
begin
Result := (T.GetClassVar() as V);
end;
class function THelperVirtualClassVarObject.GetClassVar(): TVirtualClassVar;
begin
Result := PVirtualClassVar(Integer(Self) + System.vmtAutoTable)^;
end;
class procedure THelperVirtualClassVarObject.SetClassVar(const AClassInfo: TVirtualClassVar);
var
AVirtualClassVar: TVirtualClassVar;
begin
AVirtualClassVar := GetClassVar();
if (AVirtualClassVar <> nil) then
begin
if (AVirtualClassVar.Equals(AClassInfo)) then exit;
PatchCodeDWORD(GetAddress(), DWORD(nil));
System.SysUtils.FreeAndNil(AVirtualClassVar);
end;
PatchCodeDWORD(GetAddress(), DWORD(AClassInfo))
end;
{$ENDREGION 'THelperVirtualClassVarObject'}
! , , !
K. Tout cela fonctionne dans les projets VCL (Win32). Est-ce que tout cela fonctionnera sur d'autres plateformes?
Je ne sais pas. N'a pas vérifié. Ce serait bien si quelqu'un vérifiait cela ...
Tout comme Paris vaut la messe, la technologie inventée par Hallward Wassbot mérite d'être utilisée dans vos projets Delphic.