Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Enity-Component-System ComponentClassID per VMT patching
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.