Tweet
Debugging utility
Here is the latest PowerBASIC source code for zTrace version 1.90.
Post questions or comments here:
https://forum.powerbasic.com/forum/u...ugging-utility
Here is the latest PowerBASIC source code for zTrace version 1.90.
Code:
'+--------------------------------------------------------------------------+
'| |
'| zTrace 1.90 |
'| |
'| Win32 SDK debugging window DLL |
'| |
'+--------------------------------------------------------------------------+
'| |
'| Author Patrice TERRIER |
'| |
'| copyright(c) 2009-2014 |
'| |
'| Patrice Terrier http://www.zapsolution.com |
'| |
'+--------------------------------------------------------------------------+
'| Project started on : 04-04-2009 (MM-DD-YYYY) |
'| Last revised : 12-13-2014 (MM-DD-YYYY) |
'+--------------------------------------------------------------------------+
#COMPILE DLL "zTrace.dll"
#INCLUDE "windows.inc"
#INCLUDE "commdlg.inc"
'----------------------------------------------------------------------
%dwStyle = %WS_VISIBLE or %WS_CLIPSIBLINGS or %WS_CLIPCHILDREN or %WS_CAPTION or %WS_SYSMENU or %WS_THICKFRAME
%dwExStyle = %WS_EX_TOOLWINDOW
$ZTRACE = "zTrace 1.90"
%HORIZONTAL_EXTENT = 6000 '// Maximum value for the horizontal scrollbar
%MIN_WIDTH = 300 '// default client width size
%MIN_HEIGHT = 65 '// default client height size
%ID_LISTBOX = 1
%IDM_About = 101 '// menu popup
%IDM_Hscroll = 103 '// menu popup
%IDM_Print = 104 '// menu popup
%IDM_CopyToClipboard = 105 '// menu popup
%IDM_ClearContent = 106 '// menu popup
%IDM_TopMost = 107 '// menu popup
%IDM_Debug = 108 '// menu popup
%IDM_SaveCoordinates = 109 '// menu popup
type PROP
backbrush as dword
x as long
y as long
w as long
h as long
savecoordinates as long
topmost as long
debug as long
usescrollbar as long
end type
global gP as PROP
function FileSize(szFileSpec as asciiz) as dword
local fd as WIN32_FIND_DATA
local nRet, hFind as dword
if (len(szFileSpec)) then
hFind = FindFirstFile(szFileSpec, fd)
if (hFind <> %INVALID_HANDLE_VALUE) then
FindClose(hFind)
nRet = fd.nFileSizeLow
end if
end if
function = nRet
end function
sub zLoadSaveCoordinates (byref x as long, byref y as long, byref w as long, byref h as long, byval RW as long)
local zFileName as asciiz * %MAX_PATH
local hFile, BufferSize, dwBytes as dword
static sWasCoordinates as string
zFileName = zGetTempPath + "zTrace.cfg"
if (RW) then
sWasCoordinates = ltrim$(str$(x)) + "," + ltrim$(str$(y)) + "," + ltrim$(str$(w)) + "," + ltrim$(str$(h)) + "," + _
ltrim$(str$(gP.topmost)) + "," + _
ltrim$(str$(gP.savecoordinates)) + "," + _
ltrim$(str$(gP.usescrollbar)) + "," + _
ltrim$(str$(gP.debug))
hFile = CreateFile(zFilename, %GENERIC_WRITE, 0, byval %NULL, %CREATE_ALWAYS, %FILE_ATTRIBUTE_NORMAL, byval %NULL)
if (hFile <> %INVALID_HANDLE_VALUE) then
WriteFile(hFile, byval strptr(sWasCoordinates), len(sWasCoordinates), dwBytes, byval %NULL)
CloseHandle(hFile)
end if
else
if (len(sWasCoordinates) = 0) then
BufferSize = FileSize(zFilename)
if (BufferSize) then
sWasCoordinates = space$(BufferSize)
hFile = CreateFile(zFilename, %GENERIC_READ, 0, byval %NULL, %OPEN_ALWAYS, %FILE_ATTRIBUTE_NORMAL, byval %NULL)
if (hFile <> %INVALID_HANDLE_VALUE) then
ReadFile(hFile, byval strptr(sWasCoordinates), BufferSize, dwBytes, byval %NULL)
CloseHandle(hFile)
end if
end if
x = val(parse$(sWasCoordinates, 1))
y = val(parse$(sWasCoordinates, 2))
w = val(parse$(sWasCoordinates, 3))
h = val(parse$(sWasCoordinates, 4))
gP.topmost = val(parse$(sWasCoordinates, 5))
gP.savecoordinates = val(parse$(sWasCoordinates, 6)): if (gP.savecoordinates = 0) then w = 0
gP.usescrollbar = val(parse$(sWasCoordinates, 7))
gP.debug = val(parse$(sWasCoordinates, 8))
end if
if ((w = 0) or (h = 0)) then w = %MIN_WIDTH: h = %MIN_HEIGHT: x = 0: y = 0
end if
end sub
function zGetTextListbox(byval hListBox as long, byval nItem as long) as string
local nLength as long, sItem as string
nLength = SendMessage(hListBox, %LB_GETTEXTLEN, nItem, 0)
sItem = space$(nLength)
nLength = SendMessage(hListBox, %LB_GETTEXT, nItem, byval STRPTR(sItem))
function = sItem
end function
' Get the system temp path
function zGetTempPath () as string
local dwSize as dword, sTempPath as string
' if the returned GetTempPath directory does not exist the function creates it.
sTempPath = space$(GetTempPath(0, byval %NULL))
dwSize = GetTempPath(len(sTempPath), byval STRPTR(sTempPath))
function = RTRIM$(sTempPath, ANY CHR$(0,92)) + "\"
end function
' Copy any debug string to a sequential ASCII file.
sub zDebug alias "zDebug" (zMessage as asciiz) static export
local NeverBeenThere as long
local zFileName as asciiz * 16
local sBuffer as string
local BytesWritten, hDebug as dword
if ((hDebug) and (len(zMessage) = 0)) then
CloseHandle(hDebug)
NeverBeenThere = 0
exit sub
end if
if (len(zMessage)) then
if (NeverBeenThere = 0) then
NeverBeenThere = -1
zFileName = "zDebug.txt"
hDebug = CreateFile(zFilename, %GENERIC_WRITE, 0, byval %NULL, %CREATE_ALWAYS, %FILE_ATTRIBUTE_NORMAL, byval %NULL)
end if
if (hDebug) then
sBuffer = zMessage + $CRLF
WriteFile(hDebug, byval strptr(sBuffer), len(sBuffer), BytesWritten, byval %NULL)
end if
end if
end sub
function ToolProc (byval hWnd as dword, byval Msg as long, byval wParam as long, byval lParam as long) as long
local rc, rw as RECT
local K, nCount, nSelItems as long
local sBuffer as string
local hCtrl, hPrinter as dword
local tm as TEXTMETRIC
local di as DOCINFO
local yChar, nLinesPerPage, nCharsPerLine as long
local pd as tagPRINTDLG
select case long (Msg)
case %WM_CREATE:
'A good place to initiate things, declare variables,
'create controls and read/set settings from a file, etc.
'-------------------------------------------------------
if gP.backbrush = 0 then gP.backbrush = CreateSolidBrush(&H00FFFF)
case %WM_GETMINMAXINFO:
local pMM as MINMAXINFO PTR
SetRect(rc, 0, 0, %MIN_WIDTH, %MIN_HEIGHT)
AdjustWindowRectEx(rc, %dwStyle, %FALSE, %dwExStyle) ' Adjust Window To True Requested Size
pMM = lParam
@pMM.ptMinTrackSize.x = rc.nRight
@pMM.ptMinTrackSize.y = rc.nBottom
case %WM_COMMAND:
'Messages from controls and menu items are handled here.
'-------------------------------------------------------
select case long lo(word, wParam)
case %IDCANCEL:
if (hi(word, wParam) = %BN_CLICKED) then
SendMessage(hWnd, %WM_CLOSE, 0, 0)
exit function
end if
case %IDM_About:
sBuffer = " Debugging window" + _
"|| Copyright © " + right$(DATE$, 4) + " Patrice TERRIER " + _
"| [email protected]" + _
"|| www.zapsolution.com"
REPLACE "|" WITH $CR IN sBuffer
MessageBox(0, (sBuffer), $ZTRACE, %MB_OK)
case %IDM_Hscroll:
hCtrl = GetDlgItem(hWnd, %ID_LISTBOX)
gP.usescrollbar = NOT gP.usescrollbar
if (gP.usescrollbar) then
ShowScrollBar(hCtrl, %SB_HORZ, %TRUE)
SendMessage(hCtrl, %LB_SETHORIZONTALEXTENT, %HORIZONTAL_EXTENT, 0)
else
SendMessage(hCtrl, %LB_SETHORIZONTALEXTENT, 1, 0)
ShowScrollBar(hCtrl, %SB_HORZ, %FALSE)
end if
UpdateWindow(hCtrl)
case %IDM_Print:
hCtrl = GetDlgItem(hWnd, %ID_LISTBOX)
nCount = SendMessage(hCtrl, %LB_GETCOUNT, 0, 0)
if (nCount > 0) then
pd.lStructSize = sizeof(pd)
'// get rid of PD_RETURNDEFAULT on the line below if you'd like to
'// see the "Printer Settings" dialog!
pd.Flags = %PD_RETURNDEFAULT or %PD_RETURNDC
if (PrintDlg(pd)) then
hPrinter = pd.hDC
GetTextMetrics(pd.hDC, tm)
yChar = tm.tmHeight + tm.tmExternalLeading
nLinesPerPage = GetDeviceCaps(pd.hDC, %VERTRES) / yChar
nCharsPerLine = GetDeviceCaps(pd.hDC, %HORZRES) / tm.tmAveCharWidth
di.cbSize = sizeof(di)
StartDoc(hPrinter, di)
StartPage(hPrinter)
nSelItems = SendMessage(hCtrl, %LB_GETSELCOUNT, 0, 0)
if (nSelItems > 0) then
redim SelItem(nSelItems - 1) as long
nCount = SendMessage(hCtrl, %LB_GETSELITEMS, nSelItems, varptr(SelItem(0)))
for K = 0 TO nSelItems - 1
sBuffer = zGetTextListbox(hCtrl, SelItem(K))
TextOut(pd.hDC, 0, (yChar * K), byval strptr(sBuffer), len(sBuffer))
next
else
for K = 0 TO nCount - 1
sBuffer = zGetTextListbox(hCtrl, K)
TextOut(pd.hDC, 0, (yChar * K), byval strptr(sBuffer), len(sBuffer))
next
end if
EndPage(hPrinter)
EndDoc(hPrinter)
DeleteDC(hPrinter)
end if
end if
case %IDM_CopyToClipboard:
hCtrl = GetDlgItem(hWnd, %ID_LISTBOX)
nCount = SendMessage(hCtrl, %LB_GETCOUNT, 0, 0)
if (nCount > 0) then
sBuffer = ""
nSelItems = SendMessage(hCtrl, %LB_GETSELCOUNT, 0, 0)
if (nSelItems > 0) then
REDIM SelItem(1 TO nSelItems) as long
nCount = SendMessage(hCtrl, %LB_GETSELITEMS, nSelItems&, varptr(SelItem&(1)))
for K = 1 TO nSelItems
sBuffer = sBuffer + zGetTextListbox(hCtrl, SelItem(K)) + $CRLF
next
else
for K = 0 TO nCount - 1
sBuffer = sBuffer + zGetTextListbox(hCtrl, K) + $CRLF
next
end if
local hClipData, hGlob as dword
hClipData = GlobalAlloc(%GMEM_MOVEABLE or %GMEM_DDESHARE, len(sBuffer) + 1)
hGlob = GlobalLock(hClipData)
POKE$ hGlob, sBuffer + CHR$(0)
GlobalUnlock(hClipData)
if (OpenClipboard(0)) then
EmptyClipboard()
SetClipboardData(%CF_TEXT, hClipData)
CloseClipboard()
else
GlobalFree(hClipData)
end if
end if
case %IDM_ClearContent:
SendMessage(GetDlgItem(hWnd, %ID_LISTBOX), %LB_RESETCONTENT, 0, 0)
case %IDM_TopMost:
gP.topmost = NOT gP.topmost
if (gP.topmost) then
SetWindowPos(hWnd, %HWND_TOPMOST, 0, 0, 0, 0, %SWP_NOSIZE or %SWP_NOMOVE or %SWP_SHOWWINDOW)
else
SetWindowPos(hWnd, %HWND_NOTOPMOST, 0, 0, 0, 0, %SWP_NOSIZE or %SWP_NOMOVE or %SWP_SHOWWINDOW)
end if
case %IDM_Debug:
gP.debug = NOT gP.debug
if (gP.debug) then
hCtrl = GetDlgItem(hWnd, %ID_LISTBOX)
nCount = SendMessage(hCtrl, %LB_GETCOUNT, 0, 0)
if (nCount > 0) then
for K = 0 TO nCount - 1
zDebug(zGetTextListbox(hCtrl, K))
next
end if
else
zDebug("") '// Close zDebug.txt if already open.
end if
case %IDM_SaveCoordinates:
gP.savecoordinates = NOT gP.savecoordinates
end select
case %WM_CTLCOLORLISTBOX:
' wParam is handle of control's display context (hDC)
' lParam is handle of control
'------------------------------------------------------
if (lParam = GetDlgItem(hWnd, %ID_LISTBOX)) then
SetBkColor(wParam, &H00FFFF)
function = gP.backbrush
exit function
end if
case %WM_RBUTTONDOWN:
local hMenu, nChoice as long, p as POINTAPI
local menuStyle as long
hMenu = CreatePopupMenu()
if (hMenu) then
AppendMenu(hMenu, %MF_STRING, %IDM_About , "About")
AppendMenu(hMenu, %MF_SEPARATOR, 102 , "")
if (gP.usescrollbar) then menuStyle = %MF_STRING or %MF_CHECKED else menuStyle = %MF_STRING
AppendMenu(hMenu, menuStyle, %IDM_Hscroll , "Use horizontal scrollbar")
AppendMenu(hMenu, %MF_STRING, %IDM_Print , "Send selection to printer")
AppendMenu(hMenu, %MF_STRING, %IDM_CopyToClipboard, "Copy selection to clipboard")
AppendMenu(hMenu, %MF_STRING, %IDM_ClearContent , "Clear content")
if (gP.topmost) then menuStyle = %MF_STRING or %MF_CHECKED else menuStyle = %MF_STRING
AppendMenu(hMenu, menuStyle, %IDM_TopMost , "Set window TopMost")
if (gP.debug) then menuStyle = %MF_STRING or %MF_CHECKED else menuStyle = %MF_STRING
AppendMenu(hMenu, menuStyle, %IDM_Debug, "create zDebug.txt report")
if (gP.savecoordinates) then menuStyle = %MF_STRING or %MF_CHECKED else menuStyle = %MF_STRING
AppendMenu(hMenu, menuStyle, %IDM_SaveCoordinates, "Save window coordinates")
GetCursorPos(p)
nChoice = TrackPopupMenuEx(hMenu, %TPM_RETURNCMD, p.X, p.Y, hWnd, byval %NULL)
DestroyMenu(hMenu)
if (nChoice) then SendMessage(hWnd, %WM_COMMAND, MAKLNG(nChoice, 0), 0)
end if
case %WM_MOVE:
GetWindowRect(hWnd, rw): gP.x = rw.nLeft: gP.y = rw.nTop
case %WM_SIZE:
if (wParam <> %SIZE_MINIMIZED) then
gP.w = LOWRD(lParam): gP.h = HIWRD(lParam)
MoveWindow(GetDlgItem(hWnd, %ID_LISTBOX), 0, 0, gP.w, gP.h, %TRUE)
UpdateWindow(hWnd)
GetWindowRect(hWnd, rw): gP.x = rw.nLeft: gP.y = rw.nTop
end if
case %WM_DESTROY:
if (gP.backbrush) then
DeleteObject(gP.backbrush): gP.backbrush = 0
zLoadSaveCoordinates (gP.x, gP.y, gP.w, gP.h, 1)
end if
zDebug("")
PostQuitMessage(0)
function = 0: exit function
end select
function = DefWindowProc(hWnd, Msg, wParam, lParam)
end function
function AddString(byval hCtrl as dword, byval zPtr as dword) as long
local nRet as long
if (gP.debug) then
if (zPtr) then zDebug(PEEK$(zPtr, 260))
end if
nRet = SendMessage(hCtrl, %LB_ADDSTRING, 0, zPtr)
SendMessage(hCtrl, %LB_SETTOPINDEX, nRet, 0)
function = nRet
end function
function ShowPopup (byval zPtr as dword) as long
local Msg as tagMsg
local IsInitialized as long
local hWnd, hCtrl as dword
local wcx as WndClassEx, szClassName as asciiz * 80
local rc, rw as RECT
local hInstance as dword
hInstance = GetModuleHandle("")
szClassName = $ZTRACE
wcx.cbSize = sizeof(wcx)
IsInitialized = GetClassInfoEx(hInstance, szClassName, wcx)
if (IsInitialized = 0) then
wcx.cbSize = sizeof(wcx)
wcx.style = %CS_HREDRAW or %CS_VREDRAW or %CS_DBLCLKS ' or %CS_DROPSHADOW
wcx.lpfnWndProc = codeptr(ToolProc)
wcx.cbClsExtra = 0
wcx.cbWndExtra = 0
wcx.hInstance = hInstance
wcx.hIcon = 0
wcx.hCursor = LoadCursor(%NULL, byval %IDC_ARROW)
wcx.hbrBackground = %COLOR_BTNSHADOW
wcx.lpszMenuName = %NULL
wcx.lpszClassName = varptr(szClassName)
wcx.hIconSm = wcx.hIcon
if (RegisterClassEx(wcx)) then IsInitialized = %TRUE
end if
if (IsInitialized) then
local UseX, UseY, UseW, UseH as long
zLoadSaveCoordinates (UseX, UseY, UseW, UseH, 0)
SetRect(rc, 0, 0, UseW, UseH)
AdjustWindowRectEx(rc, %dwStyle, %FALSE, %dwExStyle)
hWnd = CreateWindowEx(%dwExStyle, szClassName, szClassName, _
%dwStyle, _
UseX, UseY, _
rc.nRight - rc.nLeft, _ ' Calculate Window Width
rc.nBottom - rc.nTop, _ ' Calculate Window Height
0, 0, hInstance, byval %NULL)
if (hWnd) then
hCtrl = CreateWindowEx(0, "ListBox", byval %NULL, _
%WS_CHILD or %WS_VISIBLE or %WS_VSCROLL or %WS_HSCROLL or %LBS_MULTIPLESEL or _
%LBS_HASSTRINGS or %LBS_NOINTEGRALHEIGHT or %LBS_EXTENDEDSEL or %LBS_DISABLENOSCROLL, _
0, 0, UseW, UseH, _
hWnd, %ID_LISTBOX, hInstance, byval %NULL)
SendMessage(hCtrl, %WM_SETFONT, GetStockObject(%ANSI_FIXED_FONT), 0)
AddString(hCtrl, zPtr) '// varptr(zMessage))
if (gP.usescrollbar) then
SendMessage(hCtrl, %LB_SETHORIZONTALEXTENT, %HORIZONTAL_EXTENT, 0)
ShowScrollBar(hCtrl, %SB_HORZ, %TRUE)
else
ShowScrollBar(hCtrl, %SB_HORZ, %FALSE)
end if
if (gP.topmost) then
SetWindowPos(hWnd, %HWND_TOPMOST, 0, 0, 0, 0, %SWP_NOSIZE or %SWP_NOMOVE or %SWP_SHOWWINDOW)
else
ShowWindow(hWnd, %SW_SHOW)
end if
UpdateWindow(hWnd)
while GetMessage(Msg, %NULL, 0, 0)
'// Easier to detect the right mouse button click on the listBox from the message pump
if ((Msg.hWnd = hCtrl) and (Msg.Message = %WM_RBUTTONDOWN)) then
ToolProc(hWnd, %WM_RBUTTONDOWN, 0, 0)
else
TranslateMessage(Msg)
DispatchMessage(Msg)
end if
wend
function = msg.wParam
end if
end if
end function
function zTrace alias "zTrace" (zTmp as asciiz) export as long
local nRet as long
local hWnd, zPtr as dword
zPtr = varptr(zTmp)
hWnd = FindWindow($ZTRACE, $ZTRACE)
if (hWnd = 0) then
nRet = %LB_ERR
local hThread, dwThreadID as dword
hThread = CreateThread(byval %NULL, 0, codeptr(ShowPopup), zPtr, 0, dwThreadID)
if (hThread) then nRet = 0: apiSLEEP(100)
CloseHandle(hThread)
else
if (len(zTmp)) then nRet = AddString(GetDlgItem(hWnd, %ID_LISTBOX), zPtr)
end if
function = nRet
end function
function DLLMAIN (byval DllInstance as long, byval Reason as long, byval Reserved as long) as long
local nRet as long
nRet = %TRUE
if (Reason = %DLL_PROCESS_DETACH) then
if (gP.backbrush) then
DeleteObject(gP.backbrush): gP.backbrush = 0
zLoadSaveCoordinates (gP.x, gP.y, gP.w, gP.h, 1)
end if
zDebug("")
end if
function = nRet
end function
https://forum.powerbasic.com/forum/u...ugging-utility
Comment