Private VBA Class Initializer called from Factory #2

About

This is a follow-up of a previous question Private VBA Class Initializer called from Factory. I’ve decided to create a new question instead of answering my old question because I would like the community to review and possibly suggest improvements on the new improved code.

VBA Class methods are always called with an instance pointer but the implementation is hidden and managed by VBA. If we can manipulate that specific instance pointer then we can access methods from instance B of a class directly from instance A (of the same class type) even if those methods are declared as Private. The previous question does exactly that but in a crude, slow and unsafe way. This question will cover a better approach (in my humble view).

For example, a method of a class might look like this in VBA:

Public Sub Test(ByVal arg1)

but the method is actually implemented more like this:

Public Sub Test(this As LongPtr, ByVal arg1)

The code presented in this question replaces the this pointer with another instance pointer (directly in memory) and thus allows inter-instance calls.

The Me keyword

Before we continue, let’s clarify what the Me keyword is. Me behaves as a locally-scoped variable to any class method but in reality it is implemented as a hidden Property Get that is reading the above mentioned this pointer (which is locally scoped because it was passed as an argument to the class method). This is easy to check:

Code inside a SomeClass class:

Option Explicit

Public Sub Test()
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim tempPtr As LongPtr

    ptr1 = LibMemory.MemLongPtr(VarPtr(Me)) 'Me is still within scope while memory is read
    ptr2 = LibMemory.MemLongPtr(VarPtr(Me)) 'Me is still within scope while memory is read
    Debug.Assert ptr1 = ptr2 'Same address so code does not stop
    
    tempPtr = VarPtr(Me) 'Me gets out of scope after assignment
    ptr3 = LibMemory.MemLongPtr(tempPtr) 'Me is not is scope anymore
    Debug.Assert ptr1 = ptr3 'ptr3 is 0
End Sub

Code in a standard module:

Sub TestME()
    Dim c As New SomeClass
    c.Test
End Sub

By running the TestME method, the second Assert within the class instance will fail because Me got out of scope. This suggests that Me is actually a Property Get or a Function rather than a locally-scoped variable. Hence, we cannot use Me to get to this.

Notice that I am not using the well-known CopyMemory API. Instead I am using a LibMemory library that I have created specifically for this question. LibMemory can be found at CodeReview and GitHub. The CR question explains the reasoning behind the library.

The Code

First of all, we need the above-mentioned LibMemory

We also need a class that encapsulates all the logic for redirecting class instances.
Code inside InstanceRedirector class:

Option Explicit

Private Type INSTANCE_REDIRECT
    #If VBA7 Then
        swapAddress As LongPtr
        originalPtr As LongPtr
    #Else
        swapAddress As Long
        originalPtr As Long
    #End If
    targetInstance As Object 'Keep a reference until restore is called
End Type

Private this As INSTANCE_REDIRECT

'*******************************************************************************
'Redirects the instance of a class to another instance of the same class
'This method must be called from a class instance's Function (not Sub)
'
'Warning! RestoreInstance must be called before the calling function goes out
'   of scope OR this instance must be terminated so that RestoreInstance is
'   called at Class_Terminate
'
'Warning! vbArray + vbString Function return type is not supported. It would be
'   possible to find the correct address by reading memory in a loop but there
'   would be no checking available
'*******************************************************************************
#If VBA7 Then
Public Sub Redirect(ByVal funcReturnPtr As LongPtr, ByVal currentInstance As Object, ByVal targetInstance As Object)
#Else
Public Sub Redirect(ByVal funcReturnPtr As Long, ByVal currentInstance As Object, ByVal targetInstance As Object)
#End If
    Const methodName As String = "Redirect"
    '
    'Validate Input
    If currentInstance Is Nothing Or targetInstance Is Nothing Then
        Err.Raise 91, TypeName(Me) & "." & methodName, "Object not set"
    ElseIf TypeName(currentInstance) <> TypeName(targetInstance) Then
        Err.Raise 5, TypeName(Me) & "." & methodName, "Expected same interface"
    ElseIf funcReturnPtr = 0 Then
        Err.Raise 5, TypeName(Me) & "." & methodName, "Missing Func Return Ptr"
    End If
    '
    'Store original pointer
    this.originalPtr = ObjPtr(GetDefaultInterface(currentInstance))
    '
    'On x64 the shadow stack space is allocated next to the Function Return
    'On x32 the stack space has a fixed offset (found through testing)
    #If Win64 Then
        Const memOffsetNonVariant As LongLong = LibMemory.PTR_SIZE
        Const memOffsetVariant As LongLong = LibMemory.PTR_SIZE * 3
    #Else
        Const memOffsetNonVariant As Long = LibMemory.PTR_SIZE * 28
        Const memOffsetVariant As Long = LibMemory.PTR_SIZE * 31
    #End If
    '
    'Try Non-Variant func return first and then Variant if the former fails
    If Not SetSwapAddress(funcReturnPtr, memOffsetNonVariant) Then
        SetSwapAddress funcReturnPtr, memOffsetVariant
    End If
    '
    If this.swapAddress = 0 Then
        Err.Raise 5, TypeName(Me) & "." & methodName, "Invalid input or " _
        & "not called from class function or vbArray + vbString func return type"
    End If
    '
    'Keep a reference until restore is called, for extra safety
    Set this.targetInstance = GetDefaultInterface(targetInstance)
    '
    'Redirect Instance
    LibMemory.MemLongPtr(this.swapAddress) = ObjPtr(this.targetInstance)
End Sub

'*******************************************************************************
'Finds and sets the swap address (address of the instance pointer on the stack)
'*******************************************************************************
#If VBA7 Then
Private Function SetSwapAddress(ByRef funcReturnPtr As LongPtr, ByRef memOffset As LongPtr) As Boolean
#Else
Private Function SetSwapAddress(ByRef funcReturnPtr As Long, ByRef memOffset As Long) As Boolean
#End If
    #If VBA7 Then
        Dim tempPtr As LongPtr
    #Else
        Dim tempPtr As Long
    #End If
    '
    tempPtr = LibMemory.UnsignedAddition(funcReturnPtr, memOffset)
    #If Win64 Then
    #Else
        tempPtr = UnsignedAddition(MemLongPtr(tempPtr), PTR_SIZE * 2)
    #End If
    If LibMemory.MemLongPtr(tempPtr) = this.originalPtr Then
        this.swapAddress = tempPtr
        SetSwapAddress = True
    End If
End Function

'*******************************************************************************
'Returns the default interface for an object
'Casting from IUnknown to IDispatch (Object) forces a call to QueryInterface for
'   the IDispatch interface (which knows about the default interface)
'*******************************************************************************
Private Function GetDefaultInterface(obj As IUnknown) As Object
    Set GetDefaultInterface = obj
End Function

'*******************************************************************************
'Restores the original instance pointer at the previously used swap address
'*******************************************************************************
Public Sub Restore()
    If this.swapAddress = 0 Or this.originalPtr = 0 Then Exit Sub
    LibMemory.MemLongPtr(this.swapAddress) = this.originalPtr
    this.swapAddress = 0
    this.originalPtr = 0
    Set this.targetInstance = Nothing
End Sub

'*******************************************************************************
'Extra safety in case .Restore is not called
'*******************************************************************************
Private Sub Class_Terminate()
    Restore
End Sub

Notice that this code has a lot of checks in place compared to the previous CR question which was only reading memory in a loop until a specific value was found. Moreover, the exact location is found using predefined memory offsets.

Demo

Consider a Class1 which has VB_PredeclaredId set to True:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'@PredeclaredId
Option Explicit

Private m_id As Long

Public Function Factory(ByVal newID As Long) As Class1
    Dim c As New Class1
    '
    With New InstanceRedirector
        .Redirect VarPtr(Factory), Me, c
        Init newID
        .Restore 'This can be ommited within a With New block (Class_Terminate calls it anyway)
    End With
    Set Factory = c
End Function
Private Sub Init(newID As Long)
    m_id = newID
End Sub

Public Function Factory2(ByVal newID As Long) As Class1
    Dim c As New Class1
    '
    c.Init2 newID
    Set Factory2 = c
End Function
Public Sub Init2(newID As Long)
    m_id = newID
End Sub

Public Property Get ID() As Long
    ID = m_id
End Property

The Factory method uses a private Init method while the Factory2 uses a public Init2 method.

Quick speed test in a standard module:

Option Explicit

Sub TestFactorySpeeds()
    Const loopsCount As Long = 100000
    Dim i As Long
    Dim t As Double
    '
    t = Timer
    For i = 1 To loopsCount
        Debug.Assert Class1.Factory2(i).ID = i
    Next i
    Debug.Print "Public  Init (seconds): " & VBA.Round(Timer - t, 3)
    '
    t = Timer
    For i = 1 To loopsCount
        Debug.Assert Class1.Factory(i).ID = i
    Next i
    Debug.Print "Private  Init (seconds): " & VBA.Round(Timer - t, 3)
End Sub

In general the Private method seems to be only 3x slower but the benefit of accessing private methods seems to be worth the speed loss.

Notes

Obviously, the demo above shows how to create a Factory that is using a Private Init but the approach presented here allows any class instance (Predeclared or not) to access private methods within other instances of the same class type. A good idea provided by @TinMan in the previous question is to create a class Clone method.

The return value of the class function where the redirection is used does not necessarily need to be an Object. It can be any data type (except an Array of String i.e. vbArray + vbString VarType). For return types of Array type, the VarPtrArray function from the LibMemory library can be used for the first argument when calling InstanceRedirector.Redirect.

The class method where the redirection is used/called needs to be a Function and not a Sub because the function return will be allocated on the call stack and we can use it’s address to find the actual memory location of the class instance pointer.

On x64 the instance pointer is allocated on the call stack immediately after the function return while on x32 there is a fixed offset and a redirection. If the function return type is of type Variant then the offsets are increased by two ptr positions on x64 (i.e. + 16 bytes) and three ptr positions on x32 (i.e. + 12 bytes).

Question(s)

I would be very grateful for suggestions that could improve the code in any way (speed, readability, structure, naming etc.).