TMGTPSTP.m

;"------------------------------------------------------------
;"------------------------------------------------------------
;"
;" 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
;"
;"------------------------------------------------------------
;"------------------------------------------------------------
   
STEPTRAP(Pos)

       do VCUSAV2^TMGTERM
       do ShowCodePos(Pos)
       do VCULOAD2^TMGTERM

       new KeyIn
       new PauseMode set PauseMode=0
       new RunMode set RunMode=$get(^TMP("TMGIDE",$J,"Run Mode"))

       if RunMode=2 goto SPDone ;"Don't showmode --> goto SPDone
       if RunMode=1 hang 1
SPLoop
       read *KeyIn:0
       if KeyIn=27 set PauseMode=2
       if KeyIn=32 do
       . w $c(7)
       . set PauseMode='PauseMode
       if PauseMode=1 goto SPLoop
SPDone
       set ^TMP("TMGIDE",$J,"Run Mode")=PauseMode
       quit

 
ShowCode(Pos,Wipe)
       ;"Purpose: This will display code at the top of the screen
       ;"Input: Pos -- string like this: X+2^ROUTINE[$DMOD]
       ;"      Wipe -- OPTIONAL.  if 1, then code area is wiped blank

       new Action,i
       new Routine,Label,Offest,s
       set ScrWidth=^TMP("TMGIDE",$J,"ScrWidth")
       set ScrHeight=^TMP("TMGIDE",$J,"ScrHeight")
       new LastRou,LastLabel,LastOffset
       new dbFGColor,bBGColor,nlFGColor,nlBGColor
       set nlFGColor=^TMP("TMGIDE",$J,"Normal Foreground Color")
       set nlBGColor=^TMP("TMGIDE",$J,"Normal Background Color")
       set dbFGColor=^TMP("TMGIDE",$J,"Debug Foreground Color")
       set dbBGColor=^TMP("TMGIDE",$J,"Debug Background Color")

       new BlankLine set BlankLine=" "
       for i=1:1:ScrWidth-1 set BlankLine=BlankLine_" "

       ;"write "dbFG=",dbFGColor," dbBG=",dbBGColor,!
       do VCOLORS^TMGTERM(dbFGColor,dbBGColor)
       ;do VFGCOLOR^TMGTERM(dbFGColor)
       ;do VBGCOLOR^TMGTERM(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 LastRou=$get(^TMP("TMGIDE",$J,"DISP ROUTINE"))
       set LastLabel=$get(^TMP("TMGIDE",$J,"DISP LABEL"))
       set LastOffset=$get(^TMP("TMGIDE",$J,"DISP OFFSET"))

       set s="=== Routine: ^"_Routine_" " write s
       for i=1:1:ScrWidth-$length(s) write "="
       write !

       for i=0:1:ScrHeight do
       . new line,Bl,ref
       . set ref=Label_"+"_i_"^"_Routine
       . set line=$text(@ref)
       . if (i=Offset) do VCOLORS^TMGTERM(nlFGColor,nlBGColor)
       . if (i=Offset) 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 !

       set ^TMP("TMGIDE",$J,"DISP ROUTINE")=Routine
       set ^TMP("TMGIDE",$J,"DISP LABEL")=Label
       set ^TMP("TMGIDE",$J,"DISP OFFSET")=Offset

SCDone
       do VCULOAD^TMGTERM
       do VCOLORS^TMGTERM(nlFGColor,nlBGColor)

       do CUD^TMGTERM(2)

       quit