| Event ID | Explanation |
| EXCEPTION_DEBUG_EVENT | An exception of some sort occurred. Convert the DEBUG_EVENT.dwUnionData into an EXCEPTION_DEBUG_INFO to find out the type of exception and where it occurred. |
| CREATE_THREAD_DEBUG_EVENT | The debuggee created a thread. Convert the DEBUG_EVENT.dwUnionData into a CREATE_THREAD_DEBUG_INFO to get the thread handle and start address. |
| CREATE_PROCESS_DEBUG_EVENT | The debuggee was created. Convert the DEBUG_EVENT.dwUnionData into a CREATE_ PROCESS_DEBUG_INFO to get the information about the debuggee. The process handle is something you will need to save off so that you can read OutputDebugStrings. |
| EXIT_THREAD_DEBUG_EVENT | The debuggee had a thread terminate. Convert the DEBUG_EVENT.dwUnionData to an EXIT_THREAD_DEBUG_INFO. This is only for threads created after the main thread. The main thread is terminated with EXIT_PROCESS_DEBUG_EVENT. |
| EXIT_PROCESS_DEBUG_EVENT | The debuggee process exited. Convert the DEBUG_EVENT.dwUnionData to an EXIT_ PROCESS_DEBUG_INFO. |
| LOAD_DLL_DEBUG_EVENT | The debuggee loaded a DLL. Convert the DEBUG_EVENT.dwUnionData to a LOAD_DLL_ DEBUG_INFO. Unfortunately, the debug API does not report the name of the DLL; you must pound through the image to find it. The LOAD_DLL_DEBUG_INFO.lpImageName is always empty. |
| UNLOAD_DLL_DEBUG_EVENT | The debuggee unloaded a DLL. Convert the DEBUG_EVENT.dwUnionData to an UNLOAD_DLL_DEBUG_INFO. |
| OUTPUT_DEBUG_STRING_EVENT | The debuggee made a call to OutputDebugString. The debugger will need to read the string out of the debuggee's address space with ReadProcessMemory using the process handle saved from the CREATE_PROCESS_DEBUG_EVENT notification. |
| RIP_EVENT | The debuggee has a RIP-debugging event (system debugging error). Convert DEBUG_ EVENT.dwUnionData to a RIP_INFO. |
Figure 2 VBDebug
frmVBDebug.frm
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmVBDebug
Caption = "VBDebug"
ClientHeight = 4935
ClientLeft = 165
ClientTop = 735
ClientWidth = 5985
Icon = "frmVBDebug.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4935
ScaleWidth = 5985
StartUpPosition = 3 'Windows Default
Begin MSComDlg.CommonDialog dlgFileOpen
Left = 3120
Top = 840
_ExtentX = 847
_ExtentY = 847
_Version = 327680
CancelError = -1 'True
DefaultExt = ".exe"
Filter = "Executables (*.exe) | *.exe"
End
Begin VB.TextBox txtOutput
Height = 2055
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 0
Top = 360
Width = 2055
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuFileOpen
Caption = "&Open"
Shortcut = ^O
End
Begin VB.Menu mnuFileExit
Caption = "&Exit"
Shortcut = ^Q
End
End
Begin VB.Menu mnuDebug
Caption = "&Debug"
Begin VB.Menu mnuDebugStart
Caption = "&Start"
Enabled = 0 'False
Shortcut = {F5}
End
Begin VB.Menu mnuDebugPause
Caption = "&Pause"
Enabled = 0 'False
End
Begin VB.Menu mnuDebugEnd
Caption = "&End"
Enabled = 0 'False
End
Begin VB.Menu mnuDebugRestart
Caption = "&Restart"
Enabled = 0 'False
Shortcut = +{F5}
End
Begin VB.Menu mnuSep1
Caption = "-"
End
Begin VB.Menu mnuDebugShowActiveThreads
Caption = "S&how Active Threads"
Enabled = 0 'False
End
Begin VB.Menu mnuDebugShowActiveDLLs
Caption = "Sh&ow Active DLLs"
Enabled = 0 'False
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu mnuHelpAbout
Caption = "&About VBDebug"
End
End
End
Attribute VB_Name = "frmVBDebug"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins
' Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : frmVBDebug.frm
' DISCUSSION :
' The main UI form for the whole VBDebug project.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Enumeration types that indicate the state of the UI widgits.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Enum eUIState
' The UI is uninitialized. The only time in this state is when I
' first start and before I have loaded an executable.
eUIUninitialized = 0
' The user has opened a file but has not started debugging or the
' current debuggee has finished and is ready to run again.
eUILoaded = 1
' There is an application running under the debug loop.
eUIDebugging = 2
' The debuggee is running but it is paused.
eUIDebuggingPaused = 3
End Enum
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Form private variables.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The full name of the executable that I have open for debugging.
Private g_szFullDebuggeeName As String
' The name portion of the debuggee. This is what I use for setting the
' application title.
Private g_szJustDebuggeeName As String
' The debugger class that is passed to the debug thread.
Private g_clsDebug As DebuggerClass
' The executive class for the debugger.
Private g_clsExecutive As SimpleExecutive
' The synchronization class.
Private g_clsSynch As DebugSynchClass
' The handle to the debug thread.
Private g_hDebugThread As Long
' The handle to the thread that waits for the debug thread to end.
Private g_hWaitThread As Long
' The structure that I pass to the wait thread.
Private g_stWaitType As SPECIALWAIT_TYPE
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Form Event Handling
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form_Load()
' Force the output text box to cover the client area.
Form_Resize
End Sub
Private Sub Form_Resize()
' Resize the output text box to fill the entire client area.
txtOutput.Top = 0
txtOutput.Left = 0
txtOutput.Height = ScaleHeight
txtOutput.Width = ScaleWidth
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Tell the debugger thread to die if it is active.
If (Not (g_clsDebug Is Nothing)) Then
g_clsSynch.QuitDebugThread
' Hang out until the wait thread is done to ensure complete and
' proper cleanup.
Dim bRes As Long
bRes = WaitForSingleObject(g_hWaitThread, INFINITE)
End If
' Clear up any outstanding references.
Set g_clsDebug = Nothing
Set g_clsExecutive = Nothing
Set g_clsSynch = Nothing
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' File Menu Handling
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mnuFileOpen_Click()
' Bring up the file open dialog and get the user's choice.
On Error GoTo mnuFileOpen_Click_Error
dlgFileOpen.ShowOpen
' Get the full name of the executable.
g_szFullDebuggeeName = dlgFileOpen.filename
' Get just the partial name.
g_szJustDebuggeeName = dlgFileOpen.FileTitle
' Set the UI state to not running.
SetUIState (eUILoaded)
' Put the text in the output so the user can see what is going on.
' I am allowed to touch the output edit control here because no
' debugger thread is running so there are no synchronization
' problems
txtOutput.Text = "UI: " + g_szFullDebuggeeName + _
" opened and ready to run." + vbNewLine
Exit Sub
mnuFileOpen_Click_Error:
' If the error was anything other than cancel, throw it on.
If (cdlCancel <> Err.Number) Then
Err.Raise (Err.Number)
End If
End Sub
Private Sub mnuFileExit_Click()
' If there is an active executive class, then I must use the
' AppendText method to access the output edit control.
If (Not g_clsExecutive Is Nothing) Then
g_clsExecutive.AppendText "UI: File Exit selected"
Else
txtOutput.Text = txtOutput.Text + vbNewLine + _
"UI: File Exit selected" + vbNewLine
End If
' Call this to get the Form_QueryUnload function called.
Unload Me
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Debug Menu Handling
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mnuDebugStart_Click()
On Error GoTo mnuDebugStart_Click_Error
Dim bRet As Long
Dim boolDidStart As Boolean
' To keep everything straight, I do a complete new debugger,
' synchronization, and executive classes on each start.
' Clear out any existing debugger, executive, and synch classes.
Set g_clsDebug = Nothing
Set g_clsExecutive = Nothing
Set g_clsSynch = Nothing
' Clear the text box and indicate that the UI menu was picked.
txtOutput.Text = ""
txtOutput.Text = "UI: Debug Start selected" + vbNewLine
' Instantiate the debugger class.
Set g_clsDebug = New DebuggerClass
' Instantiate the executive.
Set g_clsExecutive = New SimpleExecutive
' Instantiate the synchronization class.
Set g_clsSynch = New DebugSynchClass
' Initialize the executive class text output. After this, the UI
' thread is no longer allowed to touch the text box.
Let g_clsExecutive.txtOutput = txtOutput
' Initialize the debugger class with the program name.
g_clsDebug.SetDebuggeeInfo (g_szFullDebuggeeName)
' Initialize the debugger class with the executive that does all
' the work.
Set g_clsDebug.clsBaseExecutive = g_clsExecutive
' Now that I have all of the required classes set up, I can start
' the debug thread.
SetUIState (eUIDebugging)
' I have to do the synch in two stages: create it before, then
' check it after. If you don't do this, then you can run into cases
' where the debug thread cranks, sets the event and dies before this
' thread can get it created. Granted those cases only happen on
' those super fast Alphas (400Mhz is REALLY great!) but they do
' happen.
g_clsSynch.PrepareWaitForStartup
' Crank the debug thread passing it debugger class.
g_hDebugThread = StartDebugThread(g_clsDebug)
' Wait until the debug thread at least gets through the
' CreateProcess on the debuggee and see how it did.
boolDidStart = g_clsSynch.WaitForStartup
' If WaitForStartup returned False, then the debuggee was not
' started.
If (False = boolDidStart) Then
' There was a problem starting up so clean up.
Set g_clsDebug = Nothing
Set g_clsExecutive = Nothing
Set g_clsSynch = Nothing
' Let the user know.
MsgBox ("Unable to start " + g_szFullDebuggeeName)
txtOutput.Text = "UI: Unable to start " + g_szFullDebuggeeName
' Make sure to set the UI state back.
SetUIState (eUILoaded)
Exit Sub
End If
' Get the debuggee process ID into the synch class.
g_clsSynch.dwUniqueID = g_clsDebug.dwDebuggeePID
' Create the synchronization objects for THIS thread.
g_clsSynch.CreateSynchObjects
' Create the thread that waits on the debug thread to end.
Set g_stWaitType.frmDTE = Me
g_stWaitType.hThread = g_hDebugThread
' Crank up the wait thread that will watch for the debug thread to
' end.
g_hWaitThread = StartWaitThread(g_stWaitType)
g_clsExecutive.AppendText "UI: Debuggee started"
Exit Sub
mnuDebugStart_Click_Error:
MsgBox ("Error in mnuDebugStart_Click: " + Err.Description)
End Sub
Private Sub mnuDebugEnd_Click()
g_clsExecutive.AppendText "UI: Debug End selected"
' Tell the debugger thread to die.
g_clsSynch.QuitDebugThread
' NOTE: I don't set the UI state here. I need to make sure the
' debug thread is really done before I set it. It is set in the
' btnPostMsgButton_MouseDown handler.
End Sub
Private Sub mnuDebugPause_Click()
g_clsExecutive.AppendText "UI: Debug Pause selected"
' Tell the debugger thread to pause.
g_clsSynch.PauseDebugThread
SetUIState (eUIDebuggingPaused)
End Sub
Private Sub mnuDebugRestart_Click()
g_clsExecutive.AppendText "UI: Debug Restart selected"
' Tell the debugger thread to resume.
g_clsSynch.ResumeDebugThread
SetUIState (eUIDebugging)
End Sub
Private Sub mnuDebugShowActiveThreads_Click()
g_clsExecutive.DumpActiveThreads
End Sub
Private Sub mnuDebugShowActiveDlls_Click()
g_clsExecutive.DumpLoadedDLLs
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Help Menu Handling
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mnuHelpAbout_Click()
If (Not g_clsExecutive Is Nothing) Then
g_clsExecutive.AppendText "UI: Help About selected"
Else
txtOutput.Text = txtOutput.Text + vbNewLine + _
"UI: Help About selected" + vbNewLine
End If
frmAbout.Show vbModal, Me
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The special function that is called from the thread that waits for the
' debug thread to end. This is how I get the UI resynched to know what
' the current state is.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugThreadEnded()
SetUIState (eUILoaded)
Dim bRet As Long
' This is very ugly. This function is called in another thread's
' context and it seems that while the caption is set correctly, it
' does not get updated correctly. To force the update, I simply make
' a direct call to SetWindowText to get everything updated.
bRet = SetWindowText(Me.hWnd, Me.Caption)
g_clsExecutive.AppendText "UI: DebugThreadEnded called!"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Form specific helper functions
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : SetUIState
' DISCUSSION :
' A helper function to set the state of all UI widgits.
' PARAMETERS :
' eUIToSet - The enum to set the user interface to.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub SetUIState(eUIToSet As eUIState)
Select Case (eUIToSet)
' I have an executable open, but I am not debugging yet.
Case eUILoaded
' If the user wants to open another file, they can.
mnuFileOpen.Enabled = True
' Debugging can start.
mnuDebugStart.Enabled = True
' Since I am not debugging, I cannot end, pause or restart
' debugging.
mnuDebugEnd.Enabled = False
mnuDebugPause.Enabled = False
mnuDebugRestart.Enabled = False
' Set the info commands off.
mnuDebugShowActiveThreads.Enabled = False
mnuDebugShowActiveDLLs.Enabled = False
' Set the title.
Me.Caption = k_APPNAME + " - " + _
g_szJustDebuggeeName + _
k_NOTRUNNINGSTATE
' I am debugging!
Case eUIDebugging
' Nope, cannot open files.
mnuFileOpen.Enabled = False
' Cannot start debugging again.
mnuDebugStart.Enabled = False
' I am debugging so I can end and pause but not restart.
mnuDebugEnd.Enabled = True
mnuDebugPause.Enabled = True
mnuDebugRestart.Enabled = False
' Turn the info commands on.
mnuDebugShowActiveThreads.Enabled = True
mnuDebugShowActiveDLLs.Enabled = True
' Set the title.
Me.Caption = k_APPNAME + " - " + _
g_szJustDebuggeeName + _
k_DEBUGGINGSTATE
' The debuggee is paused.
Case eUIDebuggingPaused
' Since this state is only allowed from eUIDebugging, all
' that is done here is to set restart to true and pause
' to false.
mnuDebugPause.Enabled = False
mnuDebugRestart.Enabled = True
Me.Caption = k_APPNAME + " - " + _
g_szJustDebuggeeName + _
k_PAUSEDSTATE
' The uninitialized state.
Case eUIUninitialized
mnuFileOpen.Enabled = True
mnuDebugStart.Enabled = False
mnuDebugEnd.Enabled = False
mnuDebugPause.Enabled = False
mnuDebugRestart.Enabled = False
mnuDebugShowActiveThreads.Enabled = False
mnuDebugShowActiveDLLs.Enabled = False
Me.Caption = k_APPNAME
End Select
End Sub
SimpleExecutive.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "SimpleExecutive"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins
' Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : SimpleExecutive.cls
' DESCRIPTION :
' Implements a simple debugger executive that conforms to the
' BaseExecutive abstract base class. If you want to extend VBDebug to
' handle more advanced things, derive your own class from
' BaseExecutive.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Polymorphic Bliss
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements BaseExecutive
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Class Specific Private Variables
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The handle to the main thread.
Private g_hMainThread As Long
' The handle to the process.
Private g_hProcess As Long
' Has the initial breakpoint already been seen?
Private g_bSeenFirstBP As Boolean
' The synchronization object that keeps us from having trouble in this
' class.
Private g_clsCritSec As CriticalSection
' The text box where all output is placed.
Private g_txtOutput As TextBox
' The internal list of threads.
Private g_colThreads As Collection
' The internal list of DLLs.
Private g_colDlls As Collection
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Property Setting Functions
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Friend Property Let txtOutput(txtBox As TextBox)
Set g_txtOutput = txtBox
End Property
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : Class_Initialize
' DISCUSSION :
' The initialization for the class.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
Set g_clsCritSec = New CriticalSection
Set g_colThreads = New Collection
Set g_colDlls = New Collection
g_bSeenFirstBP = False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : Class_Terminate
' DISCUSSION :
' The termination for the class.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Terminate()
Set g_clsCritSec = Nothing
Set g_colThreads = Nothing
Set g_colDlls = Nothing
End Sub
Private Sub BaseExecutive_DebugCreateProcess _
(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugCreateProcess_Error
g_hMainThread = clsDebugger.CreateProcessDbgEvt.hThread
g_hProcess = clsDebugger.CreateProcessDbgEvt.hProcess
#If DEBUGBUILD Then
OutputDebugString ("Created Process ID: " + _
Hex$(dwProcessID) + _
" Thread Handle : " + _
Hex$(g_hProcess) + _
" With Thread " + _
Hex$(g_hMainThread) + _
vbNewLine)
#End If
AppendText "Process &H" + Hex$(g_hProcess) + " created"
AppendText "Thread &H" + Hex$(g_hMainThread) + " created"
' Add the main thread to the collection.
g_colThreads.Add CStr(g_hMainThread), CStr(dwThreadID)
#If DEBUGBUILD Then
OutputDebugString ("Adding thread &H" + _
Hex$(g_hMainThread) + _
" to thread collection" + _
vbNewLine)
OutputDebugString ("Total of " + _
CStr(g_colThreads.Count) + _
" in the collection" + vbNewLine)
#End If
g_clsCritSec.Leave
Exit Sub
DebugCreateProcess_Error:
#If DEBUGBUILD Then
MsgBox ("DebugCreateProcess Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugCreateThread _
(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugCreateThread_Error
Dim stCTDI As CREATE_THREAD_DEBUG_INFO
stCTDI = clsDebugger.CreateThreadDbgEvt
g_colThreads.Add CStr(stCTDI.hThread), CStr(dwThreadID)
AppendText "Thread &H" + Hex$(stCTDI.hThread) + " created"
#If DEBUGBUILD Then
OutputDebugString ("Adding thread &H" + _
Hex$(stCTDI.hThread) + _
" to thread collection" + vbNewLine)
OutputDebugString ("Total of " + _
CStr(g_colThreads.Count) + _
" in the collection" + vbNewLine)
#End If
g_clsCritSec.Leave
Exit Sub
DebugCreateThread_Error:
#If DEBUGBUILD Then
MsgBox ("DebugCreateThread Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugDllLoad(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugDllLoad_Error
Dim stLDDI As LOAD_DLL_DEBUG_INFO
stLDDI = clsDebugger.LoadDllDbgEvt
g_colDlls.Add Hex$(stLDDI.lpBaseOfDll), Hex$(stLDDI.lpBaseOfDll)
AppendText "DLL Loaded at &H" + Hex$(stLDDI.lpBaseOfDll)
#If DEBUGBUILD Then
OutputDebugString ("Adding DLL &H" + _
Hex$(stLDDI.lpBaseOfDll) + _
" to DLL collection" + _
vbNewLine)
OutputDebugString ("Total of " + _
CStr(g_colDlls.Count) + _
" in the collection" + vbNewLine)
#End If
g_clsCritSec.Leave
Exit Sub
DebugDllLoad_Error:
#If DEBUGBUILD Then
MsgBox ("DebugDllLoad Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugDllUnload(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugDllUnload_Error
Dim stULDDI As UNLOAD_DLL_DEBUG_INFO
stULDDI = clsDebugger.UnloadDllDbgEvt
g_colDlls.Remove Hex$(stULDDI.lpBaseOfDll)
AppendText "DLL Unloaded at &H" + Hex$(stULDDI.lpBaseOfDll)
#If DEBUGBUILD Then
OutputDebugString ("Removing DLL &H" + _
Hex$(stULDDI.lpBaseOfDll) + _
" from the DLL collection" + _
vbNewLine)
OutputDebugString ("Total of " + _
CStr(g_colDlls.Count) + _
" in the collection" + vbNewLine)
#End If
g_clsCritSec.Leave
Exit Sub
DebugDllUnload_Error:
#If DEBUGBUILD Then
MsgBox ("DebugDllUnload Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugException(clsDebugger As DebuggerClass, _
dwContType As Long, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugException_Error
Dim stER As EXCEPTION_RECORD
stER = clsDebugger.ExceptionDbgEvt.ExceptionRecord
' If this is a breakpoint exception and if the loader breakpoint has
' not been seen yet, then it is OK.
If ((False = g_bSeenFirstBP) And _
(EXCEPTION_BREAKPOINT = stER.ExceptionCode)) Then
g_bSeenFirstBP = True
#If Alpha Then
SkipBreakPoint g_hMainThread
#End If
dwContType = DBG_CONTINUE
Else
' The program has a problem. Here is where stack dumps and other
' helpful things could occur.
' If this is a first chance exception, pass it on to the debuggee
' to let them handle it first. The second time that it is seen,
' show the warning.
If (0 = clsDebugger.ExceptionDbgEvt.dwFirstChance) Then
AppendText GetExceptionString(stER.ExceptionCode) + _
" occurred at &H" + _
Hex$(stER.ExceptionAddress)
End If
dwContType = DBG_EXCEPTION_NOT_HANDLED
End If
g_clsCritSec.Leave
Exit Sub
DebugException_Error:
#If DEBUGBUILD Then
MsgBox ("DebugException Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugExitProcess _
(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugExitProcess_Error
#If DEBUGBUILD Then
Dim hThread As Long
hThread = g_colThreads.Item(CStr(dwThreadID))
#End If
g_colThreads.Remove CStr(dwThreadID)
AppendText "Process &H" + _
Hex$(g_hProcess) + _
" ended and returned &H" + _
Hex$(clsDebugger.ExitProcessDbgEvt.dwExitCode)
#If DEBUGBUILD Then
OutputDebugString ("Removing thread &H" + _
Hex$(hThread) + _
" from the thread collection" + _
vbNewLine)
OutputDebugString ("Total of " + _
CStr(g_colThreads.Count) + _
" in the collection" + vbNewLine)
#End If
g_clsCritSec.Leave
Exit Sub
DebugExitProcess_Error:
#If DEBUGBUILD Then
MsgBox ("DebugExitProcess Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugExitThread _
(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugExitThread_Error
Dim hThread As Long
hThread = g_colThreads.Item(CStr(dwThreadID))
g_colThreads.Remove CStr(dwThreadID)
AppendText "Thread &H" + _
Hex$(hThread) + _
" ended and returned &H" + _
Hex$(clsDebugger.ExitThreadDbgEvt.dwExitCode)
#If DEBUGBUILD Then
OutputDebugString ("Removing thread &H" + _
Hex$(hThread) + _
" from the thread collection" + _
vbNewLine)
OutputDebugString ("Total of " + _
CStr(g_colThreads.Count) + _
" in the collection" + vbNewLine)
#End If
g_clsCritSec.Leave
Exit Sub
DebugExitThread_Error:
#If DEBUGBUILD Then
MsgBox ("DebugExitThread Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugODS(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugODS_Error
Dim stODS As OUTPUT_DEBUG_STRING_INFO
Dim szOutBuff As String * 1024
Dim bRet As Long
Dim dwBytes As Long
stODS = clsDebugger.ODSDbgEvt
bRet = ReadProcessMemory(g_hProcess, _
stODS.lpDebugStringData, _
szOutBuff, _
stODS.nDebugStringLength, _
dwBytes)
AppendText "ODS: " + Left$(szOutBuff, stODS.nDebugStringLength)
g_clsCritSec.Leave
Exit Sub
DebugODS_Error:
#If DEBUGBUILD Then
MsgBox ("DebugODS Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_DebugRipInfo(clsDebugger As DebuggerClass, _
dwProcessID As Long, _
dwThreadID As Long)
g_clsCritSec.Enter
On Error GoTo DebugRipInfo_Error
g_clsCritSec.Leave
Exit Sub
DebugRipInfo_Error:
#If DEBUGBUILD Then
MsgBox ("DebugRipInfo Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_PauseProcess()
g_clsCritSec.Enter
On Error GoTo PauseProcess_Error
Dim lData As Variant
Dim bRet As Long
For Each lData In g_colThreads
bRet = SuspendThread(CLng(lData))
Next lData
g_clsCritSec.Leave
Exit Sub
PauseProcess_Error:
#If DEBUGBUILD Then
MsgBox ("PauseProcess Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
Private Sub BaseExecutive_ResumeProcess()
g_clsCritSec.Enter
On Error GoTo ResumeProcess_Error
Dim lData As Variant
Dim bRet As Long
For Each lData In g_colThreads
bRet = ResumeThread(CLng(lData))
Next lData
g_clsCritSec.Leave
Exit Sub
ResumeProcess_Error:
#If DEBUGBUILD Then
MsgBox ("ResumeProcess Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : AppendText
' DISCUSSION :
' This is a public interface off the SimpleExecutive class. Both the
' UI and this class will only call through it to do their output.
' PARAMETERS :
' szStr - The string to append.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub AppendText(szStr As String)
' Hey! Shouldn't there be a critical section in here? Technically,
' there should be, but since the edit control we are protecting is
' protected internally, it doesn't really need it.
On Error GoTo AppendText_Error
Dim lLen As Long
lLen = Len(szStr)
If (0 = lLen) Then
Exit Sub
End If
Dim szTemp As String
szTemp = g_txtOutput.Text
If (Chr$(13) <> Right$(szStr, lLen - 2)) Or _
(Chr$(10) <> Right$(szStr, lLen - 1)) Then
g_txtOutput.Text = szTemp + szStr + vbNewLine
Else
g_txtOutput.Text = szTemp + szStr
End If
' Now scroll the text into view.
g_txtOutput.SelStart = Len(g_txtOutput.Text)
Exit Sub
AppendText_Error:
#If DEBUGBUILD Then
MsgBox ("AppendText Error: " + Err.Description)
#End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DumpActiveThreads
' DISCUSSION :
' To demonstrate some of the cross-thread coordination, this function
' dumps the active threads for the debuggee. This is to give you an
' idea how to access information from the UI.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DumpActiveThreads()
g_clsCritSec.Enter
On Error GoTo PauseProcess_Error
Dim lData As Variant
Dim i As Long
For Each lData In g_colThreads
AppendText "Info: Active thread #" + CStr(i) + " Handle : &H" + _
Hex$(CLng(lData))
i = i + 1
Next lData
g_clsCritSec.Leave
Exit Sub
PauseProcess_Error:
#If DEBUGBUILD Then
MsgBox ("DumpActiveThreads Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DumpLoadedDLLs
' DISCUSSION :
' Like DumpActiveThreads, dumps the loaded DLLs that are currently in
' the debuggee's address space.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DumpLoadedDLLs()
g_clsCritSec.Enter
On Error GoTo PauseProcess_Error
Dim szData As Variant
Dim i As Long
For Each szData In g_colDlls
AppendText "Info: DLL #" + CStr(i) + " Loaded at &H" + _
szData
i = i + 1
Next szData
g_clsCritSec.Leave
Exit Sub
PauseProcess_Error:
#If DEBUGBUILD Then
MsgBox ("DumpActiveThreads Error: " + Err.Description)
#End If
g_clsCritSec.Leave
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : SkipBreakPoint
' DISCUSSION :
' The function that skips over Alpha breakpoints. Where Intel
' breakpoints automatically increment EIP when hit, on the Alpha, Fir
' is not.
' PARAMETERS :
' hThread - The thread where the skip is to take place.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
#If Alpha Then
Private Sub SkipBreakPoint(hThread As Long)
Dim ctx As CONTEXT
Dim bRet As Long
ctx.ContextFlags = CONTEXT_CONTROL
bRet = GetThreadContext(hThread, ctx)
If (1 <> bRet) Then
MsgBox ("GetThreadContext failed!")
End If
' Alpha instructions are all four bytes long.
ctx.Fir.lowpart = ctx.Fir.lowpart + 4
bRet = SetThreadContext(hThread, ctx)
If (1 <> bRet) Then
MsgBox ("SetThreadContext failed!")
End If
End Sub
#End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : GetExceptionString
' DISCUSSION :
' Given an exception code, returns the human readable string that
' describes it.
' PARAMETERS :
' dwCode - The exception code.
' RETURN :
' The string. If the exception is unknown then "Unknown exception"
' is returned.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function GetExceptionString(dwCode As Long) As String
Select Case (dwCode)
Case EXCEPTION_ACCESS_VIOLATION
GetExceptionString = "Access Violation Exception"
Exit Function
Case EXCEPTION_DATATYPE_MISALIGNMENT
GetExceptionString = "Datatype Misalignment Exception"
Exit Function
Case EXCEPTION_BREAKPOINT
GetExceptionString = "Breakpoint Exception"
Exit Function
Case EXCEPTION_SINGLE_STEP
GetExceptionString = "Single Step Exception"
Exit Function
Case EXCEPTION_ARRAY_BOUNDS_EXCEEDED
GetExceptionString = "Array Bounds Exceeded Exception"
Exit Function
Case EXCEPTION_FLT_DENORMAL_OPERAND
GetExceptionString = "Floating Point Denormal Operand Exception"
Exit Function
Case EXCEPTION_FLT_DIVIDE_BY_ZERO
GetExceptionString = "Floating Point Divide By Zero Exception"
Exit Function
Case EXCEPTION_FLT_INEXACT_RESULT
GetExceptionString = "Floating Point Inexact Result Exception"
Exit Function
Case EXCEPTION_FLT_INVALID_OPERATION
GetExceptionString = "Floating Point Invalid Operation Exception"
Exit Function
Case EXCEPTION_FLT_OVERFLOW
GetExceptionString = "Floating Point Overflow Exception"
Exit Function
Case EXCEPTION_INT_DIVIDE_BY_ZERO
GetExceptionString = "Integer Divide By Zero Exception"
Exit Function
Case EXCEPTION_INT_OVERFLOW
GetExceptionString = "Integer Overflow Exception"
Exit Function
Case EXCEPTION_PRIV_INSTRUCTION
GetExceptionString = "Privileged Instruction Exception"
Exit Function
Case EXCEPTION_IN_PAGE_ERROR
GetExceptionString = "In Page Error Exception"
Exit Function
Case EXCEPTION_ILLEGAL_INSTRUCTION
GetExceptionString = "Illegal Instruction Exception"
Exit Function
Case EXCEPTION_NONCONTINUABLE_EXCEPTION
GetExceptionString = "Noncontinuable Exception"
Exit Function
Case EXCEPTION_STACK_OVERFLOW
GetExceptionString = "Stack Overflow Exception"
Exit Function
Case EXCEPTION_INVALID_DISPOSITION
GetExceptionString = "Invalid Disposition Exception"
Exit Function
Case EXCEPTION_GUARD_PAGE
GetExceptionString = "Guard Page Exception"
Exit Function
Case Else
GetExceptionString = "Unknown Exception (&H" + _
Hex$(dwCode) + ")"
Exit Function
End Select
End Function
VBD_Constants.bas
Attribute VB_Name = "VBD_Constants" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' John Robbins ' Microsoft Systems Journal - August 1997 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Helpful constants that really should be in a .RES file. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' The name of the application. Global Const k_APPNAME As String = "VBDebug" ' The names for the different states that we show in the main window ' title. Global Const k_NOTRUNNINGSTATE As String = " [Loaded]" Global Const k_PAUSEDSTATE As String = " [Paused]" Global Const k_DEBUGGINGSTATE As String = " [Running]"EndDbgThread.bas
Attribute VB_Name = "EndDbgThread"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins
' Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : EndDbgThread.bas
' DESCRIPTION :
' The thread that tells the UI that the debug thread has ended.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
' The type that is passed to the wait thread.
Public Type SPECIALWAIT_TYPE
' The thread to wait on.
hThread As Long
' The form to call the DebugThreadEnded method on. As long as your
' form has the DebugThreadEnded method, the type is the only thing
' that should be changed in this file.
frmDTE As frmVBDebug
End Type
' The function that starts the debug thread.
Public Function StartWaitThread(stWaitType As SPECIALWAIT_TYPE) As Long
Dim hThread As Long
Dim lThreadID As Long
' Create the thread.
hThread = CreateThread(0, _
0, _
AddressOf WaitForEndOfDebugThread, _
stWaitType, _
0, _
lThreadID)
StartWaitThread = hThread
End Function
Public Function WaitForEndOfDebugThread _
(stWaitType As SPECIALWAIT_TYPE) As Long
On Error GoTo WaitForEndOfDebugThread_Error
Dim bRet As Long
' Wait for the debug thread to become signaled, which means it is
' done.
bRet = WaitForSingleObject(stWaitType.hThread, INFINITE)
' Instead of calling directly into the form, I would have preferred to
' do a PostMessage here, but when this program is run on a
' multiprocessor machine, the message never makes it through the
' runtime. Therefore, we have to call into the form.
stWaitType.frmDTE.DebugThreadEnded
WaitForEndOfDebugThread = 1
Exit Function
WaitForEndOfDebugThread_Error:
MsgBox ("Got an error in DebugThread: " + Err.Description)
WaitForEndOfDebugThread = 0
End Function
Figure 3 Reusable VBDebug Code
BaseExecutive.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "BaseExecutive"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins, Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : BaseExecutive.cls
' DESCRIPTION :
' The abstract base class for all debugger executives.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugCreateProcess
' DISCUSSION :
' Called when the debugger thread gets a process create notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugCreateProcess(clsDebugger As DebuggerClass,
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugExitProcess
' DISCUSSION :
' Called when the debugger thread gets a process exit notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugExitProcess(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugCreateThread
' DISCUSSION :
' Called when the debugger thread gets a thread create notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugCreateThread(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugExitThread
' DISCUSSION :
' Called when the debugger thread gets a thread exit notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugExitThread(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugDllLoad
' DISCUSSION :
' Called when the debugger thread gets a DLL load notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugDllLoad(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugDllUnload
' DISCUSSION :
' Called when the debugger thread gets a DLL unload notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugDllUnload(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugODS
' DISCUSSION :
' Called when the debugger thread gets an OutputDebugString
' notification
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugODS(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugException
' DISCUSSION :
' Called when the debugger thread gets an exception notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwContType - The way to continue debugging.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugException(clsDebugger As DebuggerClass, _
dwContType As Long, dwProcessID As Long, _
dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DebugRipInfo
' DISCUSSION :
' Called when the debugger thread gets an RIP notification.
' PARAMETERS :
' clsDebugger - The debugger class to query for additional information.
' dwProcessID - The process ID for the process.
' dwThreadID - The thread ID for the thread.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DebugRipInfo(clsDebugger As DebuggerClass, _
dwProcessID As Long, dwThreadID As Long)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : PauseProcess
' DISCUSSION :
' When the debug process has been told to pause, this function is
' called because it is up to the executive to do the SuspendThreads.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub PauseProcess()
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : ResumeProcess
' DISCUSSION :
' When the debug process has been told to resume, this function is
' called because it is up to the executive to do the ResumeThreads.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ResumeProcess()
End Sub
CriticalSection.cls
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "CriticalSection" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' John Robbins, Microsoft Systems Journal - August 1997 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' FILE : CriticalSection.cls ' DESCRIPTION : ' A nice helper class that encapsulates critical section handling. ' If you use this class to control access to data, make sure you set ' up all the functions that use it with error handlers to make sure ' that the Leave method is called after the enter. In the following ' example, g_CritSec is the critical section class. ' 'Public Sub DoSomething ( ) ' g_CritSec.Enter ' On Error GoTo DoSomething_Error ' ' Do some work here! ' g_CritSec.Leave ' Exit Sub ' 'DoSomething_Error: ' g_CritSec.Leave 'End Sub ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Class private variables '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private m_CritSec As CRITICAL_SECTION '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' FUNCTION : Class_Initialize ' DISCUSSION : ' The initialization for the class. This just initializes the private ' CRITICAL_SECTION structure. ' PARAMETERS : ' None. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Class_Initialize() InitializeCriticalSection m_CritSec End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' FUNCTION : Class_Terminate ' DISCUSSION : ' The termination for the class. This just frees up the private ' CRITICAL_SECTION structure. ' PARAMETERS : ' None. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Class_Terminate() DeleteCriticalSection m_CritSec End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' FUNCTION : Enter ' DISCUSSION : ' Locks on the critical section by calling EnterCriticalSection. ' PARAMETERS : ' None. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub Enter() EnterCriticalSection m_CritSec End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' FUNCTION : Leave ' DISCUSSION : ' Unlocks the critical section by calling LeaveCriticalSection. ' PARAMETERS : ' None. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub Leave() LeaveCriticalSection m_CritSec End SubDebuggerClass.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "DebuggerClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins, Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : DebuggerClass.cls
' DESCRIPTION :
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Class private variables
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The required full filename of the debuggee.
Private m_szDebuggee As String
' The optional command line to use.
Private m_szCmdLine As String
' The optional startup directory.
Private m_szWorkDir As String
' The executive class that the debugger will use.
Private m_clsExecutive As BaseExecutive
' The synchronization class that the debugger will use. This is its own
' instance.
Private m_clsSynch As DebugSynchClass
' The process ID for the debuggee.
Private m_dwDebuggeePID As Long
' The error code returned when I tried to create the debuggee.
Private m_dwCreateError As Long
' The individual debug events. These are declared as private members
' and all have specific friend property get functions that will return
' them. If the debugger class is supposed to move into an ActiveX
' control, then this decision will have to be rethought.
Private m_CreateProcessDbgEvt As CREATE_PROCESS_DEBUG_INFO
Private m_CreateThreadDbgEvt As CREATE_THREAD_DEBUG_INFO
Private m_ExceptionDbgEvt As EXCEPTION_DEBUG_INFO
Private m_ExitProcessDbgEvt As EXIT_PROCESS_DEBUG_INFO
Private m_ExitThreadDbgEvt As EXIT_THREAD_DEBUG_INFO
Private m_ODSDbgEvt As OUTPUT_DEBUG_STRING_INFO
Private m_LoadDllDbgEvt As LOAD_DLL_DEBUG_INFO
Private m_UnloadDllDbgEvt As UNLOAD_DLL_DEBUG_INFO
Private m_RipInfo As RIP_INFO
Friend Property Set clsBaseExecutive(clsBase As BaseExecutive)
Set m_clsExecutive = clsBase
End Property
Friend Property Get CreateProcessDbgEvt() As CREATE_PROCESS_DEBUG_INFO
CreateProcessDbgEvt = m_CreateProcessDbgEvt
End Property
Friend Property Get CreateThreadDbgEvt() As CREATE_THREAD_DEBUG_INFO
CreateThreadDbgEvt = m_CreateThreadDbgEvt
End Property
Friend Property Get ExceptionDbgEvt() As EXCEPTION_DEBUG_INFO
ExceptionDbgEvt = m_ExceptionDbgEvt
End Property
Friend Property Get ExitProcessDbgEvt() As EXIT_PROCESS_DEBUG_INFO
ExitProcessDbgEvt = m_ExitProcessDbgEvt
End Property
Friend Property Get ExitThreadDbgEvt() As EXIT_THREAD_DEBUG_INFO
ExitThreadDbgEvt = m_ExitThreadDbgEvt
End Property
Friend Property Get ODSDbgEvt() As OUTPUT_DEBUG_STRING_INFO
ODSDbgEvt = m_ODSDbgEvt
End Property
Friend Property Get LoadDllDbgEvt() As LOAD_DLL_DEBUG_INFO
LoadDllDbgEvt = m_LoadDllDbgEvt
End Property
Friend Property Get UnloadDllDbgEvt() As UNLOAD_DLL_DEBUG_INFO
UnloadDllDbgEvt = m_UnloadDllDbgEvt
End Property
Friend Property Get RipInfo() As RIP_INFO
RipInfo = m_RipInfo
End Property
Friend Property Get dwDebuggeePID() As Long
dwDebuggeePID = m_dwDebuggeePID
End Property
Friend Property Get dwCreateError() As Long
dwCreateError = m_dwCreateError
End Property
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : Class_Initialize
' DISCUSSION :
' The initialization for the class.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
Set m_clsExecutive = Nothing
Set m_clsSynch = New DebugSynchClass
m_dwDebuggeePID = 0
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : Class_Terminate
' DISCUSSION :
' The termination for the class.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Terminate()
Set m_clsExecutive = Nothing
Set m_clsSynch = Nothing
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : SetDebuggeeInfo
' DISCUSSION :
' Sets the information that MUST be set before the class can be used.
' PARAMETERS :
' szDebuggee - The full path and name of the program to debug.
' szCmdLine - The command line for the debuggee. This can be
' vbNullString.
' szWorkDir - The working directory for the debuggee. This can be
' vbNullString.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub SetDebuggeeInfo(szDebuggee As String, _
Optional szCmdLine As String = vbNullString, _
Optional szWorkDir As String = vbNullString)
' Set the variables.
m_szDebuggee = szDebuggee
m_szCmdLine = szCmdLine
m_szWorkDir = szWorkDir
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : StartDebuggee
' DISCUSSION :
' Starts up the debuggee. This can only be called from the debug
' thread.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function StartDebuggee() As Boolean
On Error GoTo StartDebuggee_Error
Dim bRet As Long
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
' Initialize si and pi to known values.
si.cb = &H44
si.cbReserved2 = 0
si.dwFillAttribute = 0
si.dwFlags = 0
si.dwX = 0
si.dwX = 0
si.dwY = 0
si.dwXSize = 0
si.dwYSize = 0
si.dwXCountChars = 0
si.dwYCountChars = 0
si.dwFillAttribute = 0
si.dwFlags = 0
si.wShowWindow = 0
si.cbReserved2 = 0
si.lpReserved2 = 0
si.hStdInput = 0
si.hStdOutput = 0
si.hStdError = 0
pi.hProcess = 0
pi.hThread = 0
pi.dwProcessID = 0
pi.dwThreadID = 0
' Try and start up the application to debug.
bRet = CreateProcess(m_szDebuggee, m_szCmdLine, 0, 0,0, _
DEBUG_ONLY_THIS_PROCESS, _
vbNullString, m_szWorkDir, si, pi)
' Set the create error.
m_dwCreateError = GetLastError
' If the CreateProcesses failed, signal the event that the debuggee
' failed to start, and then leave.
If (0 = bRet) Then
m_clsSynch.SignalBadStartup
StartDebuggee = False
Exit Function
End If
' Close some handles I don't need.
bRet = CloseHandle(pi.hProcess)
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("StartDebuggee CloseHandle failed!")
End If
#End If
bRet = CloseHandle(pi.hThread)
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("StartDebuggee CloseHandle failed!")
End If
#End If
' Set the unique PID for the debuggee.
m_dwDebuggeePID = pi.dwProcessID
m_clsSynch.dwUniqueID = m_dwDebuggeePID
' Create the synchronization objects for the synch class for just
' this thread.
m_clsSynch.CreateSynchObjects
' At least the debuggee was able to start so signal that event.
m_clsSynch.SignalGoodStartup
StartDebuggee = True
Exit Function
StartDebuggee_Error:
MsgBox ("Got an error in StartDebuggee: " + Err.Description)
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : ProcessDebugEvents
' DISCUSSION :
' Does the looping and processing of debug events.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ProcessDebugEvents()
Dim DbgEvt As DEBUG_EVENT
Dim dwContType As Long
Dim bRet As Long
Dim bDebugRunning
Dim iObject As Long
' The debugger loop is always running.
bDebugRunning = True
While (True = bDebugRunning)
' Which thing am I supposed to be doing?
iObject = m_clsSynch.WaitForSynchObject(INFINITE)
Select Case iObject
' Quitting.
Case 0
bDebugRunning = False
' Pausing.
Case 1
m_clsExecutive.PauseProcess
' Resuming.
Case 2
m_clsExecutive.ResumeProcess
' Regular debugging.
Case 3
' Wait a bit for the debug event.
If (1 = WaitForDebugEvent(DbgEvt, 100)) Then
' Default to continuing.
dwContType = DBG_CONTINUE
' Process all the debug events by calling the executive
' class that I was passed at startup.
Select Case DbgEvt.dwDebugEventCode
Case CREATE_PROCESS_DEBUG_EVENT
LSet m_CreateProcessDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugCreateProcess Me, _
DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case CREATE_THREAD_DEBUG_EVENT
LSet m_CreateThreadDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugCreateThread Me, DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case EXIT_PROCESS_DEBUG_EVENT
LSet m_ExitProcessDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugExitProcess Me, DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
' EXIT_PROCESS_DEBUG_EVENT is handled special in
' that I will just go ahead and exit the
' processing subroutine.
Exit Sub
Case EXIT_THREAD_DEBUG_EVENT
LSet m_ExitThreadDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugExitThread Me, DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case EXCEPTION_DEBUG_EVENT
LSet m_ExceptionDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugException Me, dwContType, _
DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case OUTPUT_DEBUG_STRING_EVENT
LSet m_ODSDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugODS Me, DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case LOAD_DLL_DEBUG_EVENT
LSet m_LoadDllDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugDllLoad Me, DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case UNLOAD_DLL_DEBUG_EVENT
LSet m_UnloadDllDbgEvt = DbgEvt.dwUnionData
m_clsExecutive.DebugDllUnload Me,DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
Case RIP_EVENT
LSet m_RipInfo = DbgEvt.dwUnionData
m_clsExecutive.DebugRipInfo Me, DbgEvt.dwProcessID, _
DbgEvt.dwThreadID
End Select
bRet = ContinueDebugEvent(DbgEvt.dwProcessID, DbgEvt.dwThreadID, _
dwContType)
End If
Case Else
#If DEBUGBUILD Then
MsgBox ("WaitForSynchObject returned something other " & _
"than 0 - 3!!")
#End If
End Select
Wend
End Sub
DebugSynchClass.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "DebugSynchClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins, Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : DebugSynchClass.cls
' DESCRIPTION :
' The class that handles the chores of encapsulating all of the
' synchronization objects that are used to coordinate the debugger
' thread and the user interface.
' When looking this over, you might wonder why there is no
' synchronization handling to indicate that the debug thread is fully
' shut down. While it could be done, it would be redundant because
' the UI should be triggered off of the debug thread handle. That's
' the only way to ensure that a thread is really done processing.
' Each thread MUST create their own instances of this class.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Class private constants
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The event that signals when I had a good debuggee process startup.
' The PID is appended to it.
Private Const k_GOODSTARTUPSTRING As String = "VBDEBUG_GOODSTARTUP"
' The event that signals when I had a failure of the debuggee process
' startup. The PID is appended to it.
Private Const k_BADSTARTUPSTRING As String = "VBDEBUG_BADSTARTUP"
' The array indexes for the startup events.
Private Const k_GOODSTARTID As Long = 0
Private Const k_BADSTARTID As Long = 1
' The core synchronization objects: the debugging event, quit, pause,
' and resume events. These have the DEBUGGEE process ID appended to
' them to make sure that they are unique.
Private Const k_QUITSTRING As String = "VBDEBUG_QUIT"
Private Const k_PAUSESTRING As String = "VBDEBUG_PAUSE"
Private Const k_RESUMESTRING As String = "VBDEBUG_RESUME"
Private Const k_DEBUGSTRING As String = "VBDEBUG_DEBUG"
' The IDs for which elements in the event array belong to which. Too
' bad VB won't let you expose constants.
' The quit event is first because the WaitForMultipleObjects function
' will return on it first when it is signaled before looking at the
' regular debug events.
Private Const k_QUITEVENT As Long = 0
Private Const k_PAUSEEVENT As Long = 1
Private Const k_RESUMEEVENT As Long = 2
Private Const k_DEBUGACTIVEEVENT As Long = 3
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Class private variables
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' The process ID of the debugger.
Private m_hControlPID As Long
' The process ID for the debuggee.
Private m_hDebuggeePID As Long
' The core events I wait on, the quit, pause, resume, and debug.
Private m_hDebugEvents(4) As Long
' The startup events that can be signaled.
Private m_hStartupEvents(2) As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : Class_Initialize
' DISCUSSION :
' The initialization for the class.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
m_hDebugEvents(0) = 0
m_hDebugEvents(1) = 0
m_hDebugEvents(2) = 0
m_hDebugEvents(3) = 0
m_hDebuggeePID = 0
m_hStartupEvents(0) = 0
m_hStartupEvents(1) = 0
m_hControlPID = GetCurrentProcessId()
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : Class_Terminate
' DISCUSSION :
' The termination for the class.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Terminate()
' If the handles have not been destroyed, do it now.
If ((0 <> m_hDebugEvents(k_QUITEVENT)) And _
(0 <> m_hDebugEvents(k_DEBUGACTIVEEVENT))) Then
DeleteSynchObjects
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Properties and methods only for the debug thread!
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : dwUniqueID
' DISCUSSION :
' The property set for the unique ID for the core synch events.
' PARAMETERS :
' dwID - The value.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Let dwUniqueID(dwID As Variant)
m_hDebuggeePID = dwID
End Property
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : SignalGoodStartup
' DISCUSSION :
' Signals that the debuggee started up correctly. This is only called
' from the debug thread. The UI is supposed to be waiting in the
' WaitForStartup method.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub SignalGoodStartup()
SignalManualResetEvent (k_GOODSTARTUPSTRING + Hex$(m_hControlPID))
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : SignalBadStartup
' DISCUSSION :
' Signals that the debuggee failed to start correctly. This is only
' called from the debug thread. The UI is supposed to be waiting in
' the WaitForStartup method.
' PARAMETERS :
' None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub SignalBadStartup()
SignalManualResetEvent (k_BADSTARTUPSTRING + Hex$(m_hControlPID))
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : CreateSynchObjects
' DISCUSSION :
' The function that creates the synchronization objects that are used
' to coordinate everything between the debug thread and the UI.
' PARAMETERS :
' None.
' RETURNS :
' True - Everything was created correctly.
' False - There was a problem.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function CreateSynchObjects() As Boolean
Dim bRet As Long
' I assume that the return value will be good.
CreateSynchObjects = True
#If DEBUGBUILD Then
If (0 = m_hDebuggeePID) Then
MsgBox ("CreateSynchObjects called before the unique id set!")
End If
#End If
If (0 = m_hDebuggeePID) Then
CreateSynchObjects = False
Exit Function
End If
' Create the quit event. It is a manual reset event that is not signaled
m_hDebugEvents(k_QUITEVENT) = CreateEvent(0, 1, 0, k_QUITSTRING + _
Hex$(m_hDebuggeePID))
#If DEBUGBUILD Then
If (0 = m_hDebugEvents(k_QUITEVENT)) Then
MsgBox ("CreateSynchObjects unable to create Quit event!")
End If
#End If
If (0 = m_hDebugEvents(k_QUITEVENT)) Then
CreateSynchObjects = False
Exit Function
End If
' Create the pause event. It is a manual reset event that is not signaled
m_hDebugEvents(k_PAUSEEVENT) = CreateEvent(0, 1, 0, k_PAUSESTRING + _
Hex$(m_hDebuggeePID))
#If DEBUGBUILD Then
If (0 = m_hDebugEvents(k_PAUSEEVENT)) Then
MsgBox ("CreateSynchObjects unable to create Pause event!")
End If
#End If
If (0 = m_hDebugEvents(k_PAUSEEVENT)) Then
bRet = CloseHandle(m_hDebugEvents(k_QUITEVENT))
CreateSynchObjects = False
Exit Function
End If
' Create the resume event. It is a manual reset event that is not signaled
m_hDebugEvents(k_RESUMEEVENT) = CreateEvent(0, 1, 0, k_RESUMESTRING + _
Hex$(m_hDebuggeePID))
#If DEBUGBUILD Then
If (0 = m_hDebugEvents(k_RESUMEEVENT)) Then
MsgBox ("CreateSynchObjects unable to create Resume event!")
End If
#End If
If (0 = m_hDebugEvents(k_RESUMEEVENT)) Then
bRet = CloseHandle(m_hDebugEvents(k_QUITEVENT))
bRet = CloseHandle(m_hDebugEvents(k_PAUSEEVENT))
CreateSynchObjects = False
Exit Function
End If
' Create the debug event. It is a manual reset event that is
' signaled.
m_hDebugEvents(k_DEBUGACTIVEEVENT) = CreateEvent(0, 1, 1, k_DEBUGSTRING + _
Hex$(m_hDebuggeePID))
#If DEBUGBUILD Then
If (0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Then
MsgBox ("CreateSynchObjects unable to create Debug event!")
End If
#End If
If (0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Then
bRet = CloseHandle(m_hDebugEvents(k_QUITEVENT))
bRet = CloseHandle(m_hDebugEvents(k_PAUSEEVENT))
bRet = CloseHandle(m_hDebugEvents(k_RESUMEEVENT))
CreateSynchObjects = False
Exit Function
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : DeleteSynchObjects
' DISCUSSION : Deletes the synchronization objects created with
' CreateSynchObjects.
' PARAMETERS : None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub DeleteSynchObjects()
Dim bRet As Long
#If DEBUGBUILD Then
If ((0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Or _
((0 = m_hDebugEvents(k_QUITEVENT)))) Then
MsgBox ("DeleteSynchObjects called before CreateSynchObjects!")
End If
#End If
bRet = CloseHandle(m_hDebugEvents(k_DEBUGACTIVEEVENT))
m_hDebugEvents(k_DEBUGACTIVEEVENT) = 0
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("DeleteSynchObjects failed closing debug event handle")
End If
#End If
bRet = CloseHandle(m_hDebugEvents(k_QUITEVENT))
m_hDebugEvents(k_QUITEVENT) = 0
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("DeleteSynchObjects failed closing quit event handle")
End If
#End If
bRet = CloseHandle(m_hDebugEvents(k_PAUSEEVENT))
m_hDebugEvents(k_PAUSEEVENT) = 0
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("DeleteSynchObjects failed closing pause event handle")
End If
#End If
bRet = CloseHandle(m_hDebugEvents(k_RESUMEEVENT))
m_hDebugEvents(k_RESUMEEVENT) = 0
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("DeleteSynchObjects failed closing resume event handle")
End If
#End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : WaitForSynchObject
' DISCUSSION :
' This is the function that the debug thread will call to figure out
' what it should be doing.
' PARAMETERS :
' The maximum time, in milliseconds to wait. The SDK define INFINITE
' is permitted.
' RETURNS :
' 0 - The quit event was signaled.
' 1 - The pause event was signaled.
' 2 - The resume event was signaled.
' 3 - The debug event was signaled.
' Otherwise - See the return values for WaitForMultipleObjects
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function WaitForSynchObject(dwWaitTime As Long) As Long
#If DEBUGBUILD Then
If ((0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Or _
((0 = m_hDebugEvents(k_QUITEVENT)))) Then
MsgBox ("DeleteSynchObjects called before CreateSynchObjects!")
End If
#End If
Dim dwRet As Long
dwRet = WaitForMultipleObjects(4, m_hDebugEvents(0), 0, dwWaitTime)
' Handle the resets on Pause and Resume.
Dim bTemp As Long
If (k_PAUSEEVENT = dwRet) Then
bTemp = ResetEvent(m_hDebugEvents(k_DEBUGACTIVEEVENT))
' Put the pause back into its normal state.
bTemp = ResetEvent(m_hDebugEvents(k_PAUSEEVENT))
ElseIf (k_RESUMEEVENT = dwRet) Then
bTemp = SetEvent(m_hDebugEvents(k_DEBUGACTIVEEVENT))
bTemp = ResetEvent(m_hDebugEvents(k_RESUMEEVENT))
End If
WaitForSynchObject = dwRet
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Properties and methods only for the UI thread!
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : PrepareWaitForStartup
' DISCUSSION :
' The UI MUST call this function before it can call WaitForStartup.
' It must also be called before spawning the debug thread as well.
' As I found out on those really, really fast DEC Alphas, the debugger
' thread can fail the CreateProcess and call SignalBadStartup
' before the UI can call WaitForStartup, which, you guessed it, causes
' massive deadlock. By requiring the UI to call this function first,
' I make sure that the event is ready. 400Mhz really helps show
' synchronization problems!
' PARAMETERS : None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub PrepareWaitForStartup()
' Create the events
m_hStartupEvents(k_GOODSTARTID) = CreateEvent(0, 1, 0, k_GOODSTARTUPSTRING + _
Hex$(m_hControlPID))
m_hStartupEvents(k_BADSTARTID) = CreateEvent(0, 1, 0, k_BADSTARTUPSTRING + _
Hex$(m_hControlPID))
#If DEBUGBUILD Then
If ((0 = m_hStartupEvents(k_BADSTARTID)) Or _
(0 = m_hStartupEvents(k_GOODSTARTID))) Then
MsgBox ("PrepareWaitForStartup failed to create events")
End If
#End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : WaitForStartup
' DISCUSSION :
' The UI thread calls this after it has created the thread so that it
' can then check if life got cranked up. The UI must call
' PrepareWaitForStartup FIRST!
' PARAMETERS : None.
' RETURNS :
' TRUE - The debuggee was started correctly.
' FALSE - The debuggee was not started correctly.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function WaitForStartup() As Boolean
#If DEBUGBUILD Then
If ((0 = m_hStartupEvents(k_BADSTARTID)) Or _
(0 = m_hStartupEvents(k_GOODSTARTID))) Then
MsgBox ("WaitForStartup can only be called after " + _
"PrepareWaitForStartup!")
End If
#End If
Dim dwRet As Long
Dim bRet As Long
' Wait for one of the startup events.
dwRet = WaitForMultipleObjects(2, m_hStartupEvents(0), 0, INFINITE)
' Close the handles.
bRet = CloseHandle(m_hStartupEvents(k_BADSTARTID))
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("WaitForStartup CloseHandle(k_BADSTARTID) failed!")
End If
#End If
bRet = CloseHandle(m_hStartupEvents(k_GOODSTARTID))
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("WaitForStartup CloseHandle(k_GOODSTARTID) failed!")
End If
#End If
If (k_GOODSTARTID = dwRet) Then
WaitForStartup = True
Else
WaitForStartup = False
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : PauseDebugThread
' DISCUSSION : Pauses the debug thread. Only the UI thread should call this!
' PARAMETERS : None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub PauseDebugThread()
#If DEBUGBUILD Then
If ((0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Or _
((0 = m_hDebugEvents(k_QUITEVENT)))) Then
MsgBox ("PauseDebugThread called before CreateSynchObjects!")
End If
#End If
Dim bRet As Long
bRet = SetEvent(m_hDebugEvents(k_PAUSEEVENT))
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("PauseDebugThread ResetEvent failed!")
End If
#End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : ResumeDebugThread
' DISCUSSION : Resumes the debug thread. Only the UI thread should call this!
' PARAMETERS : None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ResumeDebugThread()
#If DEBUGBUILD Then
If ((0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Or _
((0 = m_hDebugEvents(k_QUITEVENT)))) Then
MsgBox ("ResumeDebugThread called before CreateSynchObjects!")
End If
#End If
Dim bRet As Long
bRet = SetEvent(m_hDebugEvents(k_RESUMEEVENT))
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("ResumeDebugThread SetEvent failed!")
End If
#End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : QuitDebugThread
' DISCUSSION : Quits the debug thread. Only the UI thread should call this!
' PARAMETERS : None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub QuitDebugThread()
#If DEBUGBUILD Then
If ((0 = m_hDebugEvents(k_DEBUGACTIVEEVENT)) Or _
((0 = m_hDebugEvents(k_QUITEVENT)))) Then
MsgBox ("QuitDebugThread called before CreateSynchObjects!")
End If
#End If
' All I have to do is set the debug event to the signaled state.
Dim bRet As Long
bRet = SetEvent(m_hDebugEvents(k_QUITEVENT))
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("QuitDebugThread SetEvent failed!")
End If
#End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Class Private Helper Routines
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FUNCTION : SignalManualResetEvent
' DISCUSSION :
' A helper function for SignalGoodStartup and SignalBadStartup. Simply
' creates and signals the event with the passed in string.
' PARAMETERS : None.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub SignalManualResetEvent(szStr As String)
Dim hEvent As Long
Dim bRet As Long
' Create the event.
hEvent = CreateEvent(0, 1, 1, szStr)
#If DEBUGBUILD Then
If (0 = hEvent) Then
MsgBox ("SignalManualResetEvent failed to create event")
End If
#End If
If (0 = hEvent) Then
Exit Sub
End If
' Signal the event.
bRet = SetEvent(hEvent)
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("SignalManualResetEvent failed to set event")
End If
#End If
' Close the handle.
bRet = CloseHandle(hEvent)
#If DEBUGBUILD Then
If (0 = bRet) Then
MsgBox ("SignalManualResetEvent CloseHandle failed!")
End If
#End If
End Sub
DebugThread.bas
Attribute VB_Name = "DebugThread"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' John Robbins, Microsoft Systems Journal - August 1997
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FILE : DebugThread.bas
' DESCRIPTION :
' Since the AddressOf operator can only take things out of .BAS
' modules, this is the actual debug thread and the thread function.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
' The function that starts the debug thread.
Public Function StartDebugThread(clsDebug As DebuggerClass) As Long
Dim hThread As Long
Dim lThreadID As Long
' Create the thread.
hThread = CreateThread(0, 0, AddressOf DebugThread, clsDebug, 0, lThreadID)
StartDebugThread = hThread
End Function
' The actual debug thread.
Public Function DebugThread(clsDebug As DebuggerClass) As Long
On Error GoTo DebugThread_Error
Dim boolRet As Boolean
boolRet = clsDebug.StartDebuggee
If (False = boolRet) Then
DebugThread = 0
Exit Function
End If
' Process debug events until done.
clsDebug.ProcessDebugEvents
DebugThread = 1
Exit Function
DebugThread_Error:
MsgBox ("Got an error in DebugThread: " + Err.Description)
End Function