|
-
VB6 call-stack capture via dbghelp.dll (32-bit StackWalk + Unicode symbol APIs)
This module produces call-stacks with parameters peeked based on their types being surmised from the names w/ hungarian notation (heh) like this:
Code:
Project1.exe!Form1::pvProcess Line 38 Me=&H6FDD00->&H40543C, sText="Test", sTest2=&H1AFA74->"Proba", lOffset=&H2A, Cancel=&H1AFA70->&H0
Project1.exe!Form1::Command1_Click Line 29 Me=&H6FDD00->&H40543C
Project1.exe!Form1::Form_Load Line 34 Me=&H6FDD00->&H40543C
MSVBVM60.DLL!Zombie_QueryInterface + &H7E3
MSVBVM60.DLL!Zombie_QueryInterface + &H7C0
MSVBVM60.DLL!_vbaRedimPreserve + &H176B
MSVBVM60.DLL!_vbaVarCat + &H105E
MSVBVM60.DLL!EVENT_SINK_Release + &H10A5
MSVBVM60.DLL!EVENT_SINK_Release + &HF20
MSVBVM60.DLL!EVENT_SINK_Release + &HEB4
MSVBVM60.DLL!rtcVarType + &H317
MSVBVM60.DLL!EbLoadRunTime + &HA22
MSVBVM60.DLL!EbSetContextWorkerThread + &H6EE
MSVBVM60.DLL!EbLibraryLoad + &H4DC
MSVBVM60.DLL!ThunRTMain + &H155
MSVBVM60.DLL!ThunRTMain + &H5B
Project1.exe!__vbaS + &HA
ntdll.dll!RtlInitializeExceptionChain + &H6B
ntdll.dll!RtlGetAppContainerNamedObjectPath + &H231
Here is the Claude assisted helper module with all of the boring comments stripped:
Code:
'=== mdCallStack.bas =======================================================
' VB6 call-stack capture via dbghelp.dll (32-bit StackWalk + Unicode symbol APIs).
'
' Requires: Native code compile + "Create Symbolic Debug Info" (Project ->
' Properties -> Compile). The resulting .pdb must sit next to the
' .exe/.dll. Ship a known-good dbghelp.dll alongside the app.
'
' Output mimics the IDE call-stack view, one frame per line:
' Module.ext!Class::Method Line 123 (when source line is known)
' Module.dll!Export + &H1A (no PDB -> symbol + displacement)
'===========================================================================
Option Explicit
DefObj A-Z
Private Const MACHINE_I386 As Long = &H14C
Private Const ADDRMODE_FLAT As Long = 3
Private Const CONTEXT_FULL As Long = &H10007 '--- CONTROL|INTEGER|SEGMENTS
Private Const SYMOPT_LOAD_LINES As Long = &H10
Private Const SYMOPT_DEFERRED As Long = &H4
Private Const SYMOPT_UNDNAME As Long = &H2
Private Const MAX_NAME As Long = 511
Private Const MAX_PATH As Long = 260
Private Const MAX_STR_DUMP As Long = 1024
Private Const SYMFLAG_VALUEPRESENT As Long = &H1
Private Const SYMFLAG_REGREL As Long = &H10
Private Const SYMFLAG_FRAMEREL As Long = &H20
Private Const SYMFLAG_PARAMETER As Long = &H40
Private Const CV_REG_EBP As Long = 22
Private Const CV_ALLREG_VFRAME As Long = 30006
Private Type ADDRESS32
Offset As Long
Segment As Integer
Pad As Integer
Mode As Long
End Type
Private Type STACKFRAME
AddrPC As ADDRESS32
AddrReturn As ADDRESS32
AddrFrame As ADDRESS32
AddrStack As ADDRESS32
FuncTblEntry As Long
Params(0 To 3) As Long
fFar As Long
fVirtual As Long
Reserved(0 To 2) As Long
KdHelp(0 To 23) As Long
End Type
Private Type FLOATING_SAVE_AREA
ControlWord As Long
StatusWord As Long
TagWord As Long
ErrorOffset As Long
ErrorSelector As Long
DataOffset As Long
DataSelector As Long
RegisterArea(0 To 79) As Byte
Cr0NpxState As Long
End Type
Private Type CAPTURE_CONTEXT
ContextFlags As Long
Dr0 As Long
Dr1 As Long
Dr2 As Long
Dr3 As Long
Dr6 As Long
Dr7 As Long
FloatSave As FLOATING_SAVE_AREA
SegGs As Long
SegFs As Long
SegEs As Long
SegDs As Long
Edi As Long
Esi As Long
Ebx As Long
Edx As Long
Ecx As Long
Eax As Long
Ebp As Long
Eip As Long
SegCs As Long
EFlags As Long
Esp As Long
SegSs As Long
ExtendedRegisters(0 To 511) As Byte
End Type
Private Type IMAGEHLP_LINEW64
SizeOfStruct As Long '--- 0
Key As Long '--- 4 PVOID
LineNumber As Long '--- 8
FileName As Long '--- 12 PWSTR
AddressLo As Long '--- 16 ULONG64 Address
AddressHi As Long '--- 20
End Type
Private Type SYMBOL_INFOW
SizeOfStruct As Long '--- 0
TypeIndex As Long '--- 4
Reserved(0 To 3) As Long '--- 8 ULONG64 Reserved[2] (16 bytes)
Index As Long '--- 24
SymSize As Long '--- 28
ModBaseLo As Long '--- 32 ULONG64 ModBase
ModBaseHi As Long '--- 36
Flags As Long '--- 40
Pad44 As Long '--- 44 alignment pad before ULONG64 Value
ValueLo As Long '--- 48 ULONG64 Value
ValueHi As Long '--- 52
AddressLo As Long '--- 56 ULONG64 Address (frame/reg-relative offset)
AddressHi As Long '--- 60
Register As Long '--- 64
Scope As Long '--- 68
Tag As Long '--- 72
NameLen As Long '--- 76
MaxNameLen As Long '--- 80
NameBuf(0 To MAX_NAME) As Integer '--- 84 WCHAR Name[1] (variable length follows)
End Type
Private Type IMAGEHLP_STACK_FRAME
InstructionOffsetLo As Long '--- 0
InstructionOffsetHi As Long '--- 4
ReturnOffsetLo As Long '--- 8
ReturnOffsetHi As Long '--- 12
FrameOffsetLo As Long '--- 16
FrameOffsetHi As Long '--- 20
StackOffsetLo As Long '--- 24
StackOffsetHi As Long '--- 28
BackingStoreOffsetLo As Long '--- 32
BackingStoreOffsetHi As Long '--- 36
FuncTableEntryLo As Long '--- 40
FuncTableEntryHi As Long '--- 44
Params(0 To 7) As Long '--- 48 ULONG64 Params[4]
Reserved(0 To 9) As Long '--- 80 ULONG64 Reserved[5]
Virtual As Long '--- 120 BOOL
Reserved2 As Long '--- 124 ULONG
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, ByVal cb As Long)
Private Declare Sub RtlCaptureContext Lib "kernel32" (ctx As CAPTURE_CONTEXT)
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function GetCurrentThread Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameW" (ByVal hModule As Long, ByVal lpFilename As Long, ByVal nSize As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hMod As Long, ByVal lpProc As String) As Long
Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal cb As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, ByVal lpsz As Long) As Long
'--- dbghelp
Private Declare Function SymInitialize Lib "dbghelp" Alias "SymInitializeW" (ByVal hProc As Long, ByVal lpUserSearchPath As Long, ByVal fInvade As Long) As Long
Private Declare Function SymCleanup Lib "dbghelp" (ByVal hProc As Long) As Long
Private Declare Function SymSetOptions Lib "dbghelp" (ByVal opts As Long) As Long
Private Declare Function SymGetModuleBase Lib "dbghelp" (ByVal hProc As Long, ByVal dwAddr As Long) As Long
Private Declare Function StackWalk Lib "dbghelp" (ByVal MachineType As Long, ByVal hProc As Long, ByVal hThread As Long, sf As STACKFRAME, ctx As CAPTURE_CONTEXT, ByVal pfnRead As Long, ByVal pfnFTA As Long, ByVal pfnGMB As Long, ByVal pfnTranslate As Long) As Long
Private Declare Function SymFromAddr Lib "dbghelp" Alias "SymFromAddrW" (ByVal hProc As Long, ByVal AddressLo As Long, ByVal AddressHi As Long, Displacement As Currency, Symbol As Any) As Long
Private Declare Function SymGetLineFromAddr64 Lib "dbghelp" Alias "SymGetLineFromAddrW64" (ByVal hProc As Long, ByVal AddressLo As Long, ByVal AddressHi As Long, Displacement As Long, Line As IMAGEHLP_LINEW64) As Long
Private Declare Function SymSetContext Lib "dbghelp" (ByVal hProc As Long, pStackFrame As Any, ByVal ctx As Long) As Long
Private Declare Function SymEnumSymbols Lib "dbghelp" Alias "SymEnumSymbolsW" (ByVal hProc As Long, ByVal BaseOfDll As Currency, ByVal Mask As Long, ByVal pfnCallback As Long, ByVal UserContext As Long) As Long
Private Type EnumContext
FrameEbp As Long
Params As String
End Type
Public Function GetPdbCallstack() As String
Dim hProc As Long
Dim hThread As Long
Dim pfnFTA As Long
Dim pfnGMB As Long
Dim uCtx As CAPTURE_CONTEXT
Dim uFrame As STACKFRAME
Dim uScopeFrame As IMAGEHLP_STACK_FRAME
Dim uSym As SYMBOL_INFOW
Dim uLine As IMAGEHLP_LINEW64
Dim uEnumCtx As EnumContext
Dim cTemp As Currency
Dim lDisp As Long
Dim lLineDisp As Long
Dim sModule As String
Dim sName As String
Dim sFrame As String
Dim sOut As String
On Error GoTo EH
hProc = GetCurrentProcess()
hThread = GetCurrentThread()
Call SymSetOptions(SYMOPT_LOAD_LINES Or SYMOPT_DEFERRED Or SYMOPT_UNDNAME)
If SymInitialize(hProc, 0, 1) = 0 Then
GetPdbCallstack = "SymInitialize failed (&H" & Hex$(Err.LastDllError) & ")"
Exit Function
End If
pfnFTA = GetProcAddress(GetModuleHandle(StrPtr("dbghelp")), "SymFunctionTableAccess")
pfnGMB = GetProcAddress(GetModuleHandle(StrPtr("dbghelp")), "SymGetModuleBase")
uCtx.ContextFlags = CONTEXT_FULL
Call RtlCaptureContext(uCtx)
uFrame.AddrPC.Offset = uCtx.Eip
uFrame.AddrPC.Mode = ADDRMODE_FLAT
uFrame.AddrFrame.Offset = uCtx.Ebp
uFrame.AddrFrame.Mode = ADDRMODE_FLAT
uFrame.AddrStack.Offset = uCtx.Esp
uFrame.AddrStack.Mode = ADDRMODE_FLAT
Do While StackWalk(MACHINE_I386, hProc, hThread, uFrame, uCtx, 0, pfnFTA, pfnGMB, 0) <> 0
If uFrame.AddrPC.Offset = 0 Then
Exit Do
End If
sModule = pvModuleName(hProc, uFrame.AddrPC.Offset)
uSym.SizeOfStruct = LenB(uSym) - 2 * (MAX_NAME - 1)
uSym.MaxNameLen = MAX_NAME
If SymFromAddr(hProc, uFrame.AddrPC.Offset, 0, cTemp, uSym) <> 0 Then
sName = pvToString(VarPtr(uSym.NameBuf(0)))
Call CopyMemory(lDisp, cTemp, 4)
Else
sName = vbNullString
End If
If LenB(sModule) <> 0 Then
sFrame = sModule & "!"
Else
sFrame = vbNullString
End If
If LenB(sName) <> 0 Then
sFrame = sFrame & sName
Else
sFrame = sFrame & "&H" & Hex$(uFrame.AddrPC.Offset)
End If
uLine.SizeOfStruct = LenB(uLine)
If SymGetLineFromAddr64(hProc, uFrame.AddrPC.Offset, 0, lLineDisp, uLine) <> 0 Then
sFrame = sFrame & " Line " & uLine.LineNumber
ElseIf LenB(sName) <> 0 Then
sFrame = sFrame & " + &H" & Hex$(lDisp)
End If
uScopeFrame.InstructionOffsetLo = uFrame.AddrPC.Offset
uScopeFrame.FrameOffsetLo = uFrame.AddrFrame.Offset
uScopeFrame.StackOffsetLo = uFrame.AddrStack.Offset
Call SymSetContext(hProc, uScopeFrame, 0)
uEnumCtx.FrameEbp = uFrame.AddrFrame.Offset
uEnumCtx.Params = vbNullString
Call SymEnumSymbols(hProc, 0, 0, AddressOf pvEnumSymCallback, VarPtr(uEnumCtx))
If LenB(uEnumCtx.Params) <> 0 Then
sFrame = sFrame & " " & uEnumCtx.Params
Else
'sFrame = sFrame & " [&H" & Hex$(uFrame.Params(0)) & ", &H" & Hex$(uFrame.Params(1)) & _
", &H" & Hex$(uFrame.Params(2)) & ", &H" & Hex$(uFrame.Params(3)) & "]"
End If
sOut = IIf(LenB(sOut) <> 0, sOut & vbCrLf, vbNullString) & sFrame
Loop
QH:
If hProc <> 0 Then
Call SymCleanup(hProc)
End If
GetPdbCallstack = sOut
Exit Function
EH:
sOut = sOut & vbCrLf & "Critical error: " & Err.Description
Resume QH
End Function
Private Function pvEnumSymCallback(uSym As SYMBOL_INFOW, ByVal lSymbolSize As Long, uEnumCtx As EnumContext) As Long
Dim lReg As Long
Dim lOffset As Long
Dim lValAddr As Long
Dim lValue As Long
Dim sName As String
Dim sVal As String
On Error GoTo QH
pvEnumSymCallback = 1
If (uSym.Flags And SYMFLAG_PARAMETER) = 0 Then
If (uSym.Flags And (SYMFLAG_REGREL Or SYMFLAG_FRAMEREL)) = 0 Then
Exit Function
End If
If uSym.AddressLo <= 0 Then
Exit Function
End If
End If
sName = pvToString(VarPtr(uSym.NameBuf(0)))
If LenB(sName) = 0 Then
Exit Function
End If
If (uSym.Flags And SYMFLAG_VALUEPRESENT) <> 0 Then
sVal = "&H" & Hex$(uSym.ValueLo)
ElseIf (uSym.Flags And (SYMFLAG_REGREL Or SYMFLAG_FRAMEREL)) <> 0 Then
lReg = uSym.Register
lOffset = uSym.AddressLo
If lReg = CV_REG_EBP Or lReg = CV_ALLREG_VFRAME Or (uSym.Flags And SYMFLAG_FRAMEREL) <> 0 Then
lValAddr = uEnumCtx.FrameEbp + lOffset
If IsBadReadPtr(lValAddr, 4) = 0 Then
Call CopyMemory(lValue, ByVal lValAddr, 4)
If Left$(sName, 1) = "s" And Mid$(sName, 2, 1) = UCase$(Mid$(sName, 2, 1)) Then
sVal = pvDumpString(lValue)
Else
sVal = "&H" & Hex$(lValue)
If lValue <> 0 Then
If IsBadReadPtr(lValue, 4) = 0 Then
Call CopyMemory(lValue, ByVal lValue, 4)
sVal = sVal & "->&H" & Hex$(lValue)
End If
End If
End If
Else
sVal = "<unreadable>"
End If
ElseIf lOffset < 0 Then
sVal = "<" & pvRegName(lReg) & "-&H" & Hex$(-lOffset) & ">"
Else
sVal = "<" & pvRegName(lReg) & "+&H" & Hex$(lOffset) & ">"
End If
Else
sVal = "<?>"
End If
uEnumCtx.Params = IIf(LenB(uEnumCtx.Params) <> 0, uEnumCtx.Params & ", ", vbNullString) & sName & "=" & sVal
QH:
End Function
Private Function pvModuleName(ByVal hProc As Long, ByVal lAddr As Long) As String
Dim lBase As Long
Dim lLen As Long
Dim lPos As Long
Dim sPath As String
lBase = SymGetModuleBase(hProc, lAddr)
If lBase = 0 Then
Exit Function
End If
sPath = String$(MAX_PATH, 0)
lLen = GetModuleFileName(lBase, StrPtr(sPath), MAX_PATH)
If lLen = 0 Then
Exit Function
End If
sPath = Left$(sPath, lLen)
lPos = InStrRev(sPath, "\")
If lPos > 0 Then
sPath = Mid$(sPath, lPos + 1)
End If
pvModuleName = sPath
End Function
Private Function pvDumpString(ByVal lPtr As Long) As String
Dim sResult As String
If pvTryDumpString(lPtr, sResult) Then
pvDumpString = """" & Replace(sResult, """", """""") & """"
Exit Function
End If
pvDumpString = "&H" & Hex$(lPtr)
If lPtr <> 0 Then
If IsBadReadPtr(lPtr, 4) = 0 Then
Call CopyMemory(lPtr, ByVal lPtr, 4)
If pvTryDumpString(lPtr, sResult) Then
pvDumpString = pvDumpString & "->""" & Replace(sResult, """", """""") & """"
End If
End If
End If
End Function
Private Function pvTryDumpString(ByVal lPtr As Long, sResult As String) As Boolean
Dim lLen As Long
Dim nChar As Integer
If lPtr = 0 Then
sResult = vbNullString
pvTryDumpString = True
Exit Function
End If
If IsBadReadPtr(lPtr - 4, 4) <> 0 Then
Exit Function
End If
Call CopyMemory(lLen, ByVal lPtr - 4, 4)
If lLen < 0 Or lLen > 2 * MAX_STR_DUMP Or (lLen And 1) <> 0 Then
Exit Function
End If
If IsBadReadPtr(lPtr, lLen + 2) <> 0 Then
Exit Function
End If
Call CopyMemory(nChar, ByVal lPtr + lLen, 2)
If nChar <> 0 Then
Exit Function
End If
sResult = pvToString(lPtr)
'--- success
pvTryDumpString = True
End Function
Private Function pvToString(ByVal lPtr As Long) As String
Call SysReAllocString(VarPtr(pvToString), lPtr)
End Function
Private Function pvRegName(ByVal lReg As Long) As String
Static vNames As Variant
If lReg = CV_ALLREG_VFRAME Then
pvRegName = "VFRAME"
ElseIf lReg >= 1 And lReg <= 30 Then
If Not IsArray(vNames) Then
vNames = Split("AL CL DL BL AH CH DH BH AX CX DX BX SP BP SI DI EAX ECX EDX EBX ESP EBP ESI EDI ES CS SS DS FS GS")
End If
pvRegName = vNames(lReg - 1)
Else
pvRegName = "reg" & lReg
End If
End Function
cheers,
</wqw>
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote