[poyo]

En este otro hilo, Al González hizo algunos planteamientos que involucraban las famosas táblas de métodos virtuales (VMT's a partir de ahora).

No está muy claro este tema ya que no hay documentación oficial (al menos no la conozco). Lo poco que se conoce es por el Unit System.pas y por lo que algunos programadores han investigado haciendo un poco de ingeniería inversa.

Sé que no es bueno andar por lugares tan oscuros como la VMT ya que no sólo hay poco información sino que son muy suceptibles a los cambios sin aviso previo (ni posterior)...
De todos modos, muchas veces no hay otra opción. Cuando es así, no queda otra que manejarse con cautela y tener en cuenta las diferencias entre versiones.
De hecho, en la versión 2009 se han introducido modificaciones en la VMT...

A continuación pongo alguno links que tenía agendados y que estaban esperando a este momento.

http://hallvards.blogspot.com/2004/0...id-object.html
http://hallvards.blogspot.com/2006/0...structure.html
http://hallvards.blogspot.com/2006/0...vmt-calls.html
http://hallvards.blogspot.com/2007/0...s-part-ii.html

Ya bien empapados en el tema vamos a lo nuestro:

Miré código que tenía, algo de Hallvards, algo de GExperts y algo de JCL y terminé con lo siguiente:

Tenía un unit dedicado al RTTI así que ustedes pueden tener uno llamado RttiUtils.pas o como prefieran.
lo que nos compete va a continuación:

Código Delphi [-]
interface

uses ...Classes, typinfo....;

type
  TDMTIndex   = Smallint;
  PDmtIndices = ^TDmtIndices;
  TDmtIndices = array[0..High(Word)-1] of TDMTIndex;
  PDmtMethods = ^TDmtMethods;
  TDmtMethods = array[0..High(Word)-1] of Pointer;
  PDmt = ^TDmt;
  TDmt = packed record
    Count: word;
    Indicies: TDmtIndices; // really [0..Count-1]
    Methods : TDmtMethods; // really [0..Count-1]
  end;

  PClass = ^TClass;
  PSafeCallException = function  (Self: TObject; ExceptObject:
    TObject; ExceptAddr: Pointer): HResult;
  PAfterConstruction = procedure (Self: TObject);
  PBeforeDestruction = procedure (Self: TObject);
  PDispatch          = procedure (Self: TObject; var Message);
  PDefaultHandler    = procedure (Self: TObject; var Message);
  PNewInstance       = function  (Self: TClass) : TObject;
  PFreeInstance      = procedure (Self: TObject);
  PDestroy           = procedure (Self: TObject; OuterMost: ShortInt);
  PVmt = ^TVmt;

  TVmt = packed record
    SelfPtr           : TClass;
    IntfTable         : Pointer;
    AutoTable         : Pointer;
    InitTable         : Pointer;
    TypeInfo          : Pointer;
    FieldTable        : Pointer;
    MethodTable       : Pointer;
    DynamicTable      : PDmt;
    ClassName         : PShortString;
    InstanceSize      : PLongint;
    Parent            : PClass;
    equals            : pointer;
    GetHashCode       : pointer;
    ToString          : pointer;
    SafeCallException : PSafeCallException;
    AfterConstruction : PAfterConstruction;
    BeforeDestruction : PBeforeDestruction;
    Dispatch          : PDispatch;
    DefaultHandler    : PDefaultHandler;
    NewInstance       : PNewInstance;
    FreeInstance      : PFreeInstance;
    Destroy           : PDestroy;
    UserDefinedVirtuals: array[0..999] of procedure;
  end;

function GetVirtualMethodCount(AClass: TClass): Integer;
function GetVMT(AClass: TClass): PVMT; overload;
function GetVMT(AObject: TObject): PVMT; overload;

implementation

function GetVirtualMethodCount(AClass: TClass): Integer;
var
  BeginVMT: integer;
  EndVMT: integer;
  TablePointer: integer;
  I: Integer;
begin
  BeginVMT := integer(AClass);

  // Scan the offset entries in the class table for the various fields,
  // namely vmtIntfTable, vmtAutoTable, ..., vmtDynamicTable
  // The last entry is always the vmtClassName, so stop once we got there
  // After the last virtual method there is one of these entries.

  EndVMT := pinteger(integer(AClass) + vmtClassName)^;
  // Set iterator to first item behind VMT table pointer
  I := vmtSelfPtr + SizeOf(Pointer);
  repeat
    TablePointer := pinteger(integer(AClass) + I)^;
    if (TablePointer <> 0) and (TablePointer >= BeginVMT) and
       (TablePointer < EndVMT) then
      EndVMT := integer(TablePointer);
    Inc(I, SizeOf(Pointer));
  until I >= vmtClassName;

  Result := (EndVMT - BeginVMT) div SizeOf(Pointer);
end;


function GetVMT(AClass: TClass): PVMT; overload;
begin
  if assigned(AClass) then
  begin
    result := pvmt(integer(AClass) + vmtSelfPtr)
  end
  else
    Result := nil;
end;

function GetVMT(AObject: TObject): PVMT; overload;
begin
  if assigned(AObject) then
    result := pvmt(integer(AObject.ClassType) + vmtSelfPtr)
  else
    Result := nil;
end;

La respuesta la pregunta de Al se responde con la función GetVirtualMethodCount... aunque, como es de esperar, sólo devuelve los métodos declarados con la directiva "virtual", para los que estén declarados con "dinamic" ya es otro asunto.

A propósito, los métodos virtuales y abstractos (sin implementación por decirlo de algún modo), apuntan (tal como lo decía Al), a la función _AbstractError pero indirectamente... o sea que se puede hookear.
El puntero a interceptar está (como no podía ser de otra manera) en el System.pas:

AbstractErrorProc: procedure; { Abstract method error handler }

Allí, entonces, podremos colgar nuestra propia rutina para manejar el error, e inclusive llamar desde allí a la original.

sólo bastará declarar la función...

procedure CustomAbastractError;
begin
raise EAbstractError.Create('my custom abstract error');
end;

y asignarla:

AbstractErrorProc := CustomAbastractError;