Вызов любых функций по указателю

[The trick]

Все просто. Объявляем прототип функции (пустую функцию), где дополнительно первым параметром будет передаваться адрес функции. Далее пропатчиваем его, таким образом чтобы он перекидывал нас по адресу заданному первым параметром. Таким образом можно вызывать функции в стандартных модулях, модулях класса, формы, API-функции (например полученные через LoadLibrary и GetProcAddress). Работает и в IDE и в скомпилированном виде, но только при Start With Full Compile (Ctrl+F5).
Для "пропатчивания" прототипа я сделал отдельный модуль:

Код: Выделить всё

Option Explicit

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Sub EbGetExecutingProj Lib "vba6" (hProject As Long)
Private Declare Function TipGetFunctionId Lib "vba6" (ByVal hProj As Long, ByVal bstrName As Long, ByRef bstrId As Long) As Long
Private Declare Function TipGetLpfnOfFunctionId Lib "vba6" (ByVal hProject As Long, ByVal bstrId As Long, ByRef lpAddress As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal lpbstr As Long)

Private Const PAGE_EXECUTE_READWRITE = &H40

' Вспомогательные функции
Public Sub PatchFunc(FuncName As String, ByVal Addr As Long)
    Dim lpAddr As Long, hProj As Long, sId As Long, InIDE As Boolean

    Debug.Assert MakeTrue(InIDE)

    ' Получаем адрес функции
    If InIDE Then
        EbGetExecutingProj hProj
        TipGetFunctionId hProj, StrPtr(FuncName), sId
        TipGetLpfnOfFunctionId hProj, sId, lpAddr
        SysFreeString sId
    Else
        lpAddr = GetAddr(Addr)
        VirtualProtect lpAddr, 8, PAGE_EXECUTE_READWRITE, 0
    End If

    ' Записываем вставку
    ' Запускать только по Ctrl+F5!!
    ' pop eax
    ' pop ecx
    ' push eax
    ' jmp ecx

    GetMem4 &HFF505958, ByVal lpAddr
    GetMem4 &HE1, ByVal lpAddr + 4
End Sub

Private Function GetAddr(ByVal Addr As Long) As Long
    GetAddr = Addr
End Function
Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
    bvar = True: MakeTrue = True
End Function

Пример вызова обычных функций в стандартном модуле:

Код: Выделить всё

' Пример вызова обычных функции по указателю
Public Sub Main()

    ' Пропатчиваем функции, перед первым вызовом
    PatchFunc "Proto1", AddressOf Proto1
    PatchFunc "Proto2", AddressOf Proto2

    MsgBox Proto1(AddressOf Func1, 1, "Вызов")
    MsgBox Proto1(AddressOf Func2, 2, "По указателю")
    MsgBox Proto1(AddressOf Func3, 3, ";)")

    Call Proto2(AddressOf Sub1)
    Call Proto2(AddressOf Sub2)
End Sub

' Прототип функций
Private Function Proto1(ByVal Addr As Long, ByVal x As Long, y As String) As String
End Function
Private Sub Proto2(ByVal Addr As Long)
End Sub
' Функции
Private Function Func1(ByVal x As Long, y As String) As String
    Func1 = "Func1_" & y
End Function
Private Function Func2(ByVal x As Long, y As String) As String
    Func2 = "Func2_" & y
End Function
Private Function Func3(ByVal x As Long, y As String) As String
    Func3 = "Func3_" & y
End Function
Private Sub Sub1()
    MsgBox "Sub1"
End Sub
Private Sub Sub2()
    MsgBox "Sub2"
End Sub


Пример вызова функций API по адресу полученному через GetProcAddress:

Код: Выделить всё

Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long


' Пример вызова WinApi функций по указателю
Public Sub Main()
    Dim hUser As Long, hGDI As Long
    Dim DC As Long

    hUser = LoadLibrary("user32")
    hGDI = LoadLibrary("gdi32")

    PatchFunc "GetDC", AddressOf GetDC
    PatchFunc "ReleaseDC", AddressOf ReleaseDC
    PatchFunc "Ellipse", AddressOf Ellipse

    DC = GetDC(GetProcAddress(hUser, "GetDC"), 0)
    Ellipse GetProcAddress(hGDI, "Ellipse"), DC, 0, 0, 500, 500
    ReleaseDC GetProcAddress(hUser, "ReleaseDC"), 0, DC
End Sub

' Прототип функций
Private Function GetDC(ByVal Addr As Long, ByVal hWnd As Long) As Long
End Function
Private Function ReleaseDC(ByVal Addr As Long, ByVal hWnd As Long, ByVal hdc As Long) As Long
End Function
Private Function Ellipse(ByVal Addr As Long, ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
End Function

Пример вызова методов класса по указателю:

• Модуль:

  Код: Выделить всё

  Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long

' Пример вызова методов объекта по указателю
Public Sub Main()
    Dim IUnk    As Long
    Dim lpProp  As Long
    Dim lpView  As Long
    Dim Obj1    As clsTest
    Dim Obj2    As clsTest
    Dim ret     As Long

    Set Obj1 = New clsTest
    Set Obj2 = New clsTest
   
    GetMem4 ByVal ObjPtr(Obj1), IUnk
    GetMem4 ByVal IUnk + &H1C, lpProp
    GetMem4 ByVal IUnk + &H20, lpView
   
    PatchFunc "clsTest_PropLet", AddressOf clsTest_PropLet
    PatchFunc "clsTest_View", AddressOf clsTest_View
   
    clsTest_PropLet lpProp, Obj1, 1234
    clsTest_PropLet lpProp, Obj2, 9876
   
    clsTest_View lpView, Obj1, ret
    Debug.Print ret
    clsTest_View lpView, Obj2, ret
    Debug.Print ret
End Sub

' Прототип функций
Private Function clsTest_PropLet(ByVal Addr As Long, ByVal Obj As clsTest, ByVal Value As Long) As Long
End Function
Private Function clsTest_View(ByVal Addr As Long, ByVal Obj As clsTest, ret As Long) As Long
End Function


• Класс:

  Код: Выделить всё

  Option Explicit

Dim mValue As Long

Public Property Let Prop(ByVal Value As Long)
    mValue = Value
End Property
Public Function View() As Long
    View = MsgBox(mValue, vbYesNoCancel)
End Function


[The trick]

Я немного модифицировал модуль (теперь он стал совсем маленький):

Код: Выделить всё

Option Explicit

Private Declare Function GetMem4 Lib "msvbvm60" ( _
                         ByRef src As Any, _
                         ByRef dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" ( _
                         ByVal lpAddress As Long, _
                         ByVal dwSize As Long, _
                         ByVal flNewProtect As Long, _
                         ByRef lpflOldProtect As Long) As Long

Private Const PAGE_EXECUTE_READWRITE = &H40

' // Helpers functions
Public Sub PatchFunc(ByVal Addr As Long)
    Dim InIDE As Boolean

    Debug.Assert MakeTrue(InIDE)

    If InIDE Then
        GetMem4 ByVal Addr + &H16, Addr
    Else
        VirtualProtect Addr, 8, PAGE_EXECUTE_READWRITE, 0
    End If

    GetMem4 &HFF505958, ByVal Addr
    GetMem4 &HE1, ByVal Addr + 4
End Sub

Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
    bvar = True: MakeTrue = True
End Function

Также добавил один пример - аналог С++ функции qSort, где в качестве аргумента сравнения передается пользовательская функция:

Код: Выделить всё

Option Explicit

Private Type Vector2D
    posX As Single
    posY As Single
End Type

Private Declare Sub memcpy Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    ByRef Destination As Any, _
                    ByRef Source As Any, _
                    ByVal Length As Long)
                   
' // Buffer for exchanging
Dim buffer()    As Byte
Dim isInit      As Boolean

' // Calling of the standard functions using the pointers
Public Sub Main()
    Dim lngArray()  As Long
    Dim index       As Long
   
    ' // We're testing the function that sorts the long-array
    ReDim lngArray(99)
   
    For index = 0 To UBound(lngArray)
        lngArray(index) = Rnd * 100
    Next
   
    ' // Magic of the function pointers
    QuickSort VarPtr(lngArray(0)), UBound(lngArray) + 1, Len(lngArray(0)), AddressOf ComparatorLong
   
    ' // Now we're testing the function that sorts the string-array
    Dim strArray()  As String
   
    ReDim strArray(5)
   
    strArray(0) = "Calling"
    strArray(1) = "of the standard functions"
    strArray(2) = "using the pointers"
    strArray(3) = "on VB6"
    strArray(4) = "by The trick"
    strArray(5) = "2015"
   
    ' // We're calling same function using the magic of pointers
    QuickSort VarPtr(strArray(0)), UBound(strArray) + 1, 4, AddressOf ComparatorString
   
    ' // Now we're testing the function that sorts the UDT-array (2D-vectors)
    ' // For example we'll sorting the array by vector length
    Dim vecArray() As Vector2D
   
    ReDim vecArray(99)
   
    For index = 0 To UBound(vecArray)
        vecArray(index).posX = Rnd * 10
        vecArray(index).posY = Rnd * 10
    Next
   
    ' // We're calling same function for the sorting of the UDT-array
    QuickSort VarPtr(vecArray(0)), UBound(vecArray) + 1, LenB(vecArray(0)), AddressOf ComparatorVector2D
   
    ' // Test length
    For index = 0 To UBound(vecArray)
        Debug.Print Sqr(vecArray(index).posX ^ 2 + vecArray(index).posY ^ 2)
    Next
   
End Sub

' // This callback function which sorts two long values
Public Function ComparatorLong( _
                ByRef lItem1 As Long, _
                ByRef lItem2 As Long) As Long
    ComparatorLong = Sgn(lItem1 - lItem2)
End Function

' // This callback function which sorts two string values
Public Function ComparatorString( _
                ByRef lItem1 As String, _
                ByRef lItem2 As String) As Long
    ComparatorString = StrComp(lItem1, lItem2, vbTextCompare)
End Function

' // This callback function which sorts two 2D-vectors values by length
Public Function ComparatorVector2D( _
                ByRef lItem1 As Vector2D, _
                ByRef lItem2 As Vector2D) As Long
    ' // Optimize sqr
    ComparatorVector2D = Sgn((lItem1.posX * lItem1.posX + lItem1.posY * lItem1.posY) - _
                             (lItem2.posX * lItem2.posX + lItem2.posY * lItem2.posY))
End Function

' // Quick-sort using the callback function for a comparing
' // This function uses callback function (lpfnComparator)
Public Sub QuickSort( _
           ByVal lpFirstPtr As Long, _
           ByVal lNumOfItems As Long, _
           ByVal lSizeElement As Long, _
           ByVal lpfnComparator As Long)
           
    Dim lpI     As Long
    Dim lpJ     As Long
    Dim lpM     As Long
    Dim lpLast  As Long
   
    If Not isInit Then
        ' // Initialize patching and buffer for exchanging
        ReDim buffer(lSizeElement - 1)
        PatchFunc AddressOf MainComparator
        isInit = True
       
    End If
   
    lpLast = lpFirstPtr + (lNumOfItems - 1) * lSizeElement
    lpI = lpFirstPtr
    lpJ = lpLast
    lpM = lpFirstPtr + ((lNumOfItems - 1) \ 2) * lSizeElement

    Do Until lpI > lpJ
       
        ' // Call function that being passed into the lpfnComparator parameter
        Do While MainComparator(lpfnComparator, lpI, lpM) = -1
            lpI = lpI + lSizeElement
        Loop
       
        ' // Call function that being passed into the lpfnComparator parameter
        Do While MainComparator(lpfnComparator, lpJ, lpM) = 1
            lpJ = lpJ - lSizeElement
        Loop
       
        ' // Exchanging
        If (lpI <= lpJ) Then
           
            If lpI = lpM Then
                lpM = lpJ
            ElseIf lpJ = lpM Then
                lpM = lpI
            End If
           
            If lSizeElement > UBound(buffer) + 1 Then
                ReDim buffer(lSizeElement - 1)
            End If
           
            memcpy buffer(0), ByVal lpI, lSizeElement
            memcpy ByVal lpI, ByVal lpJ, lSizeElement
            memcpy ByVal lpJ, buffer(0), lSizeElement
 
            lpI = lpI + lSizeElement
            lpJ = lpJ - lSizeElement
           
        End If
       
    Loop

    If lpFirstPtr < lpJ Then
        QuickSort lpFirstPtr, (lpJ - lpFirstPtr) \ lSizeElement + 1, lSizeElement, lpfnComparator
    End If
   
    If lpI < lpLast Then
        QuickSort lpI, (lpLast - lpI) \ lSizeElement + 1, lSizeElement, lpfnComparator
    End If
   
End Sub

' // Prototype for comparator function
' // If lpItem1 > lpItem2 then function return 1
' // If lpItem1 = lpItem2 then function return 0
' // If lpItem1 < lpItem2 then function return -1
Public Function MainComparator( _
                ByVal lpAddressOfFunction As Long, _
                ByVal lpItem1 As Long, _
                ByVal lpItem2 As Long) As Long
End Function

Скачать.

[Хакер]

Выкладывай аттачем. Столько проблем теперь от ресурсов, которые умерли.

[Mikle]

Использую кирпич для динамического подключения dll. Появился вопрос:
А как выгрузить библиотеку, не завершая работу своей программы? Чтобы, например, подгрузить функцию с тем же именем из другой библиотеки.

[Хакер]

А как выгрузить библиотеку, не завершая работу своей программы? Чтобы, например, подгрузить функцию с тем же именем из другой библиотеки.

Обратным образом по отношению к тому,как загружал её. Например FreeLibrary, если загружалась с помощью LoadLibrary. Ответ выглядит настолько очевидным, что начинает казаться, что где-то есть подвох.

[Mikle]

Ответ выглядит настолько очевидным, что начинает казаться, что где-то есть подвох.

Есть сомнения на счёт пропатченных функций, не нужно ли их как-то восстанавливать? Например, когда в новой загруженной dll список функций не полный.

[The trick]

Ответ выглядит настолько очевидным, что начинает казаться, что где-то есть подвох.

Есть сомнения на счёт пропатченных функций, не нужно ли их как-то восстанавливать? Например, когда в новой загруженной dll список функций не полный.

Привет. Каким образом используешь библиотеку? Можно пример кода?

[Хакер]

Есть сомнения на счёт пропатченных функций, не нужно ли их как-то восстанавливать?

Конечно нет. Ты не пытался заглянуть в способ работы этого кирпича?

Патчинг функции не порождает никакой ассоциации пропатчиваемой функции с какой бы то ни было DLL-библиотекой. Патчинг может быть выполнен до того, как какая бы то ни было DLL-библиотека подгружено в АП нашего процесса, и точно так же после того, как такая DLL-библиотека будет выгружена, пропатченная функция не становится некорректной или неактуальной.

Суть патчинга состоит в изменении поведения функции с «ничего не делать» на «взять первый аргумент и сделать jmp на него, оставив последующие аргументы на стеке». Патчинг не включает в себя, скажем, вшивание в код каких-либо адресов, специфичных для DLL, так, чтобы выгрузка DLL потребовала бы какой-то коррекции пропатченной функции.

Точно так же обстоят дела и в моём кирпиче «вызов функций по указателю». Можно выгрузить DLL, но не требуется перед этим (или даже после этого) делать никаких действий по «починке» указателей.

Естественно, и в моём кирпиче, и в этом кирпиче, попытка вызвать функцию используя старый адрес, после того, как библиотека, на которую ссылался этот адрес, была выгружена, приведёт к непредсказуемому поведению (скорее всего — к исключения и краху процесса).

И есть единственная проблема, о которой надо обеспокоиться (как в случае этого кирпича, так и в случае моего кирпича) перед выгрузкой DLL-библиотеки: не лежит её код «на стеке». Точнее, нет ли на стеке фреймов, принадлежащих процедуре из вызывемой DLL.

Скажем, если мы вызываем функции Foo из чужой библиотеки, а Foo делает вызов OurCallback, являющейся частью нашей программы, а мы из OutCallback вызывает FreeLibrary и выгружаем библиотеку — это выстрел себе в ногу. Потому что выполнение вернётся из FreeLibrary обратно к нам в OurCallback, а из OurCallback — в Foo, а в Foo к этому моменту уже не существует в памяти, её код был выгружен.

[Mikle]

Можно пример кода?

Вот:

Код: Выделить всё

Public AIData As tAIData
Public DllName As String

Dim hAI As Long
Dim AddrTick As Long
Dim AddrInit As Long

Public Sub AITick()
  Tick AddrTick, AIData
End Sub

Public Sub AIInit()
  hAI = LoadLibrary("AIDll\" & DllName)

  PatchFunc AddressOf Tick
  PatchFunc AddressOf Init

  AddrTick = GetProcAddress(hAI, "_Tick@4")
  AddrInit = GetProcAddress(hAI, "_Init@4")

  Init AddrInit, AIData
End Sub

' Прототип функций
Private Sub Tick(ByVal Addr As Long, ByRef AIData As tAIData)
End Sub

Private Sub Init(ByVal Addr As Long, ByRef AIData As tAIData)
End Sub


DllName может поменяться, нужно будет снова выполнить AIInit, в Dll могуть быть ещё функции.

Естественно, и в моём кирпиче, и в этом кирпиче, попытка вызвать функцию используя старый адрес, после того, как библиотека, на которую ссылался этот адрес, была выгружена, приведёт к непредсказуемому поведению (скорее всего — к исключения и краху процесса).

Так и я об этом. Я могу сменить адрес в переменной, но каким его сделать, чтобы функция стала безопасной? Если я выгружу dll, а потом случайно вызову AITick, она же выполнит jmp на мусорный адрес.

[Хакер]

Так и я об этом. Я могу сменить адрес в переменной, но каким его сделать, чтобы функция стала безопасной? Если я выгружу dll, а потом случайно вызову AITick, она же выполнит jmp на мусорный адрес.

А что считать безопасным? Указатели априори небезопасны, именно поэтому их и не сделали в VB, куда несли всё только то, что является безопасным.

Хорошая идея это установить переменную в 0. Это будет безопасным в том смысле, что выполнение не улетит неизвестно куда с неизвестно какими последствиями, а гарантированно вызовет крах. Ошибка будет легко обнаружена и исправлена.

Второй подход, который выглядит безопасным с пользовательской точки зрения, это установить указатель на функцию-пустышку. Ничего не рухнет, но появляется трудно отлавливаемый баг, потому что по факту некорректное поведение есть, а мгновенного проявления некорректного поведения — нет.

[The trick]

Mikle, патчить достаточно 1 раз.

Я могу сменить адрес в переменной, но каким его сделать, чтобы функция стала безопасной? Если я выгружу dll, а потом случайно вызову AITick, она же выполнит jmp на мусорный адрес.

Вот когда выгружаешь DLL то зануляй адреса, а в AITick проверяй, если адрес нулевой то не вызывай функцию.

[iGrok]

Второй подход, который выглядит безопасным с пользовательской точки зрения, это установить указатель на функцию-пустышку. Ничего не рухнет, но появляется трудно отлавливаемый баг, потому что по факту некорректное поведение есть, а мгновенного проявления некорректного поведения — нет.

Например, сделать не совсем пустышку, а логгирование: "опа, а нас тут вообще-то быть не должно".

[Хакер]

Например, сделать не совсем пустышку, а логгирование: "опа, а нас тут вообще-то быть не должно".

Звучит хорошо, но судя по названию Tick — это одна из тех функций, которая вызывает тысячи раз в секунду. Конечно можно не логгировать каждый вызов, а логгировать только первый вызов из серии, но тогда нужны критерии того, что является серией и механизм выделения серий. Например, считать началом серии вызовов первый вызов к пустышке, а концом серии — момент подгрузки новой DLL. Но это подход для одной DLL.

Лучше уж конечно не логгирование, а жесткое сообщение об ошибке, останавливающее всё приложение. А-ля «Pure virtual function call» в рантаймах С++.

[Mikle]

Я сделал защищенный вариант, критикуйте.
Ещё бы от случайного запуска без Start With Full Compile защитить.

[Хакер]

Ещё бы от случайного запуска без Start With Full Compile защитить.

Если использовать мой кирпич, то не придётся заморачиваться с «Start with full compile».

[The trick]

Ещё бы от случайного запуска без Start With Full Compile защитить.

Выведи кнопку на панель:

full_start.png (1.71 Кб) Просмотров: 5566

[Mikle]

Выведи кнопку на панель:

Я и имеющейся кнопкой не пользуюсь, привык к F5.

Если использовать мой кирпич, то не придётся заморачиваться с «Start with full compile».

Посмотрел... а ведь я им уже пользовался, да забыл с тех пор, а сейчас понадобилось - просто зашёл в "Кирпичи" и скачал из темы, которая выше в списке.