Created
November 12, 2012 06:49
-
-
Save iso2022jp/4057861 to your computer and use it in GitHub Desktop.
VBA: Cdecl Thunk
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
VERSION 1.0 CLASS | |
BEGIN | |
MultiUse = -1 'True | |
Persistable = 0 'NotPersistable | |
DataBindingBehavior = 0 'vbNone | |
DataSourceBehavior = 0 'vbNone | |
MTSTransactionMode = 0 'NotAnMTSObject | |
END | |
Attribute VB_Name = "CdeclCallback" | |
Attribute VB_GlobalNameSpace = False | |
Attribute VB_Creatable = True | |
Attribute VB_PredeclaredId = False | |
Attribute VB_Exposed = False | |
Option Explicit | |
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ | |
ByVal Destination As Long, _ | |
Source As Any, _ | |
ByVal Length As Long) | |
Private Declare Function FlushInstructionCache Lib "kernel32" ( _ | |
ByVal hProcess As Long, _ | |
ByVal lpBaseAddress As Long, _ | |
ByVal dwSize As Long) _ | |
As BOOL | |
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long | |
Private Declare Function VirtualAlloc Lib "kernel32" ( _ | |
ByVal lpAddress As Long, _ | |
ByVal dwSize As Long, _ | |
ByVal flAllocationType As Long, _ | |
ByVal flProtect As Long) _ | |
As Long | |
Private Declare Function VirtualFree Lib "kernel32" ( _ | |
ByVal lpAddress As Long, _ | |
ByVal dwSize As Long, _ | |
ByVal dwFreeType As Long) _ | |
As BOOL | |
' PAGE_EXECUTE | |
' PAGE_WRITE | |
Private Const PAGE_EXECUTE_READWRITE As Long = &H40& | |
Private Const MEM_COMMIT As Long = &H1000& | |
Private Const MEM_RELEASE As Long = &H8000& | |
Private Const CODE_SIZE As Long = 256 | |
Private mBase As Long ' base address | |
Private mFreed As Long ' next freed | |
Public Sub Initialize(ByVal Count As Long) | |
mBase = Platform.Invoke(VirtualAlloc(SYSNULL, Count * CODE_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) | |
mFreed = mBase | |
End Sub | |
Public Function Register(ByVal StdcallProc As Long, ByVal DWORDArgumentCount As Long) As Long | |
Dim i As Long | |
Dim p As Long | |
Dim lEspDisp8 As Long ' 8 bit displacement (max 127: 32 DWORDs) | |
' ret, arg1, arg2, arg3... | |
If DWORDArgumentCount > 32 Then Call Err.Raise(5) | |
' emit x86 code (consider pairing) | |
' mov edx, StdcallProc ; (u) | |
' | |
' mov e?x, [esp+X] ; (v) x N | |
' push e?x ; (u) x N | |
' | |
' call edx ; (v) | |
' ret ; (u) | |
p = mFreed | |
' retaddr, argN, argN-1, argN-2, ..., , arg1 | |
lEspDisp8 = 4 * DWORDArgumentCount | |
Call MoveMemory(p, &HBA, 1) ' mov edx, immediate | |
Call MoveMemory(p + 1, StdcallProc, 4) ' addr | |
p = p + 5 | |
' eax/ecx | |
For i = 1 To DWORDArgumentCount | |
If i Mod 2 Then | |
' eax | |
Call MoveMemory(p, &H8B, 1) ' mov r32, r/m32 | |
Call MoveMemory(p + 1, &H44, 1) ' ModR/M: 01 (disp8[r]), 000 (eax), 100 (SIB) | |
Call MoveMemory(p + 2, &H24, 1) ' SIB: 00 (*1), 100 (none), 100 (esp) | |
Call MoveMemory(p + 3, lEspDisp8, 1) ' disp8 | |
Call MoveMemory(p + 4, &H50, 1) ' push eax | |
Else | |
' ecx | |
Call MoveMemory(p, &H8B, 1) ' mov r32, r/m32 | |
Call MoveMemory(p + 1, &H4C, 1) ' ModR/M: 01 (disp8[r]), 001 (ecx), 100 (SIB) | |
Call MoveMemory(p + 2, &H24, 1) ' SIB: 00 (*1), 100 (none), 100 (esp) | |
Call MoveMemory(p + 3, lEspDisp8, 1) ' disp8 | |
Call MoveMemory(p + 4, &H51, 1) ' push ecx | |
End If | |
p = p + 5 | |
Next | |
Call MoveMemory(p, &HFF, 1) ' opcode extension group 5 | |
Call MoveMemory(p + 1, &HD2, 1) ' ModR/M: 11, 010 (call near), 010 (edx) | |
p = p + 2 | |
Call MoveMemory(p, &HC3, 1) ' ret (near) | |
p = p + 1 | |
' commit | |
Call Platform.Invoke(FlushInstructionCache(GetCurrentProcess(), mFreed, p - mFreed)) | |
Register = mFreed | |
mFreed = mFreed + CODE_SIZE | |
End Function | |
' | |
'Public Property Get Handle() As Long | |
' Handle = mBase | |
'End Property | |
Private Sub Class_Terminate() | |
If mBase Then | |
Call VirtualFree(mBase, 0, MEM_RELEASE) | |
End If | |
End Sub |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
VERSION 1.0 CLASS | |
BEGIN | |
MultiUse = -1 'True | |
Persistable = 0 'NotPersistable | |
DataBindingBehavior = 0 'vbNone | |
DataSourceBehavior = 0 'vbNone | |
MTSTransactionMode = 0 'NotAnMTSObject | |
END | |
Attribute VB_Name = "CdeclInvoker" | |
Attribute VB_GlobalNameSpace = False | |
Attribute VB_Creatable = True | |
Attribute VB_PredeclaredId = False | |
Attribute VB_Exposed = False | |
Option Explicit | |
Private Declare Function LoadLibraryA Lib "kernel32" ( _ | |
ByVal lpFileName As String) _ | |
As Long | |
Private Declare Function LoadLibraryW Lib "kernel32" ( _ | |
ByVal lpFileName As Long) _ | |
As Long | |
Private Declare Function FreeLibrary Lib "kernel32" ( _ | |
ByVal hModule As Long) _ | |
As BOOL | |
Private Declare Function GetProcAddress Lib "kernel32" ( _ | |
ByVal hModule As Long, _ | |
ByVal lpProcName As String) _ | |
As Long | |
' EnumerateLoadedModules | |
' EnumThreadWindows | |
' EnumResourceTypes | |
Private Declare Function Invoker12 Lib "kernel32" Alias "EnumResourceTypesA" ( _ | |
ByVal Reserved As Long, _ | |
ByVal lpCallback As Long, _ | |
lParam As Any) _ | |
As Long | |
'Private Declare Function Invoker8 Lib "user32" Alias "EnumWindows" ( _ | |
' ByVal lpCallback As Long, _ | |
' lParam As Any) _ | |
'As Long | |
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ | |
ByVal Destination As Long, _ | |
Source As Any, _ | |
ByVal Length As Long) | |
Private Declare Function FlushInstructionCache Lib "kernel32" ( _ | |
ByVal hProcess As Long, _ | |
ByVal lpBaseAddress As Long, _ | |
ByVal dwSize As Long) _ | |
As BOOL | |
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long | |
Private Declare Function VirtualAlloc Lib "kernel32" ( _ | |
ByVal lpAddress As Long, _ | |
ByVal dwSize As Long, _ | |
ByVal flAllocationType As Long, _ | |
ByVal flProtect As Long) _ | |
As Long | |
Private Declare Function VirtualFree Lib "kernel32" ( _ | |
ByVal lpAddress As Long, _ | |
ByVal dwSize As Long, _ | |
ByVal dwFreeType As Long) _ | |
As BOOL | |
' PAGE_EXECUTE | |
' PAGE_WRITE | |
Private Const PAGE_EXECUTE_READWRITE As Long = &H40& | |
Private Const MEM_COMMIT As Long = &H1000& | |
Private Const MEM_RELEASE As Long = &H8000& | |
Private Const CODE_SIZE As Long = 256 | |
Private mModule As Long | |
Private mBase As Long ' base address | |
Private mProcCache As Collection | |
Public Sub Initialize(ByRef Library As String) | |
Dim i As Long | |
If Platform.IsNT Then | |
mModule = Platform.Invoke(LoadLibraryW(StrPtr(Library))) | |
Else | |
mModule = Platform.Invoke(LoadLibraryA(Library)) | |
End If | |
mBase = Platform.Invoke(VirtualAlloc(SYSNULL, 31 * CODE_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) | |
For i = 0 To 30 | |
Call GenDriver(mBase + i * CODE_SIZE, i) | |
Next | |
End Sub | |
Public Function Invoke(ByRef CdeclProcName As String, ParamArray DWORDArguments() As Variant) As Long | |
Dim lArgs() As Long ' retval, addr, arg1, arg2, ... | |
Dim lCount As Long | |
Dim i As Long | |
Dim lProcAddr As Long | |
' resolve address | |
On Error Resume Next | |
lProcAddr = mProcCache(CdeclProcName) | |
If Err.Number Then | |
On Error GoTo 0 | |
lProcAddr = Platform.Invoke(GetProcAddress(mModule, CdeclProcName)) | |
Call mProcCache.Add(lProcAddr, CdeclProcName) | |
End If | |
On Error GoTo 0 | |
' assume LBound(DWORDArguments) = 0 | |
lCount = UBound(DWORDArguments) + 1 | |
If lCount > 30 Then Call Err.Raise(5) | |
ReDim lArgs(0 To lCount + 2) | |
lArgs(0) = 0 | |
lArgs(1) = lProcAddr | |
For i = 0 To lCount - 1 | |
lArgs(i + 2) = CLng(DWORDArguments(i)) | |
Next | |
' invoke | |
Call Invoker12(SYSNULL, mBase + lCount * CODE_SIZE, lArgs(0)) | |
Invoke = lArgs(0) | |
End Function | |
Private Sub GenDriver(ByVal Base As Long, ByVal DWORDArgumentCount As Long) | |
Dim p As Long | |
Dim i As Long | |
' make ENUMRESTYPEPROC style driver | |
' struct DRIVER_PARAM { | |
' long retval; | |
' FN func; | |
' long argv[...]; | |
' }; | |
' BOOL __stdcall driver(HWND unused, LPTSTR unused2, DRIVER_PARAM *param) { | |
' param->retval = param->func(param->argv[0], ...); | |
' return FALSE; | |
' } | |
If DWORDArgumentCount > 30 Then Call Err.Raise(5) | |
' emit x86 code (consider pairing) | |
' push esi ; (u) | |
' mov esi, [esp+16] ; (v) esi = param | |
' mov edx, [esi+4] ; (u) edx = param->func | |
' | |
' mov e?x, [esi+X] ; (v) x N | |
' push e?x ; (u) x N | |
' | |
' call edx ; (v) | |
' add esp, X ; (u) remove arguments from stack | |
' mov [esi], eax ; (v) param->retval = eax | |
' xor eax, eax ; (u) return 0 | |
' pop esi ; (v) | |
' ret 12 ; (u) | |
p = Base | |
Call MoveMemory(p, &H56, 1) ' push esi | |
p = p + 1 | |
Call MoveMemory(p, &H8B, 1) ' mov r32, r/m32 | |
Call MoveMemory(p + 1, &H74, 1) ' ModR/M: 01 (disp8[r]), 110 (esi), 100 (SIB) | |
Call MoveMemory(p + 2, &H24, 1) ' SIB: 00 (*1), 100 (none), 100 (esp) | |
Call MoveMemory(p + 3, 16, 1) ' disp8: 16 (3rd argument) | |
p = p + 4 | |
Call MoveMemory(p, &H8B, 1) ' mov r32, r/m32 | |
Call MoveMemory(p + 1, &H56, 1) ' ModR/M: 01 (disp8[r]), 010 (edx), 110 (esi) | |
Call MoveMemory(p + 2, 4, 1) ' disp8: 4 | |
p = p + 3 | |
' esi+8,12,16... | |
For i = DWORDArgumentCount - 1 To 0 Step -1 | |
If i Mod 2 Then | |
' eax | |
Call MoveMemory(p, &H8B, 1) ' mov r32, r/m32 | |
Call MoveMemory(p + 1, &H46, 1) ' ModR/M: 01 (disp8[r]), 000 (eax), 110 (esi) | |
Call MoveMemory(p + 2, i * 4 + 8, 1) ' disp8 | |
Call MoveMemory(p + 3, &H50, 1) ' push eax | |
Else | |
' ecx | |
Call MoveMemory(p, &H8B, 1) ' mov r32, r/m32 | |
Call MoveMemory(p + 1, &H4E, 1) ' ModR/M: 01 (disp8[r]), 001 (ecx), 110 (esi) | |
Call MoveMemory(p + 2, i * 4 + 8, 1) ' disp8 | |
Call MoveMemory(p + 3, &H51, 1) ' push ecx | |
End If | |
p = p + 4 | |
Next | |
Call MoveMemory(p, &HFF, 1) ' opcode extension group 5 | |
Call MoveMemory(p + 1, &HD2, 1) ' ModR/M: 11, 010 (call near), 010 (edx) | |
p = p + 2 | |
Call MoveMemory(p, &H83, 1) ' opcode extension group 1 (r/m32, imm8) | |
Call MoveMemory(p + 1, &HC4, 1) ' ModR/M: 11, 000 (add), 100 (esp) | |
Call MoveMemory(p + 2, DWORDArgumentCount * 4, 1) ' imm8 | |
p = p + 3 | |
' param->retval = eax | |
Call MoveMemory(p, &H89, 1) ' mov r/m32, r32 | |
Call MoveMemory(p + 1, &H6, 1) ' ModR/M: 00 ([r]), 000 (eax), 110 (esi) | |
p = p + 2 | |
' return 0 | |
Call MoveMemory(p, &H33, 1) ' xor r32, r/m32 | |
Call MoveMemory(p + 1, &HC0, 1) ' ModR/M: 11 (r), 000 (eax), 000 (eax) | |
p = p + 2 | |
Call MoveMemory(p, &H5E, 1) ' pop esi | |
p = p + 1 | |
Call MoveMemory(p, &HC2, 1) ' ret imm16 (near) | |
Call MoveMemory(p + 1, 12, 2) ' imm16 | |
p = p + 3 | |
' commit | |
Call Platform.Invoke(FlushInstructionCache(GetCurrentProcess(), Base, p - Base)) | |
End Sub | |
Private Sub Class_Initialize() | |
Set mProcCache = New Collection | |
End Sub | |
Private Sub Class_Terminate() | |
If mBase Then | |
Call VirtualFree(mBase, 0, MEM_RELEASE) | |
End If | |
If mModule Then | |
Call FreeLibrary(mModule) | |
End If | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
@Greedquest
Thank you for your comment.
Young me want to call Cabinet API from Visual Basic 5 for file compression.
(Now xz/7z are available, but in that time Microsoft CAB was the most efficient compression format.)
https://docs.microsoft.com/en-us/windows/win32/devnotes/cabinet-api-functions
Unfortunately, Cabinet APIs are not STDCALL calling convension, so I cannot use declare statement.
and what is worse, my manager do not accept additional dependencies ― includes native dll, C thunks, and type libraries.
I've got to go with the last resort. I implemented cdecl calling convention thunks in PURE VISUAL BASIC!
Platform
class is just helper, no magics in there.Platform.Invoke
converts from win32 error code via GetLastError() to HRESULT and throw COM Exception withErr.Raise
.