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.
;"------------------------------------------------------------
;"------------------------------------------------------------
STEPTRAP(idePos,Msg)
;"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.
;"Input: idePos -- a text line containing position, as returned bye $ZPOS
;" Msg -- OPTIONAL -- can be used by programs to pass in info.
;" If Msg=1, then this function was called without the
;" $ZSTEP value set, so this function should set it.
new NakedRef set NakedRef=$$LGR^%ZOSV ;"save naked reference
new tpBlankLine
new tpAction
new tpKeyIn
new tpRunMode,tpStepMode
new tpI
new tpDone
new result set result=1 ;1=step into, 2=step over
new ViewOffset set ViewOffset=0
;"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_" "
new ArrayName set ArrayName="^TMP(""TMGIDE"",$J,""MODULES"")"
set idePos=$$ConvertPos(idePos,ArrayName)
do VCUSAV2^TMGTERM
if tpRunMode'=2 do
. do ShowCodePos(idePos,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(idePos,ScrWidth,ScrHeight,,ViewOffset)
. do CUP^TMGTERM(1,ScrHeight+4) ;"Cursor to line (x,y)
. write tpBlankLine,!
. do CUU^TMGTERM(2)
. if tpWatchLine'="" do
. . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode="""""
. . xecute tpWatchLine
. . write !
. write tpBlankLine,!
. do VTATRIB^TMGTERM(7) ;"reverse text
. for i=1:1:ScrWidth write "~"
. do VTATRIB^TMGTERM(0) ;"reset text
. write !
. do CUU^TMGTERM(2)
. write "Action (? for help): "
. if tpStepMode="into" write "step INTO// " set DefAction="I"
. else write "step OVER// " set DefAction="O"
. new loop
. for loop=1:1:20 write " "
. for loop=1:1:20 write $char(8) ;"backspace
. set tpAction=$$READ^XGF(1) write !
. ;"read tpAction,!
. if tpActionn="" 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
. . new temp
. . do CUU^TMGTERM(1)
. . do CHA^TMGTERM(1) ;"move to x=1 on this line
. . write tpBlankLine,!
. . do CUU^TMGTERM(1)
. . read " enter M code (^ to cancel): ",tpLine,!
. . if (tpLine'="^") do
. . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
. . . write ! ;"get below bottom line for output.
. . . 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 "Bb"[tpAction do quit
. . new idePos
. . read "Enter breakpoint (e.g. Label+8^MyFunct): ",idePos,!
. . set idePos=Pos_":""n tmg s tmg=$$STEPTRAP^TMGTPSTP($ZPOS,1)"""
. . ZBREAK @idePos
. if "Hh"[tpAction do quit
. . set tpRunMode=2
. . set tpDone=1
. if "Ww"[tpAction do quit
. . new temp
. . do CUU^TMGTERM(1)
. . do CHA^TMGTERM(1) ;"move to x=1 on this line
. . write tpBlankLine,!
. . do CUU^TMGTERM(1)
. . read "Enter M code (^ to cancel): ",temp,!
. . if temp'="^" set tpWatchLine=temp
. if "Aa"[tpAction do quit
. . set ViewOffset=ViewOffset-1
. if "Zz"[tpAction do quit
. . set ViewOffset=ViewOffset+1
. else do quit
. . write !
. . new tpNLines
. . for tpNLines=1:1:5 write tpBlankLine,!
. . do CUU^TMGTERM(5)
. . write " L -- run in sLow mode M -- enter any line of M code",!
. . write " O -- step OVER line I -- step INTO line",!
. . write " R -- run H -- Hide debug code",!
. . write " B -- set Breakpoint W - enter variable watch code ",!
. . write " A -- scroll upward Z -- scroll downward",!
SPDone
do VCULOAD2^TMGTERM
set TMGRunMode=tpRunMode
if tpStepMode="into" set result=1
else set result=2
set TMGStepMode=tpStepMode
if $get(Msg)=1 do
. set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGTPSTP($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue"
. zstep:(result=1) into zstep:(result=2) over
new discard set discard=$get(@NakedRef) ;"reset naked reference.
quit result
BlankLine
write tpBlankLine
do CHA^TMGTERM(1) ;"move to x=1 on this line
quit
ErrTrap(idePos)
;"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(idePos,ScrWidth,ScrHeight)
ETDone
do VCULOAD2^TMGTERM
quit
ShowCode(idePos,ScrWidth,ScrHeight,Wipe,ViewOffset)
;"Purpose: This will display code at the top of the screen
;"Input: idePos -- string like this: X+2^ROUTINE[$DMOD]
;" ScrWidth -- width of code display (Num of columns)
;" ScrHeight -- height of code display (number of rows)
;" Wipe -- OPTIONAL. if 1, then code area is wiped blank
;" ViewOffset -- OPTIONAL. If a value is supplied, then
;" the display will be shifted up or down (i.e. to view
;" code other than at the point of execution)
;" Positive numbers will scroll page downward.
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 BlankLine=" "
for i=1:1:ScrWidth-1 set BlankLine=BlankLine_" "
do VTATRIB^TMGTERM(7) ;"reverse text
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 VTATRIB^TMGTERM(0) ;"reset colors
. for i=0:1:ScrHeight+1 write BlankLine
set s=$piece(idePos,"$",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)+2
else set StartOffset=0
set StartOffset=StartOffset+$get(ViewOffset)
for i=StartOffset:1:(ScrHeight+StartOffset) do
. new line,Bl,ref,LoopOffset
. set ref=Label_"+"_i_"^"_Routine
. set line=$text(@ref)
. set line=$$Substitute^TMGSTUTL(line,$Char(9)," ")
. if (i=Offset) do
. . do VTATRIB^TMGTERM(0) ;"reset colors
. . 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 VTATRIB^TMGTERM(7) ;"reverse colors
for i=1:1:ScrWidth write "~"
write !
SCDone
do VTATRIB^TMGTERM(0) ;"reset colors
quit
ScanMod(Module,pArray)
;"Purpose: To scan a module and find all the labels/entry points/Entry points
;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF")
;" pArray -- pointer to (name of) array Will be filled like this
;" pArray(1,"TAG")="Label1"
;" pArray(1,"OFFSET")=1
;" pArray(2,"TAG")="Label2"
;" pArray(2,"OFFSET")=9
;" pArray(3,"TAG")="Label3" etc.
;" pArray(3,"OFFSET")=15
;" pArray("Label1")=1
;" pArray("Label2")=2
;" pArray("Label3")=3
;"Output: Results are put into array
;"Result: none
new i set i=1
new LabelNum set LabelNum=0
new line set line=""
if $get(Module)="" goto SMDone
for do quit:(line="")
. new ch
. set line=$text(+i^@Module)
. if line="" quit
. set line=$$Substitute^TMGSTUTL(line,$Char(9)," ") ;"replace tabs for spaces
. set ch=$extract(line,1)
. if (ch'=" ")&(ch'=";") do
. . new label
. . set label=$piece(line," ",1)
. . set LabelNum=LabelNum+1
. . set @pArray@(LabelNum,"TAG")=label
. . set @pArray@(LabelNum,"OFFSET")=i
. . set @pArray@(label)=LabelNum
. set i=i+1
SMDone
quit
ConvertPos(Pos,pArray)
;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into
;" one that is relative to the start of the file
;" e.g. START+8^MYFUNCT --> +32^MYFUNCT
;"Input: Pos -- a position, as returned from $ZPOS
;" pArray -- pointer to (name of). Array holding holding tag offsets
;" pArray will be in this format:
;" pArray("ModuleA",1,"TAG")="ALabel1"
;" pArray("ModuleA",1,"OFFSET")=1
;" pArray("ModuleA",2,"TAG")="ALabel2"
;" pArray("ModuleA",2,"OFFSET")=9
;" pArray("ModuleA","Label1")=1
;" pArray("ModuleA","Label2")=2
;" pArray("ModuleA","Label3")=3
;" pArray("ModuleB",1,"TAG")="BLabel1"
;" pArray("ModuleB",1,"OFFSET")=4
;" pArray("ModuleB",2,"TAG")="BLabel2"
;" pArray("ModuleB",2,"OFFSET")=23
;" pArray("ModuleB","Label1")=1
;" pArray("ModuleB","Label2")=2
;" pArray("ModuleB","Label3")=3
;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it
;"Result: returns the new position line, relative to the start of the file/module
;"
new s
new result set result=""
new Routine,Label,Offset
set s=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
if s="" goto CPDone
set Routine=$piece(s,"^",2)
if Routine="" goto CPDone
set s=$piece(s,"^",1)
set Offset=$piece(s,"+",2)
if Offset="" set Offset=1
else set Offset=+Offset
set Label=$piece(s,"+",1)
if $data(@pArray@(Routine))=0 do
. new p2Array set p2Array=$name(@pArray@(Routine))
. do ScanMod(Routine,p2Array)
new i set i=+$get(@pArray@(Routine,Label))
if i=0 goto CPDone
new GOffset set GOffset=@pArray@(Routine,i,"OFFSET")
set result="+"_+(GOffset+Offset)_"^"_Routine
CPDone
quit result
