TMGIDE2 ;TMG/kst/A debugger/tracer for GT.M (core functionality) ;03/25/06 ;;1.0;TMG-LIB;**1**;03/23/09 ;" GT.M TRAP STEP ;" ;" 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^TMGIDE2($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,^TMGIDE ;" ;"Notes: ;" This function will be called inbetween lines of the main ;" program that is being traced. Thus this function can't do ;" anything that might change the environment of the main ;" program. ;"------------------------------------------------------------ ;"------------------------------------------------------------ ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"STEPTRAP(tmgIDEPos,TMGMsg) ;"ErrTrap(tmgIDEPos) ;"======================================================================= ;"PRIVATE API FUNCTIONS ;"======================================================================= ;"EvalWatches ;"BlankLine ;"ShowCode(ShowPos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset) ;"GetStackInfo(Stack,tmgOrigIDEPos) ;"SetBreakpoint(pos,Condition) ;"RelBreakpoint(pos) ;"======================================================================= ;"======================================================================= STEPTRAP(tmgIDEPos,TMGMsg) ;"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: tmgIDEPos -- a text line containing position, as returned bye $ZPOS ;" TMGMsg -- OPTIONAL -- can be used by programs to pass in info. ;" If TMGMsg=1, then this function was called without the ;" $ZSTEP value set, so this function should set it. ;"Global-scoped vars used: ;" tmgDbgRemoteJob = remote $J if controlling a remote process ;" Won't exist (or will be 0) otherwise. ;" tmgRunMode -- ;" tmgStepMode -- ;" TMGScrHeight -- ;" TMGScrWidth -- ;" TMGLROffset -- ;" TMGdbgHideList (an array REF) -- holds modules to hide ;"Result: desired mode for next time: ;" 1=step into ;" 2=step over ;" 3-step outof ;" (anything else) -- stop debugging. <-- I think... ;" 0-->signals request to stop when remote debugging. ;"tmgRunMode: 0=running mode (NOTE: tmgRunMode comes from tmgRunMode) ;" 1=stepping mode ;" 2=Don't show code ;" 3=running SLOW mode ;" -1=quit new tmgdbgTruth set tmgdbgTruth=$TEST ;"save initial value of $TEST if $ZTRAP'["^TMG" do SetErrTrap^TMGIDE ;"ensure no redirecting of error trap new tmgDbgResult set tmgDbgResult=1 ;"1=step into, 2=step over new tmgDbgNakedRef set tmgDbgNakedRef=$$LGR^TMGIDE ;"save naked reference set tmgDbgHangTime=+$get(tmgDbgHangTime,0.25) set tmgRunMode=$get(tmgRunMode,1) ;"Keep track of changes to variable system table if (tmgRunMode'=0)&(+$get(tmgDbgOptions("VARTRACE"))=1) do RecordVTrace^TMGIDE6 set tmgStepMode=$get(tmgStepMode,"into") set tmgDbgRemoteJob=+$get(tmgDbgRemoteJob) new TMGdbgJNum set TMGdbgJNum=$J if tmgDbgRemoteJob set TMGdbgJNum=tmgDbgRemoteJob new ArrayName set ArrayName=$name(^TMG("TMGIDE",TMGdbgJNum,"MODULES")) new %TMG set %TMG=$get(%) new tpBlankLine,tpAction,tpKeyIn,tpI,tpDone new ViewOffset set ViewOffset=0 new savedIO,savedX,savedY set savedIO=$IO set savedX=$X,savedY=$Y new ScrHeight,ScrWidth,LROffset set ScrHeight=$get(TMGScrHeight,10) set ScrWidth=+$get(TMGScrWidth) if (ScrWidth'>0)!(tmgRunMode=1) do ;"If pause after every show, take time to check dimensions. . if $$GetScrnSize^TMGKERNL(,.ScrWidth) . set TMGScrWidth=ScrWidth set LROffset=$get(TMGLROffset,0) use $P:(WIDTH=ScrWidth:NOWRAP) ;"reset IO to the screen set tpBlankLine=" " for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " new relPos set relPos=tmgIDEPos new tmgOrigIDEPos set tmgOrigIDEPos=tmgIDEPos new tempPos set tempPos=$$ConvertPos^TMGIDE(tmgIDEPos,ArrayName) if tempPos'="" set tmgIDEPos=tempPos ;"don't show hidden modules (setup in TMGIDE module) if $$ShouldSkip($piece(tmgIDEPos,"^",2)) goto SPDone ;"Record trace, if not a hidden module if +$get(tmgDbgOptions("TRACE"))=1 do RecordTrace^TMGIDE6(tmgOrigIDEPos) ;"Note: Conditional Breakpoints: I will have to try to get this working later. ;"I have it such that the condition is recognized. But now I need to ;"Differientate between stepping through code, and a breakpoint from ;"a full speed run. new stpSkip set stpSkip=0 if $$IsBreakpoint(tmgIDEPos) do ;"goto:(stpSkip=1) SPDone . new ifS set ifS=$$GetBrkCond(tmgIDEPos) if ifS="" quit . new $etrap set $etrap="write ""ERROR in breakpoint condition code."",! quit" . if (@ifS=0) set stpSkip=1 . if @ifS write "Condition FOUND!!" ;"do PressToCont^TMGUSRIF do VCUSAV2^TMGTERM new CsrOnBreakline set CsrOnBreakline=0 if tmgRunMode'=2 do ;"2=Don't show code . do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) . write CsrOnBreakline,! ;"temps else do . do CUP^TMGTERM(1,2) write tpBlankLine,! write tpBlankLine,! do CUU^TMGTERM(2) if tmgRunMode'=1 do ;"Not stepping mode . write tpBlankLine,! . do CUU^TMGTERM(1) . do EvalWatches . write "(Press any key to pause" . if tmgRunMode=3 write "; '+' for faster, '-' for slower)",! . else write ")",! . read *tpKeyIn:0 . if tmgRunMode=3 do . . if tpKeyIn=43 set tmgDbgHangTime=tmgDbgHangTime/2 ;"43= '+' . . else if tpKeyIn=45 set tmgDbgHangTime=tmgDbgHangTime*2 ;"45= '-' . . hang tmgDbgHangTime . if (tpKeyIn>0) set tmgRunMode=1 if tmgRunMode'=2 do ;"2=Don't show code . do CmdPrompt ;"display prompt and interact with user do VCULOAD2^TMGTERM ; SPDone ;"Finish up and return to GTM execution if tmgStepMode="into" set tmgDbgResult=1 if tmgStepMode="over" set tmgDbgResult=2 if tmgStepMode="outof" set tmgDbgResult=3 if $get(TMGMsg)=1 do ;"call was without $ZSTEP set, so we should set it. . new code set code="N TMGTrap " . set code=code_"S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) " . set code=code_"zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zstep:(TMGTrap=3) outof " . set code=code_"zcontinue" . ;"set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zstep:(TMGTrap=3) outof zcontinue" . set $ZSTEP=code . zstep:(tmgDbgResult=1) into . zstep:(tmgDbgResult=2) over . zstep:(tmgDbgResult=3) outof ;"Restore environment if $data(savedIO) use savedIO ;"turn IO back to what it was when coming into this function. set $X=+$get(savedX),$Y=+$get(savedY) ;"Restore screen POS variables. set %=%TMG if tmgDbgNakedRef'["""""" do ;"If holds "" index, skip over . new discard set discard=$get(@tmgDbgNakedRef) ;"restore naked reference. if tmgdbgTruth ;"This will restore initial value of $TEST quit tmgDbgResult ;"============================================================================ CmdPrompt ;"Purpose: Display the command prompt, and handle user input ;"Note: uses some variables with global scope, because this code block ;" was simply cut out of main routine above. ;"Result: None if tmgRunMode'=1 quit ;"Only interact with user if in stepping mode (1) new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" new tpDone set tpDone=0 for do quit:tpDone=1 . do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) . new tempi for tempi=1:1:2 write tpBlankLine,! ;"create empty space below display. . do CUU^TMGTERM(2) . if CsrOnBreakline=1 do . . new ifS set ifS=$$GetBrkCond($$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName)) . . if ifS'="" write "Breakpoint test: [",ifS,"]",! . write "}" . do EvalWatches . set $X=1 . write "Action (? for help): " . write "step "_$$UP^TMGIDE(tmgStepMode)_"// " . do ClrLine . set tpAction=$$READ^TMGIDE() write ! . if tpAction="" set tpAction=$$UP^TMGIDE($extract(tmgStepMode,1,1)) . new origAction set origAction=tpAction . do TranslateKeys(.tpAction,$get(tmgXGRT)) . set tpDone=("RLIHOXTQ"[tpAction) . if tpAction="R" set tmgRunMode=0 quit ;"Run Quickly . if tpAction="L" set tmgRunMode=3 quit ;"Run slowly . if tpAction="H" set tmgRunMode=2 quit ;"HIDE . if tpAction="I" set tmgStepMode="into" quit ;"Step INTO . if tpAction="O" set tmgStepMode="over" quit ;"Step OVER . if tpAction="T" set tmgStepMode="outof" quit ;"Step OUTOF . if tpAction="X" do HndlDone quit ;"Turn off debugger (keep running) . if tpAction="Q" do HndlQuit quit ;"Quit from debugger (stop running) . if tpAction="M" do HndlMCode quit ;"Execute M code . if tpAction="B" do HndlSetBrk quit ;"Toggle a breakpoint at current location . if tpAction="E" do HndlExpand quit ;"Expand line . if tpAction="W" do HndlWatch(origAction) quit ;"Watch . if tpAction="C" do HndlCstBrk quit ;"Custom breakpoint . if tpAction="J" do HndlJmpDisp(.tmgIDEPos,.ViewOffset) quit ;"Jump to new display location . if tpAction="BC" do HndlBrkCond quit ;"Enter a breakpoint condition (IF code) . if $$MoveKey(tpAction) quit . if tpAction="+" set TMGScrWidth=$get(TMGScrWidth)+1 quit . if tpAction="-" set:(TMGScrWidth>10) TMGScrWidth=$get(TMGScrWidth)-1 quit . if tpAction="=" do HndlScrW quit . if tpAction="CLS" write # quit . if tpAction="TABLE" do HndlTable quit . if tpAction["SHOW" do HndlShow quit . if tpAction["BROWSE" do HndlBrowse quit . if tpAction["NODES" do HndlNodes quit . if tpAction["STACK" do HndlStack(.tmgIDEPos,.ViewOffset) quit . if tpAction["RESYNC" kill @ArrayName quit . if tpAction["HIDE" do SetupSkips quit . if tpAction["FULL" do FULL^VALM1,INITKB^XGF() quit . if tpAction["UCASE" do HndlToggleMode("UCASE") quit . if tpAction["LCASE" do HndlToggleMode("LCASE") quit . if tpAction["XCMD" do HndlToggleMode("XCMD") quit . if tpAction["SCMD" do HndlToggleMode("SCMD") quit . if tpAction["TRACE" do ShowTrace^TMGIDE6 quit . if tpAction["TVDIFF" do HndlToggleMode("VARTRACE") quit . if tpAction["VDIFF" do ShowVTrace^TMGIDE6 quit . if tpAction["COLORS" do EditColors^TMGIDE6 quit . if tpAction["INITKB" do INITKB^XGF() quit ;"set up keyboard input escape code processing . else do HndlHelp quit quit BlankLine ; write tpBlankLine do CHA^TMGTERM(1) ;"move to x=1 on this line quit ClrLine ; ;"Purpose: clear out line new loop new tempX set tempX=$X for loop=1:1:20 write " " for loop=1:1:20 write $char(8) ;"backspace set $X=tempX quit TranslateKeys(tpAction,tmgXGRT) ;"Purpose: translate input keys into a standard output. ;"Input: tpAction -- PASS BY REFERENCE. set tpAction=$$UP^TMGIDE(tpAction) set tmgXGRT=$get(tmgXGRT) if tmgXGRT="UP" set tpAction="A" if tmgXGRT="PREV" set tpAction="AA" if tmgXGRT="DOWN" set tpAction="Z" if tmgXGRT="NEXT" set tpAction="ZZ" if tmgXGRT="RIGHT" set tpAction="]" if tmgXGRT="LEFT" set tpAction="[" if (tpAction="") set tpAction="" if (tpAction="A") set tpAction="" if (tpAction="AA") set tpAction="" if (tpAction="") set tpAction="" if (tpAction="Z") set tpAction="" if (tpAction="ZZ") set tpAction="" if (tpAction="") set tpAction="" if (tpAction="[") set tpAction="" if (tpAction="[[") set tpAction="" if (tpAction="") set tpAction="" if (tpAction="]") set tpAction="" if (tpAction="]]") set tpAction="" if (tpAction="^") set tpAction="Q" if "wW"[$piece(tpAction," ",1) set tpAction="W" quit MoveKey(tpAction) ;"Purpose: Handle movement keys ;"result: 1 if tpAction is a movement key, 0 otherwise if (tpAction="") do quit 1 . set ViewOffset=ViewOffset-1 if (tpAction="") do quit 1 . set ViewOffset=ViewOffset+1 if (tpAction="") do quit 1 . set ViewOffset=ViewOffset-1 . set ViewOffset=ViewOffset-ScrHeight+2; if (tpAction="") do quit 1 . set ViewOffset=ViewOffset+1 . set ViewOffset=ViewOffset+ScrHeight-2; if (tpAction="") do quit 1 . if LROffset>1 set LROffset=LROffset-1 if (tpAction="") do quit 1 . set LROffset=0 if tpAction="" do quit 1 . if LROffset=0 set LROffset=1 . set LROffset=LROffset+1 if (tpAction="") do quit 1 . if LROffset=0 set LROffset=1 . set LROffset=LROffset+20 quit 0 EvalWatches ;"Purpose: Run code that evaluates watches. if $get(tmgWatchLine)'="" do . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" . xecute tmgWatchLine if $data(tmgDgbWatches("*")) do ShowVTrace^TMGIDE6 write ! quit HndlMCode ; ;"Purpose: Handle option to execute arbitrary code. do CUU^TMGTERM(1) do CHA^TMGTERM(1) ;"move to x=1 on this line write tpBlankLine,! do CUU^TMGTERM(1) set tpLine=$$Trim^TMGIDE($piece(origAction," ",2,999)) if tpLine="" read " enter M code (^ to cancel): ",tpLine,! if (tpLine'="^") do . if +$get(tmgDbgRemoteJob) do RemoteXecute(tpLine) quit . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" . write ! ;"get below bottom line for output. . xecute tpLine quit HndlShow; ;"Purpose: Handle option to show a variable. do Box do SetColors("NORM") do CUP^TMGTERM(1,2) ;"Cursor to line (1,2) new varName set varName=$$Trim^TMGSTUTL($extract(origAction,5,999)) if +$get(tmgDbgRemoteJob) set varName=$$GetRemoteVar(varName) write ! ;"get below bottom line for output. new zbTemp set zbTemp=0 if varName["$" do . new tempCode . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" . write varName,"='" . set tempCode="do DebugWrite(1,"_varName_")" . xecute tempCode . write "' " else if varName'="" do . set varName=$$CREF^TMGIDE(varName) ;"convert open to closed format . set zbTemp=$$ArrayDump^TMGIDE(varName) if zbTemp=0 do . do SetColors("Highlight") . do PressToCont^TMGUSRIF do SetColors("Reset") quit HndlToggleMode(Mode) ;"Purpose: Toggle UCASE or LCASE in Options ;"This will effect the translation of all commands into forced Upper Case ;"or forced Lowercase, or leave as found if both options are set to 0 quit:($get(Mode)="") set tmgDbgOptions(Mode)='+$get(tmgDbgOptions(Mode)) write "Mode for " if "UCASE,LCASE,XCMD,SCMD"[Mode do . write "forcing " . write $select(Mode="UCASE":"UPPER case",Mode="LCASE":"LOWER case",1:"") . write $select(Mode="XCMD":"expansion",Mode="SCMD":"shortening",1:"") . write " of mumps command " if "TRACE"[Mode do . write "recording TRACE of execution " write "turned: " write $select(tmgDbgOptions(Mode)=0:"OFF",1:"ON")," ",! if tmgDbgOptions(Mode)=1 do . if Mode="UCASE" set tmgDbgOptions("LCASE")=0 . if Mode="LCASE" set tmgDbgOptions("UCASE")=0 . if Mode="XCMD" set tmgDbgOptions("SCMD")=0 . if Mode="SCMD" set tmgDbgOptions("XCMD")=0 ;"do PressToCont^TMGUSRIF quit HndlWatch(tpAction) ; ;"Purpose: Handle option to add watch do CUU^TMGTERM(1) do CHA^TMGTERM(1) ;"move to x=1 on this line write tpBlankLine,! do CUU^TMGTERM(1) write !,tpAction ;"TEMP! if (tpAction["+")!(tpAction["-") do . new watchVar . if (tpAction["+") do . . set watchVar=$$Trim^TMGIDE($piece(origAction,"+",2)) . . if watchVar="" quit . . if watchVar="^" set watchVar="tmgDbgNakedRef" . . set tmgDgbWatches(watchVar)="" . . if watchVar="*" write "Watching variable CHANGES" . else if (tpAction["-") do . . set watchVar=$$Trim^TMGIDE($piece(origAction,"-",2)) . . if watchVar="" quit . . if watchVar="^" set watchVar="tmgDbgNakedRef" . . kill tmgDgbWatches(watchVar) . set tmgWatchLine="" . new v set v="" . for set v=$order(tmgDgbWatches(v)) quit:(v="") do . . if v="*" quit ;" this signal for watching CHANGES handled elsewhere. . . set tmgWatchLine=tmgWatchLine_" write """_v_" =["",$get("_v_"),""], """ else do . kill tmgDgbWatches . new tempCode . read "Enter M code (^ to cancel): ",tempCode,! . if tempCode'="^" set tmgWatchLine=tempCode quit HndlQuit ; ;"Purpose: To create a crash, so can quit debugger, OR if in Remote ;" mode, then do same thing as 'X' command if +$get(tmgDbgRemoteJob) goto HndlDone ;"quit will occur from there kill @ArrayName set $etrap="" ;"remove error trap write !!!!!!!!!!! write "CREATING AN ARTIFICIAL ERROR TO STOP EXECUTION.",! write "--->Enter 'ZGOTO' from the GTM> prompt to clear error.",!! set $ZSTEP="" ;"turn off step capture xecute "write CrashNonVariable" quit HndlDone ; ;"Purpose: To turn off the debugger, allowing program to continue full speed. ;"Globally-scoped vars uses: tmgDbgResult, tmgStepMode if +$get(tmgDbgRemoteJob) do . new temp set temp=$$MessageOut("DONE") . set tmgStepMode="DONE" . set tmgDbgResult=0 ;"Will signal to stop looking for remote messages in TMGIDE3 else do . set $ZSTEP="" ;"Turn off debugger set TMGMsg=0 ;"ensure $ZSTEP is not turned back on. quit HndlScrW ; ;"Purpose: Handle option to set screen width new tempWidth read "Enter screen width: ",tempWidth,! if (+tempWidth>10) set TMGScrWidth=tempWidth,ScrWidth=tempWidth set tpBlankLine=" " for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " write # ;"clear screen do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) ;"<---- not working! quit HndlExpand ; ;"Purpose: handle option to expand one mumps like of code. new expPos,zbLabel,zbOffset,zbRoutine do ParsePos^TMGIDE(tmgIDEPos,.zbLabel,.zbOffset,.zbRoutine) set expPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine write ! do ExpandLine^TMGIDE(expPos) new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600) quit HndlStack(ShowPos,ViewOffset) ; ;"Purpose: Handle option to show and interact with stack. ;"Input: ShowPos -- OPTIONAL. PASS BY REFERENCE. Will be changed to user selected value. ;" ViewOffset -- OPTIONAL. PASS BY REFERENCE. Will be changed to 0 if user selects new Pos. ;"Globally scoped vars used: tmgOrigIDEPos write ! ;"get below bottom line for output. new Stack do GetStackInfo(.Stack,tmgOrigIDEPos) new Menu set Menu(0)="Pick Stack Entry to BROWSE TO" new menuI set menuI=1 new TMGi for TMGi=1:1 quit:($get(Stack(TMGi))="") do . new $etrap set $etrap="set $etrap="""",$ecode=""""" . new addr set addr=$piece($$TRIM^XLFSTR(Stack(TMGi))," ",2) . new txt set txt=$$TRIM^XLFSTR($text(@addr)) . set txt=$$TRIM^XLFSTR(txt,$char(9)) . new line set line=addr_" Code: "_txt . if $length(line)>TMGScrWidth set line=$extract(line,1,TMGScrWidth-10)_"..." . set Menu(menuI)=line_$char(9)_addr . set menuI=menuI+1 new UsrSlct set UsrSlct=$$Menu^TMGUSRIF(.Menu) write "User selection: [",UsrSlct,"]",! if (UsrSlct["^")&($length(UsrSlct)>1) do . set ShowPos=UsrSlct . set ViewOffset=0 write # ;"clr screen. quit HndlNodes ; ;"Purpse: Handle option to browse a variable by nodes. new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999)) write ! ;"get below bottom line for output. do BRWSASK2^TMGMISC quit HndlBrowse ; ;"Purpose: Handle option to browse a variable. new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999)) write ! ;"get below bottom line for output. do BRWSNOD2^TMGMISC(varName) quit HndlBrkCond ; ;"Purpose: Handle option to browse conditional break write "Enter an IF condition. Examples: 'A=1' or '$$FN1^MOD(A)=2'",! read "Enter IF condition (^ to cancel, @ to delete): ",tpLine,! if (tpLine="^") quit new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName) do SetBrkCond(brkPos,tpLine) quit HndlCstBrk ; ;"Purpose: Set a custom breakpoint new brkPos read !,"Enter breakpoint (e.g. Label+8^MyFunct): ",brkPos,! do SetBreakpoint(brkPos) quit HndlSetBrk ; ;"Purpose: Set breakpoint at current point ;"write !,"Trying to determine correct breakpoint. relPos=",relPos," ViewOffset=",ViewOffset,! new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName) ;"write "brkPos=",brkPos,! if brkPos="" write "relPos=",relPos," view offset=",ViewOffset," ArrayName=",ArrayName,! do ToggleBreakpoint(brkPos) quit HndlTable ; ;"Purpose: Handle option for Table command if +$get(tmgDbgRemoteJob) do . new temp set temp=$$MessageOut("TABLE") . if temp="" quit . new i set i="" . for set i=$order(@temp@(i)) quit:(i="") do . . new j set j="" . . for set j=$order(@temp@(i,j)) quit:(j="") do . . . write $get(@temp@(i,j)),! else do . write ! ;"get below bottom line for output. . zshow "*" new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600) quit HndlJmpDisp(ShowPos,ViewOffset) ;"Purpose: to allow user to enter in a location to show in code displayer ;"Input: ShowPos : PASS BY REFERENCE. The new location to change to ;" ViewOffset : PASS BY REFERECE. Will be changed to 0 if ShowPos changed. new tempLoc write "(Example: MYLABL+2^MYCODE)",! write "Enter location to jump display to: " read tempLoc:$get(DTIME,999),! if (tempLoc'="^")&(tempLoc["^")&(tempLoc'[" ") do . if $TEXT(@tempLoc)'="" do . . set ShowPos=tempLoc . . set ViewOffset=0 . else do . . write "Sorry. No code found at ",tempLoc,! . . do PressToCont^TMGUSRIF quit ; HndlHelp ; ;"Purpose: Handle option for help. do Box do SetColors("NORM") do CUP^TMGTERM(1,2) ;"Cursor to line (1,2) do HlpWrite(" {L} : Run sLow mode | {M} : exec M code | {SHOW [var]} : show [var]") do HlpWrite(" {O} : Step OVER line | {I} : step INTO line | {STACK} : stack show/jump") do HlpWrite(" {R} : Run | {T} Step OUT | {H} : Hide debug code | {CLS} : clear screen") do HlpWrite(" {B} : Toggle Brkpoint | {C} : Custom breakpoint| {BC} : breakpoint code") do HlpWrite(" {W} : Set watch code | {W +MyVar} :Watch MyVar| {W -MyVar} :Remove watch") do HlpWrite(" {A},{AA} : Scroll up | {Z},{ZZ} : Scroll down | {W +^} : Add Naked Ref") do HlpWrite(" {[},{[[} : Scroll left | {]},{]]} : Scroll right | {W +*} : Watch Var changes") do HlpWrite(" {X} : Turn off debug | {Q} : Abort | {BROWSE} [var] : browse [var]") do HlpWrite(" {-},{+} : Screen width | {=} : Enter width | {HIDE} : manage/hide modules") do SetColors("SPECIAL") do PressToCont^TMGUSRIF do Box do SetColors("NORM") do CUP^TMGTERM(1,2) ;"Cursor to line (1,2) do HlpWrite(" {TABLE} : Symbol table | {NODES} : Browse var | {INITKB} : restore key fn") do HlpWrite(" {J} : Jump display | {FULL} : Undo Scrl Zone | {E} : expand current line") do HlpWrite(" {UCASE} : Force U Case | {LCASE} : Force L Case | {COLORS} : Edit colors ") do HlpWrite(" {XCMD} : Force ExpndCmd| {SCMD} : Force ShrtnCmd | {TRACE} : Show Trace ") do HlpWrite(" {VDIFF} : Show Var Chng| {TVDIFF} Toggle TraceVar| {RESYNC} : sync display ") ;"write HlpWrite(" "),! do SetColors("SPECIAL") do PressToCont^TMGUSRIF do SetColors("Reset") quit ; HlpWrite(line) for quit:($length(line)'>0) do . if $find(line,"{")>0 do . . new part set part=$piece(line,"{",1) . . do SetColors("NORM") . . write part . . set line=$piece(line,"{",2,999) . . set part=$piece(line,"}",1) . . do SetColors("SPECIAL") . . write part . . set line=$piece(line,"}",2,999) . else do . . do SetColors("NORM") . . write line,! . . set line="" do SetColors("NORM") quit ErrTrap(tmgIDEPos) ;"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 if $$ShouldSkip($piece(tmgIDEPos,"^",2)) DO . write !,"Error at ",$P($ZSTATUS,",",2)," -- in code that debugger can't display.",! . write "Error is: ",$P($ZSTATUS,",",3,99),! . write !,"Dropping to command line via BREAK",! . BREAK new ScrHeight,ScrWidth set ScrHeight=$get(TMGScrHeight,10) set ScrWidth=$get(TMGScrWidth,70) do VCUSAV2^TMGTERM do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,0) ETDone do VCULOAD2^TMGTERM quit ShowCode(ShowPos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset,CsrOnBreakline) ;"Purpose: This will display code at the top of the screen ;"Input: ShowPos -- 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. ;" LROffset -- OPTIONAL. if value > 0 then the display ;" of each line will begin with this number character. ;" (i.e. will shift screen so that long lines can be seen.) ;" 0->no offset; 1->no offset (start at character 1); 2->offset 1 ;" CsrOnBreakline -- OPTIONAL. PASS BY REFERENCE. Will return 1 ;" if cursor is on a break line, otherwise 0 new cdLoop,scRoutine,scLabel,scOffset,scS new LastRou,LastLabel,LastOffset new dbFGColor,bBGColor,nlFGColor,nlBGColor new StartOffset,scCursorLine,cbLineLen new zBreakIdx set zBreakIdx=-1 new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob new zArrayName set zArrayName=$name(^TMG("TMGIDE",TMGdbgJNum,"MODULES")) set ScrWidth=$get(ScrWidth,80) set ScrHeight=$get(ScrHeight,10) set LROffset=+$get(LROffset,1) new ideBlankLine set $piece(ideBlankLine," ",ScrWidth-1)="" do CUP^TMGTERM(1,1) ;"Cursor to line (1,1) if $get(Wipe)=1 do goto SCDone ;"Blank screen and then quit . do SetColors("Reset") . for cdLoop=0:1:ScrHeight+1 write ideBlankLine,! set scS=$piece(ShowPos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE do ParsePos^TMGIDE(scS,.scLabel,.scOffset,.scRoutine) if scRoutine="" do goto SCDone . write !,!,"Error -- invalid position provided to ShowCode routine: ",ShowPos,! . write "scS=",scS,! ;"setup to show a symbol for breakpoint new zbS set zbS="" for set zbS=$order(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",zbS)) quit:(zbS="") do . new zbRoutine,zbLabel,zbOffset . new tempPos set tempPos=$$ConvertPos^TMGIDE(zbS,zArrayName) . do ParsePos^TMGIDE(tempPos,.zbLabel,.zbOffset,.zbRoutine) . if zbRoutine'=scRoutine quit . if zbLabel'=scLabel quit . set zBreakIdx(zbOffset)=1 if scOffset>(ScrHeight) set StartOffset=(scOffset-ScrHeight)+2 else set StartOffset=0 set StartOffset=StartOffset+$get(ViewOffset) ;"====Draw the top line ========================================== do SetColors("NORM") write "=== " do SetColors("SPECIAL") set scS="Routine: "_scLabel_"^"_scRoutine_" " if $data(tmgOrigIDEPos) set scS=scS_"("_tmgOrigIDEPos_")" else set scS=scS_"("_ShowPos_")" write scS do SetColors("NORM") write " " for cdLoop=1:1:ScrWidth-$length(scS)-5 write "=" do SetColors("NORM") write ! set CsrOnBreakline=0 for cdLoop=StartOffset:1:(StartOffset+ScrHeight) do . do SetColors("NORM") . do SetTempBkColor("Reset") . new cbLine,cbRef,cbCursor,cBrkLine . set cBrkLine=$data(zBreakIdx(cdLoop)) . set cbRef=scLabel_"+"_cdLoop_"^"_scRoutine . set cbLine=$text(@cbRef) . set cbLine=$$Substitute^TMGIDE(cbLine,$Char(9)," ") . if LROffset>0 set cbLine=$extract(cbLine,LROffset,999) . set scCursorLine=scOffset+$get(ViewOffset) . new cHighCsrPos set cHighCsrPos=(cdLoop=scCursorLine) . new cHighExecPos set cHighExecPos=(cdLoop=scOffset) . if cHighCsrPos do SetTempBkColor("Highlight") . if cHighExecPos do SetTempBkColor("HighExecPos") . if cBrkLine do . . if (cHighCsrPos=0)&(cHighExecPos=0) do . . . do SetTempBkColor("HighBkPos") . . else do . . . do SetTempBkColor("BkPos") . . . set CsrOnBreakline=1 . write $select(cdLoop=scOffset:">",cBrkLine:"#",1:" ") . do SetColors("SPECIAL") . if cdLoop>0 write "+"_cdLoop_$select(cdLoop<10:" ",1:"") . else write " " . do SetColors("NORM") . if $length(cbLine)>(ScrWidth-1) set cbLine=$extract(cbLine,1,ScrWidth-4)_"..." . set cbLineLen=$length(cbLine) . new StartPos set StartPos=$X . if $get(TMGDEBUG) write cbLine ;"temp . else set cbLineLen=$$ShowLine^TMGIDE6(cbLine,.tmgDbgOptions,ScrWidth-StartPos) . write $extract(ideBlankLine,cbLineLen,ScrWidth-StartPos-1) . do SetTempBkColor("Reset"),SetColors("NORM") . write ! ;"Draw bottom line. do SetColors("NORM") ;"do SetColors("SPECIAL") for cdLoop=1:1:ScrWidth write "~" ;"do SetColors("NORM") write ! SCDone ; do VTATRIB^TMGTERM(0) ;"reset colors quit SetTempBkColor(mode) set mode=$get(mode) quit:mode="" new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) if mode="Reset" kill @ref@("TEMP BACKGROUND") quit if "Highlight,HighExecPos,BkPos,HighBkPos"'[mode quit if $data(@ref)=0 do InitColors^TMGIDE6 new bg set bg=$get(@ref@(mode)) if bg="" quit set @ref@("TEMP BACKGROUND")=bg quit ; SetColors(mode) ;"Purpose: set colors in central location ;"Input: Mode -- the mode to change the colors to ;" bg -- OPTIONAL -- the default background. Default=15 set mode=$get(mode,"Reset") if mode="" set mode="Reset" new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) if $data(@ref)=0 do InitColors^TMGIDE6 if mode="Reset" do VTATRIB^TMGTERM(0) goto SCDn ;"reset colors new colorSet merge colorSet=@ref@(mode) ;"Get colors for mode new fg set fg=$get(colorSet("fg"),15) new bg set bg=$get(colorSet("bg"),15) if (bg="@") do . set bg=$get(@ref@("TEMP BACKGROUND"),"@") . if bg="@" set bg=$get(@ref@("BACKGROUND"),0) if fg=bg do . if (fg<15) set fg=fg+1 . else if (fg>0) set fg=fg-1 do VCOLORS^TMGTERM(fg,bg) SCDn quit; ; Box ; ;"Purpose: Draw a box on the top of the screen. ;"Globals Scope Vars used: ScrWidth,ScrHeight set ScrWidth=$get(ScrWidth,80) set ScrHeight=$get(ScrHeight,10) new ideBlankLine set $piece(ideBlankLine," ",ScrWidth)=" " new ideBarLine set $piece(ideBarLine,"=",ScrWidth)="=" do CUP^TMGTERM(1,1) ;"Cursor to line (1,1) do SetColors("Highlight") write ideBarLine,! do SetColors("NORM") new cdLoop for cdLoop=0:1:ScrHeight+1 write ideBlankLine,! do SetColors("Reset") quit ; GetStackInfo(Stack,ExecPos) ;"Purpose: to query GTM and get back filtered Stack information ;"Input: Stack -- PASS BY REFERENCE. An array to received back info. Old info is killed ;" ExecPos -- OPTIONAL. Current execution position kill Stack new i,count set count=1 if $STACK<3 quit ;"0-2 are steps getting into debugger for i=0:1:$STACK do ;"was 3:1: . new s set s=$STACK(i,"PLACE") . if s["TMGIDE" quit . if s["GTM$DMOD" quit . if s="@" set s=s_""""_$STACK(i,"MCODE")_"""" . if s=$get(ExecPos) set s=s_" <--Current execution point" ;",i=$STACK+1 . set Stack(count)=$STACK(i)_" "_s . set count=count+1 quit ToggleBreakpoint(pos,condition) ;"Purpose: to set or release the GT.M breakpoint at position ;"Input: pos -- the position to alter ;" condition -- OPTIONAL -- should be contain valid M code such that ;" if @condition is valid. Examples: ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1 ;"write "Here in ToggleBreakoint",! if $$IsBreakpoint(pos) do . ;"write " calling RelBreakpoint",! . do RelBreakpoint(pos) else do . ;"write "calling Set breakpoint",! . do SetBreakpoint(pos,.condition) quit IsBreakpoint(pos) ;"Purpose: to determine if position is a breakpoint pos ;"Note: I am concerned that pos might contain a name longer than 8 chars ;" and might give a false result, or ^TMP(...) might hold a name ;" longer than 8 chars. ;" BUT, if I just cut name off at 8 chars, it might not work well ;" with GTM v5 new result set result=0 new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob if $get(pos)'="" set result=$data(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)) quit (result'=0) EnsureBreakpoints() ;"Purpose: When an module is recompiled, GT.M drops the breakpoints for ;" that module. However, the breakpoints are still stored for this ;" debugger, meaning that the lines will still be highlighted etc, ;" --but they don't work. This function will go through stored ;" breakpoints and again register them with GT.M new pos set pos="" new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob for set pos=$order(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)) quit:(pos="") do . do SetBreakpoint(pos) quit SetBreakpoint(pos,condition) ;"Purpose: set the GT.M breakpoint to pos position ;"Input: pos -- the position to alter ;" condition -- OPTIONAL -- should be contain valid M code such that ;" if @condition is valid. Examples: ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1 ;"Globally scoped var used: ;" tmgDbgRemoteJob-- OPTIONAL -- if controlling a remote process, then = $J of that process ;" and action should not be done locally. if $get(pos)="" do goto SBkDone . write "?? no position specified ??",! ; new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob set ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)="" do SetBrkCond(pos,.condition) ; if $get(tmgDbgRemoteJob) do . new temp set temp=$$MessageOut("BKPOS "_pos_" "_$get(condition)) . write "Results from remote process=",temp,! else do . new brkLine set brkLine=pos_":""n tmg s tmgRunMode=1 s tmg=$$STEPTRAP^TMGIDE2($ZPOS,1)""" . new $etrap . set $etrap="K ^TMG(""TMGIDE"",$J,""ZBREAK"",pos) S $ETRAP="""",$ECODE=""""" . ZBREAK @brkLine SBkDone quit SetBrkCond(pos,condition) ;"Purpose: A standardized SET for condition. ;"Input: pos -- ;" condition -- if $get(condition)="" quit if $get(pos)="" quit new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob if condition="@" kill ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF") else set ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF")=condition if $$IsBreakpoint(pos)=0 do SetBreakpoint(pos) quit GetBrkCond(pos) ;"Purpose: A standardized GET for condition. ;"Results: returns condition code, or "" new result set result="" new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob set:(pos'="") result=$get(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF")) quit result RelBreakpoint(pos) ;"Purpose: to release a GT.M breakpoint at position new TMGdbgJNum set TMGdbgJNum=$J if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob kill ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos) if $get(tmgDbgRemoteJob) do goto SBkDone . new temp set temp=$$MessageOut("RELBKPOS "_pos) else do . new brkLine set brkLine=pos_":""zcontinue""" . ZBREAK @brkLine ;"write "released breakpoint at: ",pos,! quit ShouldSkip(module) ;"Purpose: to see if module is in hidden list new result set result=0 if $get(TMGdbgHideList)="" goto SSKDone new HideMod set HideMod="" for set HideMod=$order(@TMGdbgHideList@(HideMod)) quit:(HideMod="")!(result=1) do . if (module=HideMod) set result=1 quit . if HideMod'["*" quit . new tempMod set tempMod=$extract(HideMod,1,$find(HideMod,"*")-2) . new trimModule set trimModule=$extract(module,1,$length(tempMod)) . set result=(trimModule=tempMod) SSKDone quit result SetupSkips ;"Purpose: to manage modules that are to be skipped over. ;"Input: none. But this modifies variable @TMGdbgHideList with global scope ;"results: none ;"For some reason, this gets lost at times.... if $data(TMGdbgHideList)=0 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) new menu,option set menu(0)="Pick Options for Hiding/Showing Modules" set menu(1)="SHOW current hidden list"_$c(9)_"SHOW" set menu(2)="ADD module to hidden list"_$c(9)_"ADD" set menu(3)="REMOVE module from hidden list"_$c(9)_"REMOVE" set menu(4)="Done."_$c(9)_"^" StSkp set option=$$Menu^TMGUSRIF(.menu) if option="SHOW" do ShowSkip if option="ADD" do AddSkip if option="REMOVE" do RmSkip if option="^" goto StSkDone goto StSkp StSkDone quit AddSkip ;"Purpose: to allow user to Add a module to hidden list ;"Input: none. But this modifies variable @TMGdbgHideList with global scope ;"results: none ASKP1 write "Enter name of module to add to hidden list (? for help, ^ to abort)",! new mod read "Enter module: ",mod:$get(DTIME,3600),! if mod="?" do goto ASKP1 . write "Some modules of the code are not helpful to debugging one's code.",! . write "For example, if one did not ever want to trace into the code stored",! . write "in DIC, then DIC would be added as a module to be hidden. Then, when",! . write "debugging one's own code, all traces into ^DIC would be skipped over.",! . write "If only part of the name is specified, then ALL modules starting with",! . write "this name will be excluded.",! . do PressToCont^TMGUSERIF if mod="^" goto ASDone write "Add '",mod,"' as a module to be skipped over" new % set %=1 do YN^DICN if $data(TMGdbgHideList)=0 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) if %=1 set @TMGdbgHideList@(mod)="" ASDone quit RmSkip ;"Purpose: to allow user to remove a module from hidden list ;"Input: none. But this modifies variable @TMGdbgHideList with global scope ;"results: none new menu,option,idx RmL1 kill menu set idx=0 new mod set mod="" ;"Load menu with current list. for set mod=$order(@TMGdbgHideList@(mod)) quit:(mod="") do . set idx=idx+1,menu(idx)=mod_$c(9)_mod if $data(menu)=0 goto RmSkipDone . write "--The list is currently empty--" . do PressToCont^TMGUSRIF set idx=idx+1 set menu(idx)="Done"_$c(9)_"^" set menu(0)="Pick Module to remove from hidden list" set option=$$Menu^TMGUSRIF(.menu) if option="^" goto RmSkipDone kill @TMGdbgHideList@(option) goto RmL1 RmSkipDone quit ShowSkip ;"Purpose: to show the hidden list ;"Input: none. But this uses variable @TMGdbgHideList with global scope ;"results: none new mod set mod="" if $data(@TMGdbgHideList)>0 do . for set mod=$order(@TMGdbgHideList@(mod)) quit:(mod="") do . . write " ",mod,! else do . write "--The list is currently empty--" do PressToCont^TMGUSRIF quit ;"============================================= ;" Code for when controlling another process ;"============================================= MessageOut(Msg,timeOutTime,ignoreReply) ;"Purpose: For use when in remote-control debugging mode. This will ;" send a message to SENDER, not waiting for a reply ;"Input: Msg -- the message to send ;" timeOutTime -- OPTIONAL, default is 2 seconds ;" ignoreReply -- OPTIONAL, default is 0 (don't ignore) ;"Output: the returned message, or "" if timed out or no reply, or ignoreReply=1 set timeOutTime=$get(timeOutTime,2) set ignoreReply=$get(ignoreReply,0) new result set result="" set Msg="[CMD] "_$get(Msg) set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")=Msg set ^TMG("TMGIDE","CONTROLLER","MSG-IN")="" if (ignoreReply=0) for do quit:(result'="")!(timeOutTime<0) . set result=$get(^TMG("TMGIDE","CONTROLLER","MSG-IN")) . if (result'="") quit . set timeOutTime=timeOutTime-0.1 . set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")=Msg . hang 0.1 if $piece(result," ",1)="[RSLT]" do set result=$piece(result," ",2,999) else do . write !,"Unexpected reply: ",result,! . do PressToCont^TMGUSRIF . set result="" quit result GetRemoteVar(varName) ;"Purpose: Pass varName to remote process, have it evaluated there, and ;" then passed back back here for display. ;"Input: varName -- expression (variable name, or function) to be evaluated. new temp set temp=$$MessageOut("EVAL "_$get(varName)) kill @varName if (temp="")!(temp[" ") do goto GMVD . write !,"Unexpected var name back: [",temp,"]",! . set temp="" merge @varName=@temp GMVD quit varName RemoteXecute(MCode) ;"Purpose: Pass M Code to remote process for execution there. ;"Input: A line of M code, as entered by user. ;"Results: none ;"Output: Any IO of M code should be shown in other process's IO new temp set temp=$$MessageOut("XECUTE "_$get(MCode)) quit