Enity-Component-System ComponentClassID per VMT patching

ClassIDTest1.pas

program ClassIDTest1;
{$mode delphi}
{$apptype console}
{$m+}

uses Windows,SysUtils,Classes;

type PSupraComponentClassNameID=^TSupraComponentClassNameID;
     TSupraComponentClassNameID=record
      Name:shortstring;
      ID:Int32;
     end;

     TSupraComponent=class
      public
       class function ClassID:longint;
       class procedure SetClassID(const pID:longint);
     end;

     TSupraComponent2=class(TSupraComponent)
      public
     end;

class function TSupraComponent.ClassID:longint;
begin
 result:=PSupraComponentClassNameID(PVMT(Self)^.vClassName)^.ID;
end;

class procedure TSupraComponent.SetClassID(const pID:longint);
var VMT:PVMT;
    NewClassName:PSupraComponentClassNameID;
{$ifdef windows}
    OldProtect:longword;
{$endif}
begin
 VMT:=PVMT(Self);
 GetMem(NewClassName,SizeOf(TSupraComponentClassNameID));
 NewClassName^.Name:=VMT^.vClassName^;
 NewClassName^.ID:=pID;
{$ifdef windows}
 OldProtect:=0;
 if VirtualProtect(pointer(@VMT^.vClassName),SizeOf(VMT^.vClassName),PAGE_EXECUTE_READWRITE,OldProtect) then begin
  VMT^.vClassName:=pointer(NewClassName);
  FlushInstructionCache(GetCurrentProcess,pointer(@VMT^.vClassName),SizeOf(VMT^.vClassName));
  VirtualProtect(pointer(@VMT^.vClassName),SizeOf(VMT^.vClassName),OldProtect,@OldProtect);
 end else begin
  FreeMem(NewClassName);
  Assert(false,'Ups!');
 end;
{$else}
{$ifdef unix}
 if fpmprotect(pointer(@VMT^.vClassName),SizeOf(VMT^.vClassName),PROT_READ or PROT_WRITE or PROT_EXEC)=0 then begin
  VMT^.vClassName:=pointer(NewClassName);
  fpmprotect(pointer(@VMT^.vClassName),SizeOf(VMT^.vClassName),PROT_READ or PROT_EXEC);
 end else begin
  FreeMem(NewClassName);
  Assert(false,'Ups!');
 end;
{$else}
 {$error Unsupported system}
{$endif}
{$endif}
end;

type TSupraComponentClass=class of TSupraComponent;

var SupraComponentClassIDCounter:Int32=-1;

procedure RegisterECSComponent(const ComponentClass:TSupraComponentClass);
begin
 ComponentClass.SetClassID(InterlockedIncrement(SupraComponentClassIDCounter));
end;

procedure RegisterECSComponents(const ComponentClasses:array of TSupraComponentClass);
var i:Int32;
begin
 for i:=0 to length(ComponentClasses)-1 do begin
  RegisterECSComponent(ComponentClasses[i]);
 end;
end;

var ComponentInstances:array[0..1] of TSupraComponent;
begin
 RegisterECSComponent(TSupraComponent);
 RegisterECSComponent(TSupraComponent2);
 writeln(TSupraComponent.ClassName,' has ID ',TSupraComponent.ClassID);
 writeln(TSupraComponent2.ClassName,' has ID ',TSupraComponent2.ClassID);
 ComponentInstances[0]:=TSupraComponent.Create;
 ComponentInstances[1]:=TSupraComponent2.Create;
 writeln('A instance of ',ComponentInstances[0].ClassName,' has still ID ',ComponentInstances[0].ClassID);
 writeln('A instance of ',ComponentInstances[1].ClassName,' has still ID ',ComponentInstances[1].ClassID);
 ComponentInstances[0].Free;
 ComponentInstances[1].Free;
 readln;
end.