Get best of the week

Vassbotn H. Kelas Variabel Virtual

Salam kepada semua yang mulai membaca artikel ini! Saya ingin mengundang Anda (dan sebagian besar untuk penggemar Object Pascal, pecinta trik pemrograman, teknik, dan penyempurnaan sintaksis) untuk membiasakan diri dengan terjemahan posting ( Hack # 17 yang agak lama): Hack # 17: variabel kelas virtual, Bagian I " dan " Hack # 17: Variabel kelas virtual, Bagian II , oleh Hallvard Vassbotn, pengembang terkenal dan penulis berbagai teknik berorientasi Delphi.


Pesan Hallward dikhususkan untuk salah satu topik paling menarik - kemungkinan menempatkan dan menggunakan data yang terkait dengan kelas objek aplikasi tertentu. Jika Anda memikirkan konstanta atau variabel kelas, maka Anda akan benar, tetapi hanya sebagian.
Artikel ini adalah tentang kelas virtual var., dalam bahasa Rusia, frasa ini terdengar seperti variabel virtual kelas (frasa inilah yang ditempatkan atas nama terjemahan ini). Anda akan mengatakan bahwa tidak ada konstruksi sintaksis di Object Pascal, dan Anda akan benar. Selain itu, saya yakin bahwa para ahli dan pengembang dalam bahasa pemrograman OO lainnya akan menyatakan: dalam praktik saya, saya belum pernah mendengar, menemukan, atau menggunakan hal seperti ini. Seperti semua yang saya "tidak melihat gopher ...", tetapi saya berpendapat bahwa itu bisa ada. Dan ini akan dibahas dalam teks terjemahan yang diusulkan.


Kata pengantar dari penerjemah


Selama bertahun-tahun yang telah berlalu sejak saya pertama kali membaca posting Hallward, saya tidak bisa memutuskan untuk menggunakan idenya yang luar biasa dalam proyek-proyek saya. Tetapi kecantikannya dan solusi yang ditawarkan Hallward tidak meninggalkan saya dan tetap tidak meninggalkan saya sendirian.


Sudah waktunya untuk mengumpulkan batu: Saya punya tugas yang solusi terbaik untuk implementasinya akan hanya "hack" (dan saya masih akan memanggil metode teknologi hacks seperti itu) dari Hallward. Setelah Anda dapat menggunakannya, Anda harus siap menghadapi hal-hal yang tidak terduga - sekali lagi mempelajari materi, membaca kembali piagam, instruksi ...


Saya ingin memperjelas motif saya untuk bekerja menerjemahkan pesan-pesan 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. Semua ini berfungsi di proyek VCL (Win32). Apakah semua ini akan berfungsi pada platform lain?


Saya tidak tahu. Tidak memeriksa. Akan lebih baik jika seseorang memeriksa ini ...


Sama seperti Paris yang sepadan dengan Misa, teknologi yang ditemukan oleh Hallward Wassbot layak digunakan dalam proyek Delphic Anda.

More articles:


All Articles