Get best of the week

Vassbotn H. فئة المتغيرات الافتراضية

تحية لكل من بدأ في قراءة هذا المقال! أريد أن أدعوك (وإلى حد كبير لمحبي Object Pascal وعشاق حيل البرمجة والتقنيات والتحسينات النحوية) للتعرف على ترجمة المنشور القديم (2007) "Hack # 17: متغيرات الفئة الافتراضية ، الجزء الأول" و "Hack # 17: متغيرات الطبقة الافتراضية ، الجزء الثاني ، من قبل Hallvard Vassbotn ، مطور مشهور ومؤلف للعديد من التقنيات الموجهة نحو دلفي.


تم تخصيص رسالة Hallward لواحد من أكثر الموضوعات إثارة للاهتمام - إمكانية وضع واستخدام البيانات المرتبطة بفئة معينة من كائنات التطبيق. إذا فكرت في الثوابت أو متغيرات الفئة ، فستكون على حق ، ولكن جزئيًا فقط.
هذه المقالة هي عن فئة الظاهري var.، بالروسية ، تبدو هذه العبارة كمتغير افتراضي لفئة (هذه العبارة بالتحديد هي التي توضع باسم هذه الترجمة). ستقول أنه لا يوجد مثل هذا البناء النحوي في Object Pascal ، وستكون على حق تمامًا. علاوة على ذلك ، أنا متأكد من أن الخبراء والمطورين بلغات برمجة OO الأخرى سيعلنون: في ممارستي ، لم أسمع أو واجهت أو استخدمت أي شيء من هذا القبيل. مثل كل شيء "لا أرى غوفر ..." ، لكنني سأجادل أنه يمكن أن يوجد. وسيتم مناقشة ذلك في نص الترجمة المقترحة.


مقدمة من المترجم


على مدى السنوات العديدة التي مرت منذ أن قرأت لأول مرة وظيفة Hallward ، لم أستطع أن أقرر استخدام فكرته الرائعة في مشاريعي. لكن جمالها والحل الذي قدمه Hallward لم يتركوني ولا يزالون لا يتركوني وحدي.


لقد حان الوقت لجمع الأحجار: كان لدي مهمة يكون الحل الأفضل لتنفيذها هو مجرد "اختراق" (وما زلت أسمي مثل هذه الأساليب التكنولوجية للاختراق) من Hallward. بمجرد أن يمكنك استخدامه ، تحتاج إلى الاستعداد لما هو غير متوقع - مرة أخرى دراسة المواد ، وإعادة قراءة الميثاق ، والتعليمات ...


أود أن أوضح دوافعي للعمل على ترجمة رسائل Hallward.


بالانتقال إلى المصدر ( الجزء 1 ، الجزء 2 ) وإعادة قراءته ، التعليقات المصاحبة ، قررت أن ألقي نظرة على موارد اللغة الروسية المخصصة لهذا الموضوع ، ولدهشتي ، لم أجد ملاحظات Hallward حول موضوع متغيرات الفئة الافتراضية باللغة الروسية (عدد كبير من الملاحظات تمت ترجمة Hallvard ونشره ألكسندر أليكسيف المعروف باسم 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. كل هذا يعمل في مشاريع VCL (Win32). هل يعمل كل هذا على منصات أخرى؟


لا اعرف. لم تحقق. سيكون من اللطيف إذا فحص شخص ما هذا ...


تمامًا كما تستحق باريس القداس ، فإن التكنولوجيا التي ابتكرها Hallward Wassbot تستحق استخدامها في مشاريع Delphic الخاصة بك.

More articles:


All Articles