Get best of the week

Vassbotn H. Variáveis ​​virtuais de classe

Saudações a todos que começaram a ler este artigo! Quero convidar você (e em grande parte para os fãs de Object Pascal, amantes de truques de programação, técnicas e refinamentos sintáticos) a se familiarizarem com a tradução da publicação bastante antiga (2007) "Hack # 17: Variáveis ​​de classe virtual, parte I" e "Hack # 17: Variáveis ​​de classe virtual, Parte II , de Hallvard Vassbotn, um renomado desenvolvedor e autor de inúmeras técnicas orientadas a Delphi.


A mensagem de Hallward é dedicada a um dos tópicos mais interessantes - a possibilidade de colocar e usar dados associados a uma classe específica de objetos de aplicativo. Se você pensou em constantes ou variáveis ​​de classe, estará certo, mas apenas parcialmente.
Este artigo é sobre a classe virtual var., em russo, esta frase soa como uma variável virtual de uma classe (é precisamente essa frase que é colocada no nome desta tradução). Você dirá que não existe essa construção sintática no Object Pascal e estará absolutamente certo. Além disso, tenho certeza de que especialistas e desenvolvedores de outras linguagens de programação OO declararão: na minha prática, não ouvi, encontrei ou usei algo assim. Como tudo o que "não vejo um esquilo ...", mas vou argumentar que ele pode existir. E isso será discutido no texto da tradução proposta.


Prefácio do tradutor


Ao longo dos muitos anos que se passaram desde a primeira vez que li o post de Hallward, não pude decidir usar sua maravilhosa idéia em meus projetos. Mas sua beleza e a solução alternativa oferecida por Hallward não me deixaram e ainda não me deixam em paz.


Estava na hora de coletar pedras: eu tinha uma tarefa para a qual a melhor solução para sua implementação seria apenas um “hack” (e eu ainda chamaria esses métodos tecnológicos de hacks) da Hallward. Depois de poder usá-lo, você precisa estar preparado para o inesperado - mais uma vez estude o material, releia o regulamento, instruções ...


Gostaria de esclarecer meus motivos para trabalhar na tradução de mensagens de 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);
// Self-modifying code - change one DWORD in the code segment
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;
// Compiler generated types and variables
var
  // Global variables used for per-class virtual class fields 
  FruitClassVars = record
    FInstanceCount: integer;
  end;
  CitrusClassVars = record // inherits field 
    FInstanceCount: integer;
  end;
  OrangeClassVars = record // inherits field, introduces new field 
    FInstanceCount: integer;
    ClassDescription: string;
  end;
  // New VMT slot initialization, generated by compiler:
  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
   // written once, read _very_ frequently 
   class property Variable: Type;
 end;

 TClass2 = class(TClass1);

TClass1.Variable <> TClass2.Variable. : , .


, I. Delphi, , — . :


, , . , VMT ! :


type
  PClass = ^TClass;
  // this class contains important meta-data, 
  // accessed _very_ frequently
  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;
    // Strange: Inlining of class methods doesn't work (yet)!
    class function ClassGetClassInfo: TClassInfo; inline; 
  end;

  PBasicObjectOverlay = ^RBasicObjectOverlay;
  RBasicObjectOverlay = packed record
    OurClassInfo: TClassInfo;
  end;

procedure PatchCodeDWORD(Code: PDWORD; Value: DWORD);
// Self-modifying code - change one DWORD in the code segment
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
  // First, check if the VMT-mapping came thru the compiler alright :
  if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
  begin
    // Now, empty the variable default, 
    // very important for later code !
    PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(nil));

    // Now check that we see a cleaned up variable :
    Assert(ClassGetClassInfo = nil, 'Failed cleaning VMT of ' + ClassName);
  end
  else
    // When there's no original content anymore, this initialization 
    // has already been done - there _has_ to be a nil here :
    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
  // This method may never be called! 
  // It only exists to occupy a space in the VMT!
  Assert(False); 
  // This line prevents warnings about unused symbols
  // (until the compiler detects endless recursive loops)...
  VMT_Placeholder1; 
end; 

initialization
  // call this for any derived class too
  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
  //First, check if the VMT-mapping came thru the compiler alright:
  if Pointer(ClassGetClassInfo) = Addr(TBasicObject.VMT_Placeholder1) then
  begin
    // Now, empty the variable default,
    // very important for later code !
    PatchCodeDWORD(@PBasicObjectOverlay(Self).OurClassInfo, DWORD(nil));

    // Now check that we see a cleaned up variable :
    Assert(ClassGetClassInfo = nil, 'Failed cleaning VMT of ' + ClassName);
  end
  else
    // When there's no original content anymore, this initialization
    // has already been done - there _has_ to be a nil here :
    Assert(ClassGetClassInfo = nil,
      'Illegal value when checking initialized VMT of ' + ClassName);
end;

initialization
  // call this for any derived class too
  TBasicObject.InitVMTPlaceholders;
end.

-, , , VMT-, , . TBasicObject.VMT_Placeholder1, , , , . .


PatchCodeDWORD nil VMT- ( - ). , , , Assert, - .


MetaInfo


, . 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)
  {unit} 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;
   {UserDefinedVirtuals: array[0..999] of procedure;}
  end;

AutoTable:


  • nil ( Delphi 2-)
  • , , TBasicObject.

, VMT-, , , , Delphi 3.


: Delphi 2, COM


, 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)^; // Original code
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
  ...
{ Virtual method table entries }

  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



  1. Shemitz J. .NET 2.0 for Delphi Programmers, 2006, 10 ( H. Vassbotn)


  2. DN4DP#1: Getting classy, http://hallvards.blogspot.com/2006/08/dn4dp1-getting-classy_31.html


  3. Vassbotn H. Hack#15: Overriding message and dynamic methods at run-time, http://hallvards.blogspot.com/2007/03/hack15-overriding-message-and-dynamic.html


  4. http://www.vanlogchem.nl/archive_patrick.php


  5. Vassbotn H. Hack #8: Explicit VMT calls, http://hallvards.blogspot.com/2006/03/hack-8-explicit-vmt-calls.html


  6. Vassbotn H. Hack#15: Overriding message and dynamic methods at run-time, http://hallvards.blogspot.com/2007/03/hack15-overriding-message-and-dynamic.html


  7. Vassbotn H. David Glassborow on extended RTTI, http://hallvards.blogspot.com/2006/05/david-glassborow-on-extended-rtti.html


  8. Vassbotn H. Digging into SOAP and WebSnap, http://hallvards.blogspot.com/2006/06/digging-into-soap-and-websnap.html


  9. Vassbotn H. Simple Interface RTTI, http://hallvards.blogspot.com/2006/06/simple-interface-rtti.html


  10. 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
// call this for any derived class too
//         .
  TBasicObject.InitVMTPlaceholders();
end.

, , :


initialization
// call this for any derived class too
//         .
  TFruit.InitVMTPlaceholders();
  TApple.InitVMTPlaceholders();
  TOrange.InitVMTPlaceholders();
end.

, TBasicObject.InitVMTPlaceholders() .


E.4. VMT-, , , () , .


, ( ), — «» . , SetClassInfo:


class procedure TBasicObject.SetClassInfo(const AClassInfo: TClassInfo);
var
  AVirtualClassInfo: TObject;
begin
//  Pointer(ClassGetClassInfo) <> Addr(TBasicObject.VMT_Placeholder) = true,
//         !
  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. Tudo isso funciona em projetos VCL (Win32). Tudo isso funcionará em outras plataformas?


Eu não sei. Não checou. Seria bom se alguém verificasse isso ...


Assim como Paris vale a massa, vale a pena usar a tecnologia inventada por Hallward Wassbot em seus projetos Delphic.

More articles:


All Articles