unit ObjAutoMyy;

interface

uses System.Rtti, System.SysUtils, System.TypInfo, vcl.dialogs, Winapi.Windows,
  TEngineStruct;

const
  paEAX = Word(0);
  paEDX = Word(1);
  paECX = Word(2);
  paStack = Word(3);

type
  TEventBeforeNotify = reference to procedure(_Function: pzval;
    o: TRttiProperty; const Args: TArray<TValue>);

  PParameters = ^TParameters;

  TParameters = packed record
    Registers: array [paEDX .. paECX] of Cardinal;
    EAXRegister: Cardinal;
    ReturnAddress: Pointer;
    Stack: array [0 .. 1023] of Byte;
  end;

function CreateMethodPointer(__PropType: TRttiProperty; FuncPHP: pzval;
  OnBefore: TEventBeforeNotify): TMethod; overload;

procedure ReleaseMethodPointer(MethodPointer: TMethod);

implementation

uses
  System.Variants, System.VarUtils, System.RTLConsts;

function GetTypeSize(TypeInfo: PTypeInfo): Integer;
var
  TypeData: PTypeData;
begin
  case TypeInfo^.Kind of
    tkChar:
      Result := 1;
    tkWChar:
      Result := 2;
    tkInteger, tkEnumeration:
      begin
        TypeData := GetTypeData(TypeInfo);
        if TypeData^.MinValue >= 0 then
          if Cardinal(TypeData^.MaxValue) > $FFFF then
            Result := 4
          else if TypeData^.MaxValue > $FF then
            Result := 2
          else
            Result := 1
        else if (TypeData^.MaxValue > $7FFF) or (TypeData^.MinValue < -$7FFF - 1)
        then
          Result := 4
        else if (TypeData^.MaxValue > $7F) or (TypeData^.MinValue < -$7F - 1)
        then
          Result := 2
        else
          Result := 1;
      end;
    tkFloat:
      begin
        TypeData := GetTypeData(TypeInfo);
        case TypeData^.FloatType of
          ftSingle:
            Result := 4;
          ftComp, ftCurr, ftDouble:
            Result := 8;
        else
          Result := -1;
        end;
      end;
    tkString, tkLString, tkUString, tkWString, tkInterface, tkClass:
      Result := SizeOf(Pointer);
    tkMethod:
      Result := SizeOf(TMethod);
    tkInt64:
      Result := 8;
    tkVariant:
      Result := 16;
    tkSet:
      Result := 4;
  else
    Result := -1;
  end;
end;

type
  PParameterInfos = ^TParameterInfos;
  TParameterInfos = array [0 .. 255] of ^PTypeInfo;

  TBaseMethodHandlerInstance = class
  protected
    PHPFunc: pzval;
    TypeData: PTypeData;
    _PropertyType: TRttiProperty;
    ParamInfos: PParameterInfos;
    ParamOffsets: array of Word;
    StackSize: Integer;
    FOnBefore: TEventBeforeNotify;
    procedure Handler(Params: Pointer);
    procedure RegisterStub;
  public
    constructor Create(__PropType: TRttiProperty; FuncPHP: pzval;
      OnBefore: TEventBeforeNotify);
  end;

function AdditionalInfoOf(TypeData: PTypeData): Pointer;
var
  P: PByte;
  I: Integer;
begin
  P := @TypeData^.ParamList;
  for I := 1 to TypeData^.ParamCount do
  begin
    Inc(P, 1 + P[1] + 1);
    Inc(P, P[0] + 1);
  end;
  if TypeData^.MethodKind = mkFunction then
    Inc(P, P[0] + 1 + 4);
  Result := P;
end;

function CreateMethodPointer(__PropType: TRttiProperty; FuncPHP: pzval;
  OnBefore: TEventBeforeNotify): TMethod;
begin
  TObject(Result.Data) := TBaseMethodHandlerInstance.Create(__PropType, FuncPHP,
    OnBefore);
  Result.Code := @TBaseMethodHandlerInstance.RegisterStub;
end;

procedure ReleaseMethodPointer(MethodPointer: TMethod);
begin
  TObject(MethodPointer.Data).Free;
end;

{ TBaseMethodHandlerInstance }

constructor TBaseMethodHandlerInstance.Create(__PropType: TRttiProperty;
  FuncPHP: pzval; OnBefore: TEventBeforeNotify);
var
  P: PByte;
  Offset: Integer;
  CurReg: Integer;
  I: Integer;
  Size: Integer;
begin
  Self.PHPFunc := FuncPHP;
  Self._PropertyType := __PropType;
  Self.FOnBefore := OnBefore;

  Self.TypeData := __PropType.PropertyType.Handle.TypeData;

  P := AdditionalInfoOf(TypeData);
  ParamInfos := PParameterInfos(Cardinal(P) + 1);

  // Calculate stack size
  CurReg := paEDX;
  P := @TypeData^.ParamList;
  StackSize := 0;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    if System.TypInfo.TParamFlags(P[0]) * [pfVar, pfConst, pfAddress,
      pfReference, pfOut] <> [] then
      Size := 4
    else
      Size := GetTypeSize(ParamInfos^[I]^);
    if (Size <= 4) and (CurReg <= paECX) then
      Inc(CurReg)
    else
    begin
      if Size < 4 then
        Size := 4;
      Inc(StackSize, Size);
    end;
    Inc(P, 1 + P[1] + 1);
    Inc(P, P[0] + 1);
  end;

  // Calculate parameter offsets
  SetLength(ParamOffsets, TypeData^.ParamCount);
  CurReg := paEDX;
  P := @TypeData^.ParamList;
  Offset := StackSize;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    if System.TypInfo.TParamFlags(P[0]) * [pfVar, pfConst, pfAddress,
      pfReference, pfOut] <> [] then
      Size := 4
    else
      Size := GetTypeSize(ParamInfos^[I]^);
    if (Size <= 4) and (CurReg <= paECX) then
    begin
      ParamOffsets[I] := CurReg;
      Inc(CurReg);
    end
    else
    begin
      Dec(Offset, Size);
      ParamOffsets[I] := Offset;
    end;
    Inc(P, 1 + P[1] + 1);
    Inc(P, P[0] + 1);
  end;
end;

procedure TBaseMethodHandlerInstance.RegisterStub;
const
  PtrSize = SizeOf(Pointer);
  asm
    PUSH    EAX
    PUSH    ECX
    PUSH    EDX
    MOV     EDX,ESP
    CALL    Handler
    // Pop EDX and ECX off the stack while preserving all registers.
    MOV     [ESP+4],EAX
    POP     EAX
    POP     EAX
    POP     ECX             // Self
    MOV     ECX,[ECX].TBaseMethodHandlerInstance.StackSize

    TEST    ECX,ECX
    JZ      @@SimpleRet
    // Jump to the actual return instruction since it is most likely not just a RET
    // JMP     ECX    // Data Exec. Prevention: Jumping into a GetMem allocated memory block

    // stack address alignment
    ADD     ECX, PtrSize - 1
    AND     ECX, NOT (PtrSize - 1)
    AND     ECX, $FFFF

    // clean up the stack
    PUSH    EAX                         // we need this register, so save it
    MOV     EAX,[ESP + 4]               // Load the return address
    MOV     [ESP + ECX + 4], EAX        // Just blast it over the first param on the stack
    POP     EAX
    ADD     ESP,ECX                     // This will move the stack back to where the moved
    // return address is now located. The next RET
    // instruction will do the final stack cleanup
  @@SimpleRet:
end;

function GetCodePointer(Instance: TObject; P: Pointer): Pointer; inline;
begin
  if (IntPtr(P) and PROPSLOT_MASK) = PROPSLOT_VIRTUAL then // Virtual Method
    Result := PPointer(PNativeUInt(Instance)^ + (UIntPtr(P) and $FFFF))^
  else // Static method
    Result := P;
end;

procedure TBaseMethodHandlerInstance.Handler(Params: Pointer);
var
  P: PByte;
  Parameters: PParameters;
  I: Integer;
  Regs: array [paEAX .. paEDX] of Cardinal;
  Offset: Integer;
  Data: Pointer;
  MethodValues: TArray<TValue>;
  Zerk: Integer;
  tmp: TValue;
begin
  Parameters := Params;

  Zerk := 0; // зеркальное отрожение!

  SetLength(MethodValues, TypeData^.ParamCount);

  // Fetch the parameters into ParamValues
  P := @TypeData^.ParamList;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    Offset := ParamOffsets[I];
    if (Offset >= paEDX) and (Offset <= paECX) then
      Data := @Parameters^.Registers[Offset]
    else
      Data := @Parameters^.Stack[Offset];

    if ParamInfos^[I]^.Kind = tkClass then
      MethodValues[Zerk] := TObject(PPointer(Data)^)
    else if System.TypInfo.TParamFlags(P[0]) * [pfVar, pfOut] <> [] then
      TValue.Make(Pointer(PCardinal(Data)^), ParamInfos[I]^, MethodValues[Zerk])
    else
      TValue.Make(Data, ParamInfos[I]^, MethodValues[Zerk]);

    Inc(P, 1 + P[1] + 1);
    Inc(P, P[0] + 1);
    Inc(Zerk);
  end;
  // P is left pointing to the return type name if there is one.
  // Self.MethodHandler.
  Self.FOnBefore(Self.PHPFunc, Self._PropertyType, MethodValues);

  P := @TypeData^.ParamList;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    Offset := ParamOffsets[I];
    if (Offset >= paEDX) and (Offset <= paECX) then
      Data := @Parameters^.Registers[Offset]
    else
      Data := @Parameters^.Stack[Offset];

    if System.TypInfo.TParamFlags(P[0]) * [pfVar, pfOut] <> [] then
    begin
      // ~ = AV
      TValue.Make(Pointer(PCardinal(Data)^), ParamInfos[I]^, tmp);
      if (tmp.ToString <> MethodValues[I].ToString) then
        PPointer(PCardinal(Data)^)^ :=
          PPointer(MethodValues[I].GetReferenceToRawData^)^;
    end;

    Inc(P, 1 + P[1] + 1);
    Inc(P, P[0] + 1);
  end;



  // Let Stub procedures know where the RET instruction is
  asm
    MOV     EAX,DWORD PTR Regs[paEAX*4]
    MOV     EDX,DWORD PTR Regs[paEDX*4]
  end;
end; // of X86ASM implementation

end.