Bug with For Each enumeration on x64 Custom Classes

前端未结

关注

 1  1062

I have found a bug in VBA a few months ago and was unable to find a decent workaround. The bug is really annoying as it kind of restricts a nice language feature.

When us

相关标签:

1条回答

逝去的感伤

2021-02-02 14:55
What is happening

It appears that the stack frames are overlapping although they should not. Having enough variables in the ShowBug method prevents a crash and the values of the variables (in the caller subroutine) are simply changed because the memory they refer to is also used by another stack frame (the called subroutine) that was added/pushed later at the top of the call stack.

We can test this by adding a couple of Debug.Print statements to the same code from the question.

The CustomCollection class:
```
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CustomCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_coll As Collection

Private Sub Class_Initialize()
    Set m_coll = New Collection
End Sub
Private Sub Class_Terminate()
    Set m_coll = Nothing
End Sub

Public Sub Add(v As Variant)
    m_coll.Add v
End Sub

Public Function NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
    Debug.Print "The NewEnum return address " & VarPtr(NewEnum) & " should be outside of the"
    Set NewEnum = m_coll.[_NewEnum]
End Function
```
And the calling code, in a standard .bas module:
```
Option Explicit

Sub Main()
    #If Win64 Then
        Dim c As New CustomCollection
        c.Add 1
        c.Add 2
        ShowBug c
    #Else
        MsgBox "This bug does not occur on 32 bits!", vbInformation, "Cancelled"
    #End If
End Sub

Sub ShowBug(ByRef c As CustomCollection)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    For Each v In c
    Next v
    Debug.Print VarPtr(ptr9) & " - " & VarPtr(ptr0) & " memory range"
    Debug.Assert ptr0 = 0
End Sub
```
By running Main I get something like this in the Immediate Window:

The address of the NewEnum return value is clearly at a memory address in between the ptr0 and ptr9 variables of the ShowBug method. So, that is why the variables get values out of nowhere, because they actually come from the stack frame of the NewEnum method (like the address of the object's vtable or the address of the IEnumVariant interface). If the variables would not be there, then the crash is obvious as more critical parts of memory are being overwritten (e.g. the frame pointer address for the ShowBug method). As the stack frame for the NewEnum method is larger (we can add local variables for example, to increase the size), the more memory is shared between the top stack frame and the one below in the call stack.

What happens if we workaround the bug with the options described in the question? Simply adding a Set v = Nothing before the For Each v In c line, results into:

Showing both previous value and the current one (bordered blue), we can see that the NewEnum return is at a memory address outside of the ptr0 and ptr9 variables of the ShowBug method. It seems that the stack frame was correctly allocated using the workaround.

If we break inside the NewEnum the call stack looks like this:

How For Each invokes NewEnum

Every VBA class is derived from IDispatch (which in turn is derived from IUnknown).

When a For Each... loop is called on an object, that object's IDispatch::Invoke method is called with a dispIDMember equal to -4. A VBA.Collection already has such a member but for VBA custom classes we mark our own method with Attribute NewEnum.VB_UserMemId = -4 so that Invoke can call our method.

Invoke is not called directly if the interface used in the For Each line is not derived from IDispatch. Instead, IUnknown::QueryInterface is called first and asked for the IDispatch interface. In this case Invoke is obviously called only after IDispatch interface is returned. Right here is the reason why using For Each on an Object declared As IUnknown will not cause the bug regardless if it is passed ByRef or if it is a global or class member custom collection. It simply uses workaround number 1 mentioned in the question (i.e. calls another method) although we cannot see it.

Hooking Invoke

We can replace the non-VB Invoke method with one of our own in order to investigate further. In a standard .bas module we need the following code to hook:
```
Option Explicit

#If Mac Then
    #If VBA7 Then
        Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
    #Else
        Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
    #End If
#Else 'Windows
    'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
    #If VBA7 Then
        Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    #End If
#End If

#If Win64 Then
    Private Const PTR_SIZE As Long = 8
#Else
    Private Const PTR_SIZE As Long = 4
#End If

#If VBA7 Then
    Private newInvokePtr As LongPtr
    Private oldInvokePtr As LongPtr
    Private invokeVtblPtr As LongPtr
#Else
    Private newInvokePtr As Long
    Private oldInvokePtr As Long
    Private invokeVtblPtr As Long
#End If

'https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-idispatch-invoke
Function IDispatch_Invoke(ByVal this As Object _
    , ByVal dispIDMember As Long _
    , ByVal riid As LongPtr _
    , ByVal lcid As Long _
    , ByVal wFlags As Integer _
    , ByVal pDispParams As LongPtr _
    , ByVal pVarResult As LongPtr _
    , ByVal pExcepInfo As LongPtr _
    , ByRef puArgErr As Long _
) As Long
    Const DISP_E_MEMBERNOTFOUND = &H80020003
    '
    Debug.Print "The IDispatch::Invoke return address " & VarPtr(IDispatch_Invoke) & " should be outside of the"
    IDispatch_Invoke = DISP_E_MEMBERNOTFOUND
End Function

Sub HookInvoke(obj As Object)
    If obj Is Nothing Then Exit Sub
    #If VBA7 Then
        Dim vTablePtr As LongPtr
    #Else
        Dim vTablePtr As Long
    #End If
    '
    newInvokePtr = VBA.Int(AddressOf IDispatch_Invoke)
    CopyMemory vTablePtr, ByVal ObjPtr(obj), PTR_SIZE
    '
    invokeVtblPtr = vTablePtr + 6 * PTR_SIZE
    CopyMemory oldInvokePtr, ByVal invokeVtblPtr, PTR_SIZE
    CopyMemory ByVal invokeVtblPtr, newInvokePtr, PTR_SIZE
End Sub

Sub RestoreInvoke()
    If invokeVtblPtr = 0 Then Exit Sub
    '
    CopyMemory ByVal invokeVtblPtr, oldInvokePtr, PTR_SIZE
    invokeVtblPtr = 0
    oldInvokePtr = 0
    newInvokePtr = 0
End Sub
```
and we run the Main2 method (standard .bas module) to produce the bug:
```
Option Explicit

Sub Main2()
    #If Win64 Then
        Dim c As Object
        Set c = New CustomCollection
        c.Add 1
        c.Add 2
        '
        HookInvoke c
        ShowBug2 c
        RestoreInvoke
    #Else
        MsgBox "This bug does not occur on 32 bits!", vbInformation, "Cancelled"
    #End If
End Sub

Sub ShowBug2(ByRef c As CustomCollection)
    Dim ptr00 As LongPtr
    Dim ptr01 As LongPtr
    Dim ptr02 As LongPtr
    Dim ptr03 As LongPtr
    Dim ptr04 As LongPtr
    Dim ptr05 As LongPtr
    Dim ptr06 As LongPtr
    Dim ptr07 As LongPtr
    Dim ptr08 As LongPtr
    Dim ptr09 As LongPtr
    Dim ptr10 As LongPtr
    Dim ptr11 As LongPtr
    Dim ptr12 As LongPtr
    Dim ptr13 As LongPtr
    Dim ptr14 As LongPtr
    Dim ptr15 As LongPtr
    Dim ptr16 As LongPtr
    Dim ptr17 As LongPtr
    Dim ptr18 As LongPtr
    Dim ptr19 As LongPtr
    '
    Dim v As Variant
    '
    On Error Resume Next
    For Each v In c
    Next v
    Debug.Print VarPtr(ptr19) & " - " & VarPtr(ptr00) & " range on the call stack"
    Debug.Assert ptr00 = 0
End Sub
```
^{Notice that more dummy ptr variables are needed to prevent the crash as the stack frame for IDispatch_Invoke is bigger (hence, the memory overlap is bigger).}

By running the above, I get:

The same bug occurs although the code never reaches the NewEnum method due to the hooking of the Invoke method. The stack frame is again wrongfully allocated.

Again, adding a Set v = Nothing before the For Each v In c results into:

The stack frame is allocated correctly (bordered green). This indicates that the issue is not with the NewEnum method and also not with our replacement Invoke method. Something is happening before our Invoke is called.

If we break inside our IDispatch_Invoke the call stack looks like this:

One last example. Consider a blank (with no code) class Class1. If we run Main3 in the following code:
```
Option Explicit

Sub Main3()
    #If Win64 Then
        Dim c As New Class1
        ShowBug3 c
    #Else
        MsgBox "This bug does not occur on 32 bits!", vbInformation, "Cancelled"
    #End If
End Sub

Sub ShowBug3(ByRef c As Class1)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    On Error Resume Next
    For Each v In c
    Next v
    Debug.Assert ptr0 = 0
End Sub
```
The bug simply does not occur. How is this different from running Main2 with our own hooked Invoke? In both cases DISP_E_MEMBERNOTFOUND is returned and no NewEnum method is called.

Well, if we look at the previously shown call stacks side by side:

we can see that the non-VB Invoke is not pushed on the VB stack as a separate "Non-Basic Code" entry.

Apparently, the bug only occurs if a VBA method is called (either NewEnum via the original non-VB Invoke or our own IDispatch_Invoke). If a non-VB method is called (like the original IDispatch::Invoke with no following NewEnum) the bug does not occur as in Main3 above. No bug occurs when running For Each... on a VBA Collection within the same circumstances either.

The bug cause

As all the above examples suggest, the bug can be summarized with the following:
For Each calls IDispatch::Invoke which in turn calls NewEnum while the stack pointer has not been incremented with the size of the ShowBug stack frame. Hence, same memory is used by both frames (the caller ShowBug and the callee NewEnum).

Workarounds

Ways to force the correct incrementation of the stack pointer:
1. call another method directly (before the For Each line) e.g. Sin 1
2. call another method indirectly (before the For Each line):
  - a call to IUnknown::AddRef by passing the argument ByVal
  - a call to IUnknown::QueryInterface by using the stdole.IUnknown interface
  - using a Set statement which will call either AddRef or Release or both (e.g. Set c = c). Could also call QueryInterface depending on the source and target interfaces
As suggested in the EDIT section of the question, we don't always have the possibility to pass the Custom Collection class ByVal because it could simply be a global variable, or a class member and we would need to remember to do a dummy Set statement or to call another method before For Each... is executed.

Solution

I still could not find a better solution that the one presented in the question, so I am just going to replicate the code here as part of the answer, with a slight tweak.

EnumHelper class:
```
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "EnumHelper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_enum As IEnumVARIANT

Public Property Set EnumVariant(newEnum_ As IEnumVARIANT)
    Set m_enum = newEnum_
End Property
Public Property Get EnumVariant() As IEnumVARIANT
Attribute EnumVariant.VB_UserMemId = -4
    Set EnumVariant = m_enum
End Property

Public Property Get Self() As EnumHelper
    Set Self = Me
End Property
```
CustomCollection would now become something like:
```
Option Explicit

Private m_coll As Collection

Private Sub Class_Initialize()
    Set m_coll = New Collection
End Sub
Private Sub Class_Terminate()
    Set m_coll = Nothing
End Sub

Public Sub Add(v As Variant)
    m_coll.Add v
End Sub

Public Function NewEnum() As EnumHelper
    With New EnumHelper
        Set .EnumVariant = m_coll.[_NewEnum]
        Set NewEnum = .Self
    End With
End Function
```
You would just need to call with For Each v in c.NewEnum

Although, the EnumHelper class would be an extra class needed in any project implementing a custom collection class, there are a couple of advantages as well:
1. You would never need to add the Attribute [MethodName].VB_UserMemId = -4 to any other custom collection class. This is even more useful for users that do not have RubberDuck installed ('@Enumerator annotation), as they would need to export, edit the .cls text file and import back for each custom collection class
2. You could expose multiple EnumHelpers for the same class. Consider a custom dictionary class. You could have an ItemsEnum and a KeysEnum at the same time. Both For Each v in c.ItemsEnum and For Each v in c.KeysEnum would work
3. You would never forget to use one of the workarounds presented above as the method exposing the EnumHelper class would be called before Invoke is calling member ID -4
4. You would not get crashes anymore. If you forget to call with For Each v in c.NewEnum and instead use For Each v in c you would just get a runtime error which would be picked up in testing anyway. Of course you could still force a crash by passing the result of c.NewEnum to another method ByRef which would then need to execute a For Each before any other method call or Set statement. Highly unlikely you would ever do that
5. Obvious but worth mentioning, you would use the same EnumHelper class for all the custom collection classes you might have in a project
0 讨论(0)
发布评论:

提交评论
- 加载中...