TMGTPSTP.m
From VistApedia
;"------------------------------------------------------------
;"------------------------------------------------------------
;"
;" GT.M STEP TRAP
;"
;" K. Toppenberg
;" 4-13-2005
;" License: GPL Applies
;"
;" This code module will allow tracing through code.
;" It is used as follows:
;"
;" set $ZSTEP="do STEPTRAP^TMGTRSTP($ZPOS) zstep into zcontinue"
;" zstep into
;" do ^MyFunction ;"<--- put the function you want to trace here
;"
;" set $ZSTEP="" ;"<---turn off step capture
;" quit
;"
;"
;" Dependencies:
;" Uses TMGTERM
;"
;"Notes:
;" This function will be called inbetween lines of the main
;" program that is being traced. Thus is function can't do
;" anything that might change the environment of the main
;" program. This includes accessing global variables --
;" because it will mess up the "naked reference".
;"------------------------------------------------------------
;"------------------------------------------------------------
STEPTRAP(Pos)
;"Purpose: This is the line that is called by GT.M for each zstep event.
;" It will be used to display the current code execution point, and
;" query user as to plans for future execution: run/step/ etc.
new tpBlankLine
new tpAction
new tpKeyIn
new tpRunMode,tpStepMode
new tpI
new tpDone
new result set result=1 ;1=step into, 2=step over
;"Run modes: 0=running mode
;" 1=stepping mode
;" 2=Don't show code
;" 3=running SLOW mode
;" -1=quit
set tpRunMode=$get(TMGRunMode,1)
set tpStepMode=$get(TMGStepMode,"into")
new ScrHeight,ScrWidth
set ScrHeight=$get(TMGScrHeight,10)
set ScrWidth=$get(TMGScrWidth,80)
set tpBlankLine=" "
for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" "
do VCUSAV2^TMGTERM
if tpRunMode'=2 do
. do ShowCodePos(Pos,ScrWidth,ScrHeight)
else do
. do CUP^TMGTERM(1,2)
write tpBlankLine,!
write tpBlankLine,!
do CUU^TMGTERM(2)
if (tpRunMode=0)!(tpRunMode=3)!(tpRunMode=2) do
. write tpBlankLine,!
. do CUU^TMGTERM(1)
. write "(Press any key to pause)",!
. read *tpKeyIn:0
. if (tpKeyIn>0) set tpRunMode=1
. else if tpRunMode=3 hang 1
if tpRunMode=2 goto SPDone ;"Don't showmode --> goto SPDone
set tpDone=0
if tpRunMode=1 for do quit:tpDone=1
. new DefAction set DefAction="O"
. do ShowCodePos(Pos,ScrWidth,ScrHeight)
. do CUP^TMGTERM(1,ScrHeight+4) ;"Cursor to line (x,y)
. write tpBlankLine,!
. do CUU^TMGTERM(1)
. write "Action (? for help): "
. if tpStepMode="into" write "step INTO// " set DefAction="I"
. else write "step OVER// " set DefAction="O"
. read tpAction,!
. if tpAction="" set tpAction=DefAction
. if "rR"[tpAction do quit
. . set tpRunMode=0
. . set tpDone=1
. if "lL"[tpAction do quit
. . set tpRunMode=3
. . set tpDone=1
. if "mM"[tpAction do quit
. . write tpBlankLine,!
. . do CUU^TMGTERM(1)
. . new tpLine
. . read " enter M code: ",tpLine,!
. . xecute tpLine
. if "iI"[tpAction do quit
. . set tpStepMode="into"
. . ;"set $ZSTEP="do STEPTRAP^TMGTPSTP($ZPOS) zstep into zcontinue"
. . set tpDone=1
. if "Oo"[tpAction do quit
. . set tpStepMode="over"
. . ;"set $ZSTEP="do STEPTRAP^TMGTPSTP($ZPOS) zstep over zcontinue"
. . set tpDone=1
. if "Hh"[tpAction do quit
. . set tpRunMode=2
. . set tpDone=1
. else do quit
. . new tpNLines
. . for tpNLines=1:1:5 write tpBlankLine,!
. . do CUU^TMGTERM(5)
. . write " L -- run in sLow mode",!
. . write " M -- enter any line of M code",!
. . write " O -- step OVER line",!
. . write " I -- step INTO line",!
. . write " R -- run",!
. . write " H -- Hide debug code",!
SPDone
do VCULOAD2^TMGTERM
set TMGRunMode=tpRunMode
if tpStepMode="into" set result=1
else set result=2
set TMGStepMode=tpStepMode
quit result
ErrTrap(Pos)
;"Purpose: This is the line that is called by GT.M for each ztrap event.
;" It will be used to display the current code execution point
new ScrHeight,ScrWidth
set ScrHeight=$get(TMGScrHeight,10)
set ScrWidth=$get(TMGScrWidth,70)
do VCUSAV2^TMGTERM
do ShowCodePos(Pos,ScrWidth,ScrHeight)
ETDone
do VCULOAD2^TMGTERM
quit
ShowCode(Pos,ScrWidth,ScrHeight,Wipe)
;"Purpose: This will display code at the top of the screen
;"Input: Pos -- string like this: X+2^ROUTINE[$DMOD]
;" ScrWidth -- width of code display (Num of columns)
;
;" Wipe -- OPTIONAL. if 1, then code area is wiped blank
new i
new Routine,Label,Offest,s
new LastRou,LastLabel,LastOffset
new dbFGColor,bBGColor,nlFGColor,nlBGColor
new BlankLine
new StartOffset
set ScrWidth=$get(ScrWidth,80)
set ScrHeight=$get(ScrHeight,10)
set nlFGColor=$get(TMGNlFGColor,3)
set nlBGColor=$get(TMGNlBGColor,0)
set dbFGColor=$get(TMGDbFGColor,0)
set dbBGColor=$get(TMGDbBGColor,3)
set BlankLine=" "
for i=1:1:ScrWidth-1 set BlankLine=BlankLine_" "
do VCOLORS^TMGTERM(dbFGColor,dbBGColor)
do CUP^TMGTERM(1,1) ;"Cursor to line (1,1)
write BlankLine,! ;"This is needed for some reason...
do CUU^TMGTERM(2)
if $get(Wipe)=1 do goto SCDone
. do VCOLORS^TMGTERM(nlFGColor,nlBGColor)
. for i=0:1:ScrHeight+1 write BlankLine
set s=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
set Routine=$piece(s,"^",2)
set Label=$piece(s,"^",1)
set Offset=+$piece(Label,"+",2)
set Label=$piece(Label,"+",1)
set s="=== Routine: ^"_Routine_" " write s
for i=1:1:ScrWidth-$length(s) write "="
write !
if Offset>(ScrHeight) do
set StartOffset=(Offset-ScrHeight)
else set StartOffset=0
for i=StartOffset:1:(ScrHeight+StartOffset) do
. new line,Bl,ref,LoopOffset
. set ref=Label_"+"_i_"^"_Routine
. set line=$text(@ref)
. if (i=Offset) do
. . do VCOLORS^TMGTERM(nlFGColor,nlBGColor)
. . write ">"
. else write " "
. if $length(line)>(ScrWidth-1) do
. . write $extract(line,1,ScrWidth-4),"...",!
. else do
. . write $extract(line,1,ScrWidth-1)
. . write $extract(BlankLine,1,ScrWidth-$length(line)-1),!
. if (i=Offset) do VCOLORS^TMGTERM(dbFGColor,dbBGColor)
for i=1:1:ScrWidth write "~"
write !
SCDone
;"do VCULOAD^TMGTERM
do VCOLORS^TMGTERM(nlFGColor,nlBGColor)
;"do CUD^TMGTERM(2)
quit
