Skip to main content
Code Review

Return to Answer

Add multi-platform version.
Source Link
Comintern
  • 4.2k
  • 1
  • 18
  • 26

EDIT:

The following changes should make this safe on either 32 or 64 bit hosts (untested due to lack of access to a 64 bit Office install). Declare the following constants:

#If Win64 Then
 Private Const POINTER_SIZE As LongPtr = 8
#Else
 Private Const POINTER_SIZE As LongPtr = 4
#End If
Private Const INTERFACE_OFFSET As LongPtr = 7 * POINTER_SIZE
Private Const MAKE_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (2 * POINTER_SIZE)
Private Const INIT_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (3 * POINTER_SIZE)

Change the Declare Function to this:

Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Any)

And replace Sub SwapFunctions with this implementation:

Private Sub SwapFunctions()
 Dim first As Long
 Dim second As Long
 
 'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
 CopyMemory first, ByVal ObjPtr(Me), POINTER_SIZE
 CopyMemory second, ByVal first + MAKE_FUNCTION_OFFSET, POINTER_SIZE
 CopyMemory ByVal first + INTERFACE_OFFSET, ByVal first + INIT_FUNCTION_OFFSET, POINTER_SIZE
 CopyMemory ByVal first + INIT_FUNCTION_OFFSET, second, POINTER_SIZE
End Sub

EDIT:

The following changes should make this safe on either 32 or 64 bit hosts (untested due to lack of access to a 64 bit Office install). Declare the following constants:

#If Win64 Then
 Private Const POINTER_SIZE As LongPtr = 8
#Else
 Private Const POINTER_SIZE As LongPtr = 4
#End If
Private Const INTERFACE_OFFSET As LongPtr = 7 * POINTER_SIZE
Private Const MAKE_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (2 * POINTER_SIZE)
Private Const INIT_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (3 * POINTER_SIZE)

Change the Declare Function to this:

Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Any)

And replace Sub SwapFunctions with this implementation:

Private Sub SwapFunctions()
 Dim first As Long
 Dim second As Long
 
 'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
 CopyMemory first, ByVal ObjPtr(Me), POINTER_SIZE
 CopyMemory second, ByVal first + MAKE_FUNCTION_OFFSET, POINTER_SIZE
 CopyMemory ByVal first + INTERFACE_OFFSET, ByVal first + INIT_FUNCTION_OFFSET, POINTER_SIZE
 CopyMemory ByVal first + INIT_FUNCTION_OFFSET, second, POINTER_SIZE
End Sub
Add clarifying comment (execution order is non-obvious).
Source Link
Comintern
  • 4.2k
  • 1
  • 18
  • 26
'Point.cls - Predeclared
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Type TPoint
 X As Double
 Y As Double
End Type
Private this As TPoint
Public Function Make(ByVal X As Double, ByVal Y As Double) As Point
 Dim newPoint As Point
 Set newPoint = New Point
 'This swaps the vtable pointer of this function to the private internal one.
 SwapFunctions
 'Make the call. Due to the vtable hack, this will call InternalInitialize.
 newPoint.Make X, Y
 'Reset the vtable to it's initial state.
 SwapFunctions
 Set Make = newPoint
End Function
Public Property Get X() As Double
 X = this.X
End Property
Public Property Get Y() As Double
 Y = this.Y
End Property
'This has to be the exact same signature as Make or it will mis-align the stack
Private Function InternalInitialize(ByVal X As Double, ByVal Y As Double) As Point
 this.X = X
 this.Y = Y
End Function
Private Sub SwapFunctions()
 Dim first As Long
 Dim second As Long
 
 'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
 CopyMemory first, ByVal ObjPtr(Me), 4
 CopyMemory second, ByVal first + &H1C + 8, 4
 CopyMemory ByVal first + &H1C, ByVal first + &H1C + 12, 4
 CopyMemory ByVal first + &H1C + 12, second, 4
End Sub
'Point.cls - Predeclared
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Type TPoint
 X As Double
 Y As Double
End Type
Private this As TPoint
Public Function Make(ByVal X As Double, ByVal Y As Double) As Point
 Dim newPoint As Point
 Set newPoint = New Point
 'This swaps the vtable pointer of this function to the private internal one.
 SwapFunctions
 'Make the call.
 newPoint.Make X, Y
 'Reset the vtable to it's initial state.
 SwapFunctions
 Set Make = newPoint
End Function
Public Property Get X() As Double
 X = this.X
End Property
Public Property Get Y() As Double
 Y = this.Y
End Property
'This has to be the exact same signature as Make or it will mis-align the stack
Private Function InternalInitialize(ByVal X As Double, ByVal Y As Double) As Point
 this.X = X
 this.Y = Y
End Function
Private Sub SwapFunctions()
 Dim first As Long
 Dim second As Long
 
 'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
 CopyMemory first, ByVal ObjPtr(Me), 4
 CopyMemory second, ByVal first + &H1C + 8, 4
 CopyMemory ByVal first + &H1C, ByVal first + &H1C + 12, 4
 CopyMemory ByVal first + &H1C + 12, second, 4
End Sub
'Point.cls - Predeclared
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Type TPoint
 X As Double
 Y As Double
End Type
Private this As TPoint
Public Function Make(ByVal X As Double, ByVal Y As Double) As Point
 Dim newPoint As Point
 Set newPoint = New Point
 'This swaps the vtable pointer of this function to the private internal one.
 SwapFunctions
 'Make the call. Due to the vtable hack, this will call InternalInitialize.
 newPoint.Make X, Y
 'Reset the vtable to it's initial state.
 SwapFunctions
 Set Make = newPoint
End Function
Public Property Get X() As Double
 X = this.X
End Property
Public Property Get Y() As Double
 Y = this.Y
End Property
'This has to be the exact same signature as Make or it will mis-align the stack
Private Function InternalInitialize(ByVal X As Double, ByVal Y As Double) As Point
 this.X = X
 this.Y = Y
End Function
Private Sub SwapFunctions()
 Dim first As Long
 Dim second As Long
 
 'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
 CopyMemory first, ByVal ObjPtr(Me), 4
 CopyMemory second, ByVal first + &H1C + 8, 4
 CopyMemory ByVal first + &H1C, ByVal first + &H1C + 12, 4
 CopyMemory ByVal first + &H1C + 12, second, 4
End Sub
added 1 character in body
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467

Which leads us to... vtable hacking. The grossly simplified explanation is that an interface is simply a collection of function pointers to the entry points of the class's functionality. The instance of the class is passed as a parameter (along with any others) to that function. So you just swap the vtable entries of your private intializerinitializer (which sets the instance variables) with your factory method, set them, and swap them back:

Which leads us to... vtable hacking. The grossly simplified explanation is that an interface is simply a collection of function pointers to the entry points of the class's functionality. The instance of the class is passed as a parameter (along with any others) to that function. So you just swap the vtable entries of your private intializer (which sets the instance variables) with your factory method, set them, and swap them back:

Which leads us to... vtable hacking. The grossly simplified explanation is that an interface is simply a collection of function pointers to the entry points of the class's functionality. The instance of the class is passed as a parameter (along with any others) to that function. So you just swap the vtable entries of your private initializer (which sets the instance variables) with your factory method, set them, and swap them back:

Typo in comment.
Source Link
Comintern
  • 4.2k
  • 1
  • 18
  • 26
Loading
made the warning more... flashy
Source Link
Mathieu Guindon
  • 75.5k
  • 18
  • 194
  • 467
Loading
edited body
Source Link
Comintern
  • 4.2k
  • 1
  • 18
  • 26
Loading
Source Link
Comintern
  • 4.2k
  • 1
  • 18
  • 26
Loading
lang-vb

AltStyle によって変換されたページ (->オリジナル) /