source: cprs/branches/tmg-cprs/m_files/TMGIDE2.m@ 1085

Last change on this file since 1085 was 896, checked in by Kevin Toppenberg, 14 years ago

replacing soft links with actual files

File size: 45.1 KB
Line 
1TMGIDE2 ;TMG/kst/A debugger/tracer for GT.M (core functionality) ;03/25/06
2 ;;1.0;TMG-LIB;**1**;03/23/09
3
4 ;" GT.M TRAP STEP
5 ;"
6 ;" K. Toppenberg
7 ;" 4-13-2005
8 ;" License: GPL Applies
9 ;"
10 ;"------------------------------------------------------------
11 ;"------------------------------------------------------------
12 ;" This code module will allow tracing through code.
13 ;" It is used as follows:
14 ;"
15 ;" set $ZSTEP="do STEPTRAP^TMGIDE2($ZPOS) zstep into zcontinue"
16 ;" zstep into
17 ;" do ^MyFunction ;"<--- put the function you want to trace here
18 ;"
19 ;" set $ZSTEP="" ;"<---turn off step capture
20 ;" quit
21 ;"
22 ;"
23 ;" Dependencies:
24 ;" Uses: ^TMGTERM,^TMGIDE
25 ;"
26 ;"Notes:
27 ;" This function will be called inbetween lines of the main
28 ;" program that is being traced. Thus this function can't do
29 ;" anything that might change the environment of the main
30 ;" program.
31 ;"------------------------------------------------------------
32 ;"------------------------------------------------------------
33
34 ;"=======================================================================
35 ;" API -- Public Functions.
36 ;"=======================================================================
37 ;"STEPTRAP(tmgIDEPos,TMGMsg)
38 ;"ErrTrap(tmgIDEPos)
39
40 ;"=======================================================================
41 ;"PRIVATE API FUNCTIONS
42 ;"=======================================================================
43 ;"EvalWatches
44 ;"BlankLine
45 ;"ShowCode(ShowPos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset)
46 ;"GetStackInfo(Stack,tmgOrigIDEPos)
47 ;"SetBreakpoint(pos,Condition)
48 ;"RelBreakpoint(pos)
49
50 ;"=======================================================================
51 ;"=======================================================================
52
53
54STEPTRAP(tmgIDEPos,TMGMsg)
55 ;"Purpose: This is the line that is called by GT.M for each zstep event.
56 ;" It will be used to display the current code execution point, and
57 ;" query user as to plans for future execution: run/step/ etc.
58 ;"Input: tmgIDEPos -- a text line containing position, as returned bye $ZPOS
59 ;" TMGMsg -- OPTIONAL -- can be used by programs to pass in info.
60 ;" If TMGMsg=1, then this function was called without the
61 ;" $ZSTEP value set, so this function should set it.
62 ;"Global-scoped vars used:
63 ;" tmgDbgRemoteJob = remote $J if controlling a remote process
64 ;" Won't exist (or will be 0) otherwise.
65 ;" tmgRunMode --
66 ;" tmgStepMode --
67 ;" TMGScrHeight --
68 ;" TMGScrWidth --
69 ;" TMGLROffset --
70 ;" TMGdbgHideList (an array REF) -- holds modules to hide
71 ;"Result: desired mode for next time:
72 ;" 1=step into
73 ;" 2=step over
74 ;" 3-step outof
75 ;" (anything else) -- stop debugging. <-- I think...
76 ;" 0-->signals request to stop when remote debugging.
77
78 ;"tmgRunMode: 0=running mode (NOTE: tmgRunMode comes from tmgRunMode)
79 ;" 1=stepping mode
80 ;" 2=Don't show code
81 ;" 3=running SLOW mode
82 ;" -1=quit
83 new tmgdbgTruth set tmgdbgTruth=$TEST ;"save initial value of $TEST
84 if $ZTRAP'["^TMG" do SetErrTrap^TMGIDE ;"ensure no redirecting of error trap
85 new tmgDbgResult set tmgDbgResult=1 ;"1=step into, 2=step over
86 new tmgDbgNakedRef set tmgDbgNakedRef=$$LGR^TMGIDE ;"save naked reference
87 set tmgDbgHangTime=+$get(tmgDbgHangTime,0.25)
88
89 set tmgRunMode=$get(tmgRunMode,1)
90 ;"Keep track of changes to variable system table
91 if (tmgRunMode'=0)&(+$get(tmgDbgOptions("VARTRACE"))=1) do RecordVTrace^TMGIDE6
92 set tmgStepMode=$get(tmgStepMode,"into")
93
94 set tmgDbgRemoteJob=+$get(tmgDbgRemoteJob)
95 new TMGdbgJNum set TMGdbgJNum=$J
96 if tmgDbgRemoteJob set TMGdbgJNum=tmgDbgRemoteJob
97 new ArrayName set ArrayName=$name(^TMG("TMGIDE",TMGdbgJNum,"MODULES"))
98 new %TMG set %TMG=$get(%)
99
100 new tpBlankLine,tpAction,tpKeyIn,tpI,tpDone
101 new ViewOffset set ViewOffset=0
102
103 new savedIO,savedX,savedY
104 set savedIO=$IO
105 set savedX=$X,savedY=$Y
106
107 new ScrHeight,ScrWidth,LROffset
108 set ScrHeight=$get(TMGScrHeight,10)
109 set ScrWidth=+$get(TMGScrWidth)
110 if (ScrWidth'>0)!(tmgRunMode=1) do ;"If pause after every show, take time to check dimensions.
111 . if $$GetScrnSize^TMGKERNL(,.ScrWidth)
112 . set TMGScrWidth=ScrWidth
113 set LROffset=$get(TMGLROffset,0)
114 use $P:(WIDTH=ScrWidth:NOWRAP) ;"reset IO to the screen
115
116 set tpBlankLine=" "
117 for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" "
118
119 new relPos set relPos=tmgIDEPos
120 new tmgOrigIDEPos set tmgOrigIDEPos=tmgIDEPos
121 new tempPos set tempPos=$$ConvertPos^TMGIDE(tmgIDEPos,ArrayName)
122 if tempPos'="" set tmgIDEPos=tempPos
123
124 ;"don't show hidden modules (setup in TMGIDE module)
125 if $$ShouldSkip($piece(tmgIDEPos,"^",2)) goto SPDone
126 ;"Record trace, if not a hidden module
127 if +$get(tmgDbgOptions("TRACE"))=1 do RecordTrace^TMGIDE6(tmgOrigIDEPos)
128
129 ;"Note: Conditional Breakpoints: I will have to try to get this working later.
130 ;"I have it such that the condition is recognized. But now I need to
131 ;"Differientate between stepping through code, and a breakpoint from
132 ;"a full speed run.
133 new stpSkip set stpSkip=0
134 if $$IsBreakpoint(tmgIDEPos) do ;"goto:(stpSkip=1) SPDone
135 . new ifS set ifS=$$GetBrkCond(tmgIDEPos) if ifS="" quit
136 . new $etrap set $etrap="write ""ERROR in breakpoint condition code."",! quit"
137 . if (@ifS=0) set stpSkip=1
138 . if @ifS write "Condition FOUND!!" ;"do PressToCont^TMGUSRIF
139
140 do VCUSAV2^TMGTERM
141 new CsrOnBreakline set CsrOnBreakline=0
142 if tmgRunMode'=2 do ;"2=Don't show code
143 . do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline)
144 . write CsrOnBreakline,! ;"temps
145 else do
146 . do CUP^TMGTERM(1,2)
147 write tpBlankLine,!
148 write tpBlankLine,!
149 do CUU^TMGTERM(2)
150 if tmgRunMode'=1 do ;"Not stepping mode
151 . write tpBlankLine,!
152 . do CUU^TMGTERM(1)
153 . do EvalWatches
154 . write "(Press any key to pause"
155 . if tmgRunMode=3 write "; '+' for faster, '-' for slower)",!
156 . else write ")",!
157 . read *tpKeyIn:0
158 . if tmgRunMode=3 do
159 . . if tpKeyIn=43 set tmgDbgHangTime=tmgDbgHangTime/2 ;"43= '+'
160 . . else if tpKeyIn=45 set tmgDbgHangTime=tmgDbgHangTime*2 ;"45= '-'
161 . . hang tmgDbgHangTime
162 . if (tpKeyIn>0) set tmgRunMode=1
163 if tmgRunMode'=2 do ;"2=Don't show code
164 . do CmdPrompt ;"display prompt and interact with user
165 do VCULOAD2^TMGTERM
166 ;
167SPDone ;"Finish up and return to GTM execution
168 if tmgStepMode="into" set tmgDbgResult=1
169 if tmgStepMode="over" set tmgDbgResult=2
170 if tmgStepMode="outof" set tmgDbgResult=3
171
172
173 if $get(TMGMsg)=1 do ;"call was without $ZSTEP set, so we should set it.
174 . new code set code="N TMGTrap "
175 . set code=code_"S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) "
176 . set code=code_"zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zstep:(TMGTrap=3) outof "
177 . set code=code_"zcontinue"
178 . ;"set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zstep:(TMGTrap=3) outof zcontinue"
179 . set $ZSTEP=code
180 . zstep:(tmgDbgResult=1) into
181 . zstep:(tmgDbgResult=2) over
182 . zstep:(tmgDbgResult=3) outof
183
184
185 ;"Restore environment
186 if $data(savedIO) use savedIO ;"turn IO back to what it was when coming into this function.
187 set $X=+$get(savedX),$Y=+$get(savedY) ;"Restore screen POS variables.
188 set %=%TMG
189 if tmgDbgNakedRef'["""""" do ;"If holds "" index, skip over
190 . new discard set discard=$get(@tmgDbgNakedRef) ;"restore naked reference.
191 if tmgdbgTruth ;"This will restore initial value of $TEST
192 quit tmgDbgResult
193 ;"============================================================================
194
195CmdPrompt
196 ;"Purpose: Display the command prompt, and handle user input
197 ;"Note: uses some variables with global scope, because this code block
198 ;" was simply cut out of main routine above.
199 ;"Result: None
200 if tmgRunMode'=1 quit ;"Only interact with user if in stepping mode (1)
201 new $etrap set $etrap="set result="""",$etrap="""",$ecode="""""
202 new tpDone set tpDone=0
203 for do quit:tpDone=1
204 . do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline)
205 . new tempi for tempi=1:1:2 write tpBlankLine,! ;"create empty space below display.
206 . do CUU^TMGTERM(2)
207 . if CsrOnBreakline=1 do
208 . . new ifS set ifS=$$GetBrkCond($$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName))
209 . . if ifS'="" write "Breakpoint test: [",ifS,"]",!
210 . write "}"
211 . do EvalWatches
212 . set $X=1
213 . write "Action (? for help): "
214 . write "step "_$$UP^TMGIDE(tmgStepMode)_"// "
215 . do ClrLine
216 . set tpAction=$$READ^TMGIDE() write !
217 . if tpAction="" set tpAction=$$UP^TMGIDE($extract(tmgStepMode,1,1))
218 . new origAction set origAction=tpAction
219 . do TranslateKeys(.tpAction,$get(tmgXGRT))
220 . set tpDone=("RLIHOXTQ"[tpAction)
221 . if tpAction="R" set tmgRunMode=0 quit ;"Run Quickly
222 . if tpAction="L" set tmgRunMode=3 quit ;"Run slowly
223 . if tpAction="H" set tmgRunMode=2 quit ;"HIDE
224 . if tpAction="I" set tmgStepMode="into" quit ;"Step INTO
225 . if tpAction="O" set tmgStepMode="over" quit ;"Step OVER
226 . if tpAction="T" set tmgStepMode="outof" quit ;"Step OUTOF
227 . if tpAction="X" do HndlDone quit ;"Turn off debugger (keep running)
228 . if tpAction="Q" do HndlQuit quit ;"Quit from debugger (stop running)
229 . if tpAction="M" do HndlMCode quit ;"Execute M code
230 . if tpAction="B" do HndlSetBrk quit ;"Toggle a breakpoint at current location
231 . if tpAction="E" do HndlExpand quit ;"Expand line
232 . if tpAction="W" do HndlWatch(origAction) quit ;"Watch
233 . if tpAction="C" do HndlCstBrk quit ;"Custom breakpoint
234 . if tpAction="J" do HndlJmpDisp(.tmgIDEPos,.ViewOffset) quit ;"Jump to new display location
235 . if tpAction="BC" do HndlBrkCond quit ;"Enter a breakpoint condition (IF code)
236 . if $$MoveKey(tpAction) quit
237 . if tpAction="+" set TMGScrWidth=$get(TMGScrWidth)+1 quit
238 . if tpAction="-" set:(TMGScrWidth>10) TMGScrWidth=$get(TMGScrWidth)-1 quit
239 . if tpAction="=" do HndlScrW quit
240 . if tpAction="CLS" write # quit
241 . if tpAction="TABLE" do HndlTable quit
242 . if tpAction["SHOW" do HndlShow quit
243 . if tpAction["BROWSE" do HndlBrowse quit
244 . if tpAction["NODES" do HndlNodes quit
245 . if tpAction["STACK" do HndlStack(.tmgIDEPos,.ViewOffset) quit
246 . if tpAction["RESYNC" kill @ArrayName quit
247 . if tpAction["HIDE" do SetupSkips quit
248 . if tpAction["FULL" do FULL^VALM1,INITKB^XGF() quit
249 . if tpAction["UCASE" do HndlToggleMode("UCASE") quit
250 . if tpAction["LCASE" do HndlToggleMode("LCASE") quit
251 . if tpAction["XCMD" do HndlToggleMode("XCMD") quit
252 . if tpAction["SCMD" do HndlToggleMode("SCMD") quit
253 . if tpAction["TRACE" do ShowTrace^TMGIDE6 quit
254 . if tpAction["TVDIFF" do HndlToggleMode("VARTRACE") quit
255 . if tpAction["VDIFF" do ShowVTrace^TMGIDE6 quit
256 . if tpAction["COLORS" do EditColors^TMGIDE6 quit
257 . if tpAction["INITKB" do INITKB^XGF() quit ;"set up keyboard input escape code processing
258 . else do HndlHelp quit
259 quit
260
261BlankLine ;
262 write tpBlankLine
263 do CHA^TMGTERM(1) ;"move to x=1 on this line
264 quit
265
266ClrLine ;
267 ;"Purpose: clear out line
268 new loop
269 new tempX set tempX=$X
270 for loop=1:1:20 write " "
271 for loop=1:1:20 write $char(8) ;"backspace
272 set $X=tempX
273 quit
274
275TranslateKeys(tpAction,tmgXGRT)
276 ;"Purpose: translate input keys into a standard output.
277 ;"Input: tpAction -- PASS BY REFERENCE.
278 set tpAction=$$UP^TMGIDE(tpAction)
279 set tmgXGRT=$get(tmgXGRT)
280 if tmgXGRT="UP" set tpAction="A"
281 if tmgXGRT="PREV" set tpAction="AA"
282 if tmgXGRT="DOWN" set tpAction="Z"
283 if tmgXGRT="NEXT" set tpAction="ZZ"
284 if tmgXGRT="RIGHT" set tpAction="]"
285 if tmgXGRT="LEFT" set tpAction="["
286 if (tpAction="<AU>") set tpAction="<UP>"
287 if (tpAction="A") set tpAction="<UP>"
288 if (tpAction="AA") set tpAction="<PGUP>"
289 if (tpAction="<AD>") set tpAction="<DN>"
290 if (tpAction="Z") set tpAction="<DN>"
291 if (tpAction="ZZ") set tpAction="<PGDN>"
292 if (tpAction="<AL>") set tpAction="<LEFT>"
293 if (tpAction="[") set tpAction="<LEFT>"
294 if (tpAction="[[") set tpAction="<HOME>"
295 if (tpAction="<AR>") set tpAction="<RIGHT>"
296 if (tpAction="]") set tpAction="<RIGHT>"
297 if (tpAction="]]") set tpAction="<END>"
298 if (tpAction="^") set tpAction="Q"
299 if "wW"[$piece(tpAction," ",1) set tpAction="W"
300 quit
301
302MoveKey(tpAction)
303 ;"Purpose: Handle movement keys
304 ;"result: 1 if tpAction is a movement key, 0 otherwise
305 if (tpAction="<UP>") do quit 1
306 . set ViewOffset=ViewOffset-1
307 if (tpAction="<DN>") do quit 1
308 . set ViewOffset=ViewOffset+1
309 if (tpAction="<PGUP>") do quit 1
310 . set ViewOffset=ViewOffset-1
311 . set ViewOffset=ViewOffset-ScrHeight+2;
312 if (tpAction="<PGDN>") do quit 1
313 . set ViewOffset=ViewOffset+1
314 . set ViewOffset=ViewOffset+ScrHeight-2;
315 if (tpAction="<LEFT>") do quit 1
316 . if LROffset>1 set LROffset=LROffset-1
317 if (tpAction="<HOME>") do quit 1
318 . set LROffset=0
319 if tpAction="<RIGHT>" do quit 1
320 . if LROffset=0 set LROffset=1
321 . set LROffset=LROffset+1
322 if (tpAction="<END>") do quit 1
323 . if LROffset=0 set LROffset=1
324 . set LROffset=LROffset+20
325 quit 0
326
327EvalWatches
328 ;"Purpose: Run code that evaluates watches.
329 if $get(tmgWatchLine)'="" do
330 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode="""""
331 . xecute tmgWatchLine
332 if $data(tmgDgbWatches("*")) do ShowVTrace^TMGIDE6
333 write !
334 quit
335
336HndlMCode ;
337 ;"Purpose: Handle option to execute arbitrary code.
338 do CUU^TMGTERM(1)
339 do CHA^TMGTERM(1) ;"move to x=1 on this line
340 write tpBlankLine,!
341 do CUU^TMGTERM(1)
342 set tpLine=$$Trim^TMGIDE($piece(origAction," ",2,999))
343 if tpLine="" read " enter M code (^ to cancel): ",tpLine,!
344 if (tpLine'="^") do
345 . if +$get(tmgDbgRemoteJob) do RemoteXecute(tpLine) quit
346 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
347 . write ! ;"get below bottom line for output.
348 . xecute tpLine
349 quit
350
351HndlShow;
352 ;"Purpose: Handle option to show a variable.
353 do Box
354 do SetColors("NORM")
355 do CUP^TMGTERM(1,2) ;"Cursor to line (1,2)
356 new varName set varName=$$Trim^TMGSTUTL($extract(origAction,5,999))
357 if +$get(tmgDbgRemoteJob) set varName=$$GetRemoteVar(varName)
358 write ! ;"get below bottom line for output.
359 new zbTemp set zbTemp=0
360 if varName["$" do
361 . new tempCode
362 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
363 . write varName,"='"
364 . set tempCode="do DebugWrite(1,"_varName_")"
365 . xecute tempCode
366 . write "' "
367 else if varName'="" do
368 . set varName=$$CREF^TMGIDE(varName) ;"convert open to closed format
369 . set zbTemp=$$ArrayDump^TMGIDE(varName)
370 if zbTemp=0 do
371 . do SetColors("Highlight")
372 . do PressToCont^TMGUSRIF
373 do SetColors("Reset")
374 quit
375
376HndlToggleMode(Mode)
377 ;"Purpose: Toggle UCASE or LCASE in Options
378 ;"This will effect the translation of all commands into forced Upper Case
379 ;"or forced Lowercase, or leave as found if both options are set to 0
380 quit:($get(Mode)="")
381 set tmgDbgOptions(Mode)='+$get(tmgDbgOptions(Mode))
382 write "Mode for "
383 if "UCASE,LCASE,XCMD,SCMD"[Mode do
384 . write "forcing "
385 . write $select(Mode="UCASE":"UPPER case",Mode="LCASE":"LOWER case",1:"")
386 . write $select(Mode="XCMD":"expansion",Mode="SCMD":"shortening",1:"")
387 . write " of mumps command "
388 if "TRACE"[Mode do
389 . write "recording TRACE of execution "
390 write "turned: "
391 write $select(tmgDbgOptions(Mode)=0:"OFF",1:"ON")," ",!
392 if tmgDbgOptions(Mode)=1 do
393 . if Mode="UCASE" set tmgDbgOptions("LCASE")=0
394 . if Mode="LCASE" set tmgDbgOptions("UCASE")=0
395 . if Mode="XCMD" set tmgDbgOptions("SCMD")=0
396 . if Mode="SCMD" set tmgDbgOptions("XCMD")=0
397 ;"do PressToCont^TMGUSRIF
398 quit
399
400HndlWatch(tpAction) ;
401 ;"Purpose: Handle option to add watch
402 do CUU^TMGTERM(1)
403 do CHA^TMGTERM(1) ;"move to x=1 on this line
404 write tpBlankLine,!
405 do CUU^TMGTERM(1)
406 write !,tpAction ;"TEMP!
407 if (tpAction["+")!(tpAction["-") do
408 . new watchVar
409 . if (tpAction["+") do
410 . . set watchVar=$$Trim^TMGIDE($piece(origAction,"+",2))
411 . . if watchVar="" quit
412 . . if watchVar="^" set watchVar="tmgDbgNakedRef"
413 . . set tmgDgbWatches(watchVar)=""
414 . . if watchVar="*" write "Watching variable CHANGES"
415 . else if (tpAction["-") do
416 . . set watchVar=$$Trim^TMGIDE($piece(origAction,"-",2))
417 . . if watchVar="" quit
418 . . if watchVar="^" set watchVar="tmgDbgNakedRef"
419 . . kill tmgDgbWatches(watchVar)
420 . set tmgWatchLine=""
421 . new v set v=""
422 . for set v=$order(tmgDgbWatches(v)) quit:(v="") do
423 . . if v="*" quit ;" this signal for watching CHANGES handled elsewhere.
424 . . set tmgWatchLine=tmgWatchLine_" write """_v_" =["",$get("_v_"),""], """
425 else do
426 . kill tmgDgbWatches
427 . new tempCode
428 . read "Enter M code (^ to cancel): ",tempCode,!
429 . if tempCode'="^" set tmgWatchLine=tempCode
430 quit
431
432HndlQuit ;
433 ;"Purpose: To create a crash, so can quit debugger, OR if in Remote
434 ;" mode, then do same thing as 'X' command
435 if +$get(tmgDbgRemoteJob) goto HndlDone ;"quit will occur from there
436 kill @ArrayName
437 set $etrap="" ;"remove error trap
438 write !!!!!!!!!!!
439 write "CREATING AN ARTIFICIAL ERROR TO STOP EXECUTION.",!
440 write "--->Enter 'ZGOTO' from the GTM> prompt to clear error.",!!
441 set $ZSTEP="" ;"turn off step capture
442 xecute "write CrashNonVariable"
443 quit
444
445HndlDone ;
446 ;"Purpose: To turn off the debugger, allowing program to continue full speed.
447 ;"Globally-scoped vars uses: tmgDbgResult, tmgStepMode
448 if +$get(tmgDbgRemoteJob) do
449 . new temp set temp=$$MessageOut("DONE")
450 . set tmgStepMode="DONE"
451 . set tmgDbgResult=0 ;"Will signal to stop looking for remote messages in TMGIDE3
452 else do
453 . set $ZSTEP="" ;"Turn off debugger
454 set TMGMsg=0 ;"ensure $ZSTEP is not turned back on.
455 quit
456
457
458HndlScrW ;
459 ;"Purpose: Handle option to set screen width
460 new tempWidth
461 read "Enter screen width: ",tempWidth,!
462 if (+tempWidth>10) set TMGScrWidth=tempWidth,ScrWidth=tempWidth
463 set tpBlankLine=" "
464 for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" "
465 write # ;"clear screen
466 do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,,ViewOffset,LROffset,.CsrOnBreakline) ;"<---- not working!
467 quit
468
469HndlExpand ;
470 ;"Purpose: handle option to expand one mumps like of code.
471 new expPos,zbLabel,zbOffset,zbRoutine
472 do ParsePos^TMGIDE(tmgIDEPos,.zbLabel,.zbOffset,.zbRoutine)
473 set expPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine
474 write !
475 do ExpandLine^TMGIDE(expPos)
476 new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600)
477 quit
478
479HndlStack(ShowPos,ViewOffset) ;
480 ;"Purpose: Handle option to show and interact with stack.
481 ;"Input: ShowPos -- OPTIONAL. PASS BY REFERENCE. Will be changed to user selected value.
482 ;" ViewOffset -- OPTIONAL. PASS BY REFERENCE. Will be changed to 0 if user selects new Pos.
483 ;"Globally scoped vars used: tmgOrigIDEPos
484 write ! ;"get below bottom line for output.
485 new Stack do GetStackInfo(.Stack,tmgOrigIDEPos)
486 new Menu set Menu(0)="Pick Stack Entry to BROWSE TO"
487 new menuI set menuI=1
488 new TMGi for TMGi=1:1 quit:($get(Stack(TMGi))="") do
489 . new $etrap set $etrap="set $etrap="""",$ecode="""""
490 . new addr set addr=$piece($$TRIM^XLFSTR(Stack(TMGi))," ",2)
491 . new txt set txt=$$TRIM^XLFSTR($text(@addr))
492 . set txt=$$TRIM^XLFSTR(txt,$char(9))
493 . new line set line=addr_" Code: "_txt
494 . if $length(line)>TMGScrWidth set line=$extract(line,1,TMGScrWidth-10)_"..."
495 . set Menu(menuI)=line_$char(9)_addr
496 . set menuI=menuI+1
497 new UsrSlct set UsrSlct=$$Menu^TMGUSRIF(.Menu)
498 write "User selection: [",UsrSlct,"]",!
499 if (UsrSlct["^")&($length(UsrSlct)>1) do
500 . set ShowPos=UsrSlct
501 . set ViewOffset=0
502 write # ;"clr screen.
503 quit
504
505HndlNodes ;
506 ;"Purpse: Handle option to browse a variable by nodes.
507 new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999))
508 write ! ;"get below bottom line for output.
509 do BRWSASK2^TMGMISC
510 quit
511
512HndlBrowse ;
513 ;"Purpose: Handle option to browse a variable.
514 new varName set varName=$$Trim^TMGIDE($extract(origAction,7,999))
515 write ! ;"get below bottom line for output.
516 do BRWSNOD2^TMGMISC(varName)
517 quit
518
519HndlBrkCond ;
520 ;"Purpose: Handle option to browse conditional break
521 write "Enter an IF condition. Examples: 'A=1' or '$$FN1^MOD(A)=2'",!
522 read "Enter IF condition (^ to cancel, @ to delete): ",tpLine,!
523 if (tpLine="^") quit
524 new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName)
525 do SetBrkCond(brkPos,tpLine)
526 quit
527
528HndlCstBrk ;
529 ;"Purpose: Set a custom breakpoint
530 new brkPos
531 read !,"Enter breakpoint (e.g. Label+8^MyFunct): ",brkPos,!
532 do SetBreakpoint(brkPos)
533 quit
534
535HndlSetBrk ;
536 ;"Purpose: Set breakpoint at current point
537 ;"write !,"Trying to determine correct breakpoint. relPos=",relPos," ViewOffset=",ViewOffset,!
538 new brkPos set brkPos=$$RelConvertPos^TMGIDE(relPos,ViewOffset,ArrayName)
539 ;"write "brkPos=",brkPos,!
540 if brkPos="" write "relPos=",relPos," view offset=",ViewOffset," ArrayName=",ArrayName,!
541 do ToggleBreakpoint(brkPos)
542 quit
543
544HndlTable ;
545 ;"Purpose: Handle option for Table command
546 if +$get(tmgDbgRemoteJob) do
547 . new temp set temp=$$MessageOut("TABLE")
548 . if temp="" quit
549 . new i set i=""
550 . for set i=$order(@temp@(i)) quit:(i="") do
551 . . new j set j=""
552 . . for set j=$order(@temp@(i,j)) quit:(j="") do
553 . . . write $get(@temp@(i,j)),!
554 else do
555 . write ! ;"get below bottom line for output.
556 . zshow "*"
557 new tempKey read " --- Press Enter To Continue--",tempKey:$get(DTIME,3600)
558 quit
559
560HndlJmpDisp(ShowPos,ViewOffset)
561 ;"Purpose: to allow user to enter in a location to show in code displayer
562 ;"Input: ShowPos : PASS BY REFERENCE. The new location to change to
563 ;" ViewOffset : PASS BY REFERECE. Will be changed to 0 if ShowPos changed.
564 new tempLoc
565 write "(Example: MYLABL+2^MYCODE)",!
566 write "Enter location to jump display to: "
567 read tempLoc:$get(DTIME,999),!
568 if (tempLoc'="^")&(tempLoc["^")&(tempLoc'[" ") do
569 . if $TEXT(@tempLoc)'="" do
570 . . set ShowPos=tempLoc
571 . . set ViewOffset=0
572 . else do
573 . . write "Sorry. No code found at ",tempLoc,!
574 . . do PressToCont^TMGUSRIF
575 quit
576 ;
577HndlHelp ;
578 ;"Purpose: Handle option for help.
579 do Box
580 do SetColors("NORM")
581 do CUP^TMGTERM(1,2) ;"Cursor to line (1,2)
582 do HlpWrite(" {L} : Run sLow mode | {M} : exec M code | {SHOW [var]} : show [var]")
583 do HlpWrite(" {O} : Step OVER line | {I} : step INTO line | {STACK} : stack show/jump")
584 do HlpWrite(" {R} : Run | {T} Step OUT | {H} : Hide debug code | {CLS} : clear screen")
585 do HlpWrite(" {B} : Toggle Brkpoint | {C} : Custom breakpoint| {BC} : breakpoint code")
586 do HlpWrite(" {W} : Set watch code | {W +MyVar} :Watch MyVar| {W -MyVar} :Remove watch")
587 do HlpWrite(" {A},{AA} : Scroll up | {Z},{ZZ} : Scroll down | {W +^} : Add Naked Ref")
588 do HlpWrite(" {[},{[[} : Scroll left | {]},{]]} : Scroll right | {W +*} : Watch Var changes")
589 do HlpWrite(" {X} : Turn off debug | {Q} : Abort | {BROWSE} [var] : browse [var]")
590 do HlpWrite(" {-},{+} : Screen width | {=} : Enter width | {HIDE} : manage/hide modules")
591 do SetColors("SPECIAL")
592 do PressToCont^TMGUSRIF
593 do Box
594 do SetColors("NORM")
595 do CUP^TMGTERM(1,2) ;"Cursor to line (1,2)
596 do HlpWrite(" {TABLE} : Symbol table | {NODES} : Browse var | {INITKB} : restore key fn")
597 do HlpWrite(" {J} : Jump display | {FULL} : Undo Scrl Zone | {E} : expand current line")
598 do HlpWrite(" {UCASE} : Force U Case | {LCASE} : Force L Case | {COLORS} : Edit colors ")
599 do HlpWrite(" {XCMD} : Force ExpndCmd| {SCMD} : Force ShrtnCmd | {TRACE} : Show Trace ")
600 do HlpWrite(" {VDIFF} : Show Var Chng| {TVDIFF} Toggle TraceVar| {RESYNC} : sync display ")
601 ;"write HlpWrite(" "),!
602 do SetColors("SPECIAL")
603 do PressToCont^TMGUSRIF
604 do SetColors("Reset")
605 quit
606 ;
607HlpWrite(line)
608 for quit:($length(line)'>0) do
609 . if $find(line,"{")>0 do
610 . . new part set part=$piece(line,"{",1)
611 . . do SetColors("NORM")
612 . . write part
613 . . set line=$piece(line,"{",2,999)
614 . . set part=$piece(line,"}",1)
615 . . do SetColors("SPECIAL")
616 . . write part
617 . . set line=$piece(line,"}",2,999)
618 . else do
619 . . do SetColors("NORM")
620 . . write line,!
621 . . set line=""
622 do SetColors("NORM")
623 quit
624
625ErrTrap(tmgIDEPos)
626 ;"Purpose: This is the line that is called by GT.M for each ztrap event.
627 ;" It will be used to display the current code execution point
628 if $$ShouldSkip($piece(tmgIDEPos,"^",2)) DO
629 . write !,"Error at ",$P($ZSTATUS,",",2)," -- in code that debugger can't display.",!
630 . write "Error is: ",$P($ZSTATUS,",",3,99),!
631 . write !,"Dropping to command line via BREAK",!
632 . BREAK
633 new ScrHeight,ScrWidth
634 set ScrHeight=$get(TMGScrHeight,10)
635 set ScrWidth=$get(TMGScrWidth,70)
636 do VCUSAV2^TMGTERM
637 do ShowCode(tmgIDEPos,ScrWidth,ScrHeight,0)
638ETDone do VCULOAD2^TMGTERM
639 quit
640
641
642ShowCode(ShowPos,ScrWidth,ScrHeight,Wipe,ViewOffset,LROffset,CsrOnBreakline)
643 ;"Purpose: This will display code at the top of the screen
644 ;"Input: ShowPos -- string like this: X+2^ROUTINE[$DMOD]
645 ;" ScrWidth -- width of code display (Num of columns)
646 ;" ScrHeight -- height of code display (number of rows)
647 ;" Wipe -- OPTIONAL. if 1, then code area is wiped blank
648 ;" ViewOffset -- OPTIONAL. If a value is supplied, then
649 ;" the display will be shifted up or down (i.e. to view
650 ;" code other than at the point of execution)
651 ;" Positive numbers will scroll page downward.
652 ;" LROffset -- OPTIONAL. if value > 0 then the display
653 ;" of each line will begin with this number character.
654 ;" (i.e. will shift screen so that long lines can be seen.)
655 ;" 0->no offset; 1->no offset (start at character 1); 2->offset 1
656 ;" CsrOnBreakline -- OPTIONAL. PASS BY REFERENCE. Will return 1
657 ;" if cursor is on a break line, otherwise 0
658
659 new cdLoop,scRoutine,scLabel,scOffset,scS
660 new LastRou,LastLabel,LastOffset
661 new dbFGColor,bBGColor,nlFGColor,nlBGColor
662 new StartOffset,scCursorLine,cbLineLen
663 new zBreakIdx set zBreakIdx=-1
664 new TMGdbgJNum set TMGdbgJNum=$J
665 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
666 new zArrayName set zArrayName=$name(^TMG("TMGIDE",TMGdbgJNum,"MODULES"))
667 set ScrWidth=$get(ScrWidth,80)
668 set ScrHeight=$get(ScrHeight,10)
669 set LROffset=+$get(LROffset,1)
670 new ideBlankLine set $piece(ideBlankLine," ",ScrWidth-1)=""
671 do CUP^TMGTERM(1,1) ;"Cursor to line (1,1)
672 if $get(Wipe)=1 do goto SCDone ;"Blank screen and then quit
673 . do SetColors("Reset")
674 . for cdLoop=0:1:ScrHeight+1 write ideBlankLine,!
675
676 set scS=$piece(ShowPos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
677 do ParsePos^TMGIDE(scS,.scLabel,.scOffset,.scRoutine)
678 if scRoutine="" do goto SCDone
679 . write !,!,"Error -- invalid position provided to ShowCode routine: ",ShowPos,!
680 . write "scS=",scS,!
681
682 ;"setup to show a symbol for breakpoint
683 new zbS set zbS=""
684 for set zbS=$order(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",zbS)) quit:(zbS="") do
685 . new zbRoutine,zbLabel,zbOffset
686 . new tempPos set tempPos=$$ConvertPos^TMGIDE(zbS,zArrayName)
687 . do ParsePos^TMGIDE(tempPos,.zbLabel,.zbOffset,.zbRoutine)
688 . if zbRoutine'=scRoutine quit
689 . if zbLabel'=scLabel quit
690 . set zBreakIdx(zbOffset)=1
691
692 if scOffset>(ScrHeight) set StartOffset=(scOffset-ScrHeight)+2
693 else set StartOffset=0
694 set StartOffset=StartOffset+$get(ViewOffset)
695
696 ;"====Draw the top line ==========================================
697 do SetColors("NORM")
698 write "=== "
699 do SetColors("SPECIAL")
700 set scS="Routine: "_scLabel_"^"_scRoutine_" "
701 if $data(tmgOrigIDEPos) set scS=scS_"("_tmgOrigIDEPos_")"
702 else set scS=scS_"("_ShowPos_")"
703 write scS
704 do SetColors("NORM")
705 write " "
706 for cdLoop=1:1:ScrWidth-$length(scS)-5 write "="
707 do SetColors("NORM")
708 write !
709
710 set CsrOnBreakline=0
711 for cdLoop=StartOffset:1:(StartOffset+ScrHeight) do
712 . do SetColors("NORM")
713 . do SetTempBkColor("Reset")
714 . new cbLine,cbRef,cbCursor,cBrkLine
715 . set cBrkLine=$data(zBreakIdx(cdLoop))
716 . set cbRef=scLabel_"+"_cdLoop_"^"_scRoutine
717 . set cbLine=$text(@cbRef)
718 . set cbLine=$$Substitute^TMGIDE(cbLine,$Char(9)," ")
719 . if LROffset>0 set cbLine=$extract(cbLine,LROffset,999)
720 . set scCursorLine=scOffset+$get(ViewOffset)
721 . new cHighCsrPos set cHighCsrPos=(cdLoop=scCursorLine)
722 . new cHighExecPos set cHighExecPos=(cdLoop=scOffset)
723 . if cHighCsrPos do SetTempBkColor("Highlight")
724 . if cHighExecPos do SetTempBkColor("HighExecPos")
725 . if cBrkLine do
726 . . if (cHighCsrPos=0)&(cHighExecPos=0) do
727 . . . do SetTempBkColor("HighBkPos")
728 . . else do
729 . . . do SetTempBkColor("BkPos")
730 . . . set CsrOnBreakline=1
731 . write $select(cdLoop=scOffset:">",cBrkLine:"#",1:" ")
732 . do SetColors("SPECIAL")
733 . if cdLoop>0 write "+"_cdLoop_$select(cdLoop<10:" ",1:"")
734 . else write " "
735 . do SetColors("NORM")
736 . if $length(cbLine)>(ScrWidth-1) set cbLine=$extract(cbLine,1,ScrWidth-4)_"..."
737 . set cbLineLen=$length(cbLine)
738 . new StartPos set StartPos=$X
739 . if $get(TMGDEBUG) write cbLine ;"temp
740 . else set cbLineLen=$$ShowLine^TMGIDE6(cbLine,.tmgDbgOptions,ScrWidth-StartPos)
741 . write $extract(ideBlankLine,cbLineLen,ScrWidth-StartPos-1)
742 . do SetTempBkColor("Reset"),SetColors("NORM")
743 . write !
744
745 ;"Draw bottom line.
746 do SetColors("NORM")
747 ;"do SetColors("SPECIAL")
748 for cdLoop=1:1:ScrWidth write "~"
749 ;"do SetColors("NORM")
750 write !
751SCDone ;
752 do VTATRIB^TMGTERM(0) ;"reset colors
753 quit
754
755SetTempBkColor(mode)
756 set mode=$get(mode) quit:mode=""
757 new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS"))
758 if mode="Reset" kill @ref@("TEMP BACKGROUND") quit
759 if "Highlight,HighExecPos,BkPos,HighBkPos"'[mode quit
760 if $data(@ref)=0 do InitColors^TMGIDE6
761 new bg set bg=$get(@ref@(mode))
762 if bg="" quit
763 set @ref@("TEMP BACKGROUND")=bg
764 quit
765 ;
766SetColors(mode)
767 ;"Purpose: set colors in central location
768 ;"Input: Mode -- the mode to change the colors to
769 ;" bg -- OPTIONAL -- the default background. Default=15
770 set mode=$get(mode,"Reset") if mode="" set mode="Reset"
771 new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS"))
772 if $data(@ref)=0 do InitColors^TMGIDE6
773 if mode="Reset" do VTATRIB^TMGTERM(0) goto SCDn ;"reset colors
774 new colorSet merge colorSet=@ref@(mode) ;"Get colors for mode
775 new fg set fg=$get(colorSet("fg"),15)
776 new bg set bg=$get(colorSet("bg"),15)
777 if (bg="@") do
778 . set bg=$get(@ref@("TEMP BACKGROUND"),"@")
779 . if bg="@" set bg=$get(@ref@("BACKGROUND"),0)
780 if fg=bg do
781 . if (fg<15) set fg=fg+1
782 . else if (fg>0) set fg=fg-1
783 do VCOLORS^TMGTERM(fg,bg)
784SCDn quit;
785 ;
786Box ;
787 ;"Purpose: Draw a box on the top of the screen.
788 ;"Globals Scope Vars used: ScrWidth,ScrHeight
789 set ScrWidth=$get(ScrWidth,80)
790 set ScrHeight=$get(ScrHeight,10)
791 new ideBlankLine set $piece(ideBlankLine," ",ScrWidth)=" "
792 new ideBarLine set $piece(ideBarLine,"=",ScrWidth)="="
793 do CUP^TMGTERM(1,1) ;"Cursor to line (1,1)
794 do SetColors("Highlight")
795 write ideBarLine,!
796 do SetColors("NORM")
797 new cdLoop for cdLoop=0:1:ScrHeight+1 write ideBlankLine,!
798 do SetColors("Reset")
799 quit
800 ;
801GetStackInfo(Stack,ExecPos)
802 ;"Purpose: to query GTM and get back filtered Stack information
803 ;"Input: Stack -- PASS BY REFERENCE. An array to received back info. Old info is killed
804 ;" ExecPos -- OPTIONAL. Current execution position
805 kill Stack
806 new i,count set count=1
807 if $STACK<3 quit ;"0-2 are steps getting into debugger
808 for i=0:1:$STACK do ;"was 3:1:
809 . new s set s=$STACK(i,"PLACE")
810 . if s["TMGIDE" quit
811 . if s["GTM$DMOD" quit
812 . if s="@" set s=s_""""_$STACK(i,"MCODE")_""""
813 . if s=$get(ExecPos) set s=s_" <--Current execution point" ;",i=$STACK+1
814 . set Stack(count)=$STACK(i)_" "_s
815 . set count=count+1
816 quit
817
818
819ToggleBreakpoint(pos,condition)
820 ;"Purpose: to set or release the GT.M breakpoint at position
821 ;"Input: pos -- the position to alter
822 ;" condition -- OPTIONAL -- should be contain valid M code such that
823 ;" if @condition is valid. Examples:
824 ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1
825 ;"write "Here in ToggleBreakoint",!
826 if $$IsBreakpoint(pos) do
827 . ;"write " calling RelBreakpoint",!
828 . do RelBreakpoint(pos)
829 else do
830 . ;"write "calling Set breakpoint",!
831 . do SetBreakpoint(pos,.condition)
832 quit
833
834IsBreakpoint(pos)
835 ;"Purpose: to determine if position is a breakpoint pos
836
837 ;"Note: I am concerned that pos might contain a name longer than 8 chars
838 ;" and might give a false result, or ^TMP(...) might hold a name
839 ;" longer than 8 chars.
840 ;" BUT, if I just cut name off at 8 chars, it might not work well
841 ;" with GTM v5
842 new result set result=0
843 new TMGdbgJNum set TMGdbgJNum=$J
844 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
845 if $get(pos)'="" set result=$data(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos))
846 quit (result'=0)
847
848
849EnsureBreakpoints()
850 ;"Purpose: When an module is recompiled, GT.M drops the breakpoints for
851 ;" that module. However, the breakpoints are still stored for this
852 ;" debugger, meaning that the lines will still be highlighted etc,
853 ;" --but they don't work. This function will go through stored
854 ;" breakpoints and again register them with GT.M
855
856 new pos set pos=""
857 new TMGdbgJNum set TMGdbgJNum=$J
858 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
859 for set pos=$order(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)) quit:(pos="") do
860 . do SetBreakpoint(pos)
861 quit
862
863
864SetBreakpoint(pos,condition)
865 ;"Purpose: set the GT.M breakpoint to pos position
866 ;"Input: pos -- the position to alter
867 ;" condition -- OPTIONAL -- should be contain valid M code such that
868 ;" if @condition is valid. Examples:
869 ;" i=1 or $data(VAR)=0 or $$MyFunct(var)=1
870 ;"Globally scoped var used:
871 ;" tmgDbgRemoteJob-- OPTIONAL -- if controlling a remote process, then = $J of that process
872 ;" and action should not be done locally.
873 if $get(pos)="" do goto SBkDone
874 . write "?? no position specified ??",!
875 ;
876 new TMGdbgJNum set TMGdbgJNum=$J
877 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
878 set ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)=""
879 do SetBrkCond(pos,.condition)
880 ;
881 if $get(tmgDbgRemoteJob) do
882 . new temp set temp=$$MessageOut("BKPOS "_pos_" "_$get(condition))
883 . write "Results from remote process=",temp,!
884 else do
885 . new brkLine set brkLine=pos_":""n tmg s tmgRunMode=1 s tmg=$$STEPTRAP^TMGIDE2($ZPOS,1)"""
886 . new $etrap
887 . set $etrap="K ^TMG(""TMGIDE"",$J,""ZBREAK"",pos) S $ETRAP="""",$ECODE="""""
888 . ZBREAK @brkLine
889SBkDone quit
890
891
892SetBrkCond(pos,condition)
893 ;"Purpose: A standardized SET for condition.
894 ;"Input: pos --
895 ;" condition --
896 if $get(condition)="" quit
897 if $get(pos)="" quit
898 new TMGdbgJNum set TMGdbgJNum=$J
899 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
900 if condition="@" kill ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF")
901 else set ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF")=condition
902 if $$IsBreakpoint(pos)=0 do SetBreakpoint(pos)
903 quit
904
905
906GetBrkCond(pos)
907 ;"Purpose: A standardized GET for condition.
908 ;"Results: returns condition code, or ""
909 new result set result=""
910 new TMGdbgJNum set TMGdbgJNum=$J
911 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
912 set:(pos'="") result=$get(^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos,"IF"))
913 quit result
914
915RelBreakpoint(pos)
916 ;"Purpose: to release a GT.M breakpoint at position
917 new TMGdbgJNum set TMGdbgJNum=$J
918 if +$get(tmgDbgRemoteJob) set TMGdbgJNum=+tmgDbgRemoteJob
919 kill ^TMG("TMGIDE",TMGdbgJNum,"ZBREAK",pos)
920 if $get(tmgDbgRemoteJob) do goto SBkDone
921 . new temp set temp=$$MessageOut("RELBKPOS "_pos)
922 else do
923 . new brkLine set brkLine=pos_":""zcontinue"""
924 . ZBREAK @brkLine
925 ;"write "released breakpoint at: ",pos,!
926 quit
927
928
929ShouldSkip(module)
930 ;"Purpose: to see if module is in hidden list
931 new result set result=0
932 if $get(TMGdbgHideList)="" goto SSKDone
933
934 new HideMod set HideMod=""
935 for set HideMod=$order(@TMGdbgHideList@(HideMod)) quit:(HideMod="")!(result=1) do
936 . if (module=HideMod) set result=1 quit
937 . if HideMod'["*" quit
938 . new tempMod set tempMod=$extract(HideMod,1,$find(HideMod,"*")-2)
939 . new trimModule set trimModule=$extract(module,1,$length(tempMod))
940 . set result=(trimModule=tempMod)
941SSKDone
942 quit result
943
944
945SetupSkips
946 ;"Purpose: to manage modules that are to be skipped over.
947 ;"Input: none. But this modifies variable @TMGdbgHideList with global scope
948 ;"results: none
949
950 ;"For some reason, this gets lost at times....
951 if $data(TMGdbgHideList)=0 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST"))
952
953 new menu,option
954 set menu(0)="Pick Options for Hiding/Showing Modules"
955 set menu(1)="SHOW current hidden list"_$c(9)_"SHOW"
956 set menu(2)="ADD module to hidden list"_$c(9)_"ADD"
957 set menu(3)="REMOVE module from hidden list"_$c(9)_"REMOVE"
958 set menu(4)="Done."_$c(9)_"^"
959
960StSkp set option=$$Menu^TMGUSRIF(.menu)
961 if option="SHOW" do ShowSkip
962 if option="ADD" do AddSkip
963 if option="REMOVE" do RmSkip
964 if option="^" goto StSkDone
965 goto StSkp
966
967StSkDone
968 quit
969
970AddSkip
971 ;"Purpose: to allow user to Add a module to hidden list
972 ;"Input: none. But this modifies variable @TMGdbgHideList with global scope
973 ;"results: none
974
975ASKP1 write "Enter name of module to add to hidden list (? for help, ^ to abort)",!
976 new mod
977 read "Enter module: ",mod:$get(DTIME,3600),!
978 if mod="?" do goto ASKP1
979 . write "Some modules of the code are not helpful to debugging one's code.",!
980 . write "For example, if one did not ever want to trace into the code stored",!
981 . write "in DIC, then DIC would be added as a module to be hidden. Then, when",!
982 . write "debugging one's own code, all traces into ^DIC would be skipped over.",!
983 . write "If only part of the name is specified, then ALL modules starting with",!
984 . write "this name will be excluded.",!
985 . do PressToCont^TMGUSERIF
986 if mod="^" goto ASDone
987 write "Add '",mod,"' as a module to be skipped over"
988 new % set %=1
989 do YN^DICN
990 if $data(TMGdbgHideList)=0 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST"))
991 if %=1 set @TMGdbgHideList@(mod)=""
992
993ASDone
994 quit
995
996RmSkip
997 ;"Purpose: to allow user to remove a module from hidden list
998 ;"Input: none. But this modifies variable @TMGdbgHideList with global scope
999 ;"results: none
1000
1001 new menu,option,idx
1002RmL1 kill menu
1003 set idx=0
1004 new mod set mod=""
1005 ;"Load menu with current list.
1006 for set mod=$order(@TMGdbgHideList@(mod)) quit:(mod="") do
1007 . set idx=idx+1,menu(idx)=mod_$c(9)_mod
1008 if $data(menu)=0 goto RmSkipDone
1009 . write "--The list is currently empty--"
1010 . do PressToCont^TMGUSRIF
1011 set idx=idx+1
1012 set menu(idx)="Done"_$c(9)_"^"
1013 set menu(0)="Pick Module to remove from hidden list"
1014 set option=$$Menu^TMGUSRIF(.menu)
1015 if option="^" goto RmSkipDone
1016 kill @TMGdbgHideList@(option)
1017 goto RmL1
1018
1019RmSkipDone
1020 quit
1021
1022
1023ShowSkip
1024 ;"Purpose: to show the hidden list
1025 ;"Input: none. But this uses variable @TMGdbgHideList with global scope
1026 ;"results: none
1027
1028 new mod set mod=""
1029 if $data(@TMGdbgHideList)>0 do
1030 . for set mod=$order(@TMGdbgHideList@(mod)) quit:(mod="") do
1031 . . write " ",mod,!
1032 else do
1033 . write "--The list is currently empty--"
1034 do PressToCont^TMGUSRIF
1035 quit
1036
1037
1038 ;"=============================================
1039 ;" Code for when controlling another process
1040 ;"=============================================
1041
1042MessageOut(Msg,timeOutTime,ignoreReply)
1043 ;"Purpose: For use when in remote-control debugging mode. This will
1044 ;" send a message to SENDER, not waiting for a reply
1045 ;"Input: Msg -- the message to send
1046 ;" timeOutTime -- OPTIONAL, default is 2 seconds
1047 ;" ignoreReply -- OPTIONAL, default is 0 (don't ignore)
1048 ;"Output: the returned message, or "" if timed out or no reply, or ignoreReply=1
1049
1050 set timeOutTime=$get(timeOutTime,2)
1051 set ignoreReply=$get(ignoreReply,0)
1052 new result set result=""
1053 set Msg="[CMD] "_$get(Msg)
1054 set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")=Msg
1055 set ^TMG("TMGIDE","CONTROLLER","MSG-IN")=""
1056 if (ignoreReply=0) for do quit:(result'="")!(timeOutTime<0)
1057 . set result=$get(^TMG("TMGIDE","CONTROLLER","MSG-IN"))
1058 . if (result'="") quit
1059 . set timeOutTime=timeOutTime-0.1
1060 . set ^TMG("TMGIDE","CONTROLLER","MSG-OUT")=Msg
1061 . hang 0.1
1062 if $piece(result," ",1)="[RSLT]" do
1063 set result=$piece(result," ",2,999)
1064 else do
1065 . write !,"Unexpected reply: ",result,!
1066 . do PressToCont^TMGUSRIF
1067 . set result=""
1068
1069 quit result
1070
1071
1072GetRemoteVar(varName)
1073 ;"Purpose: Pass varName to remote process, have it evaluated there, and
1074 ;" then passed back back here for display.
1075 ;"Input: varName -- expression (variable name, or function) to be evaluated.
1076 new temp set temp=$$MessageOut("EVAL "_$get(varName))
1077 kill @varName
1078 if (temp="")!(temp[" ") do goto GMVD
1079 . write !,"Unexpected var name back: [",temp,"]",!
1080 . set temp=""
1081 merge @varName=@temp
1082GMVD quit varName
1083
1084
1085RemoteXecute(MCode)
1086 ;"Purpose: Pass M Code to remote process for execution there.
1087 ;"Input: A line of M code, as entered by user.
1088 ;"Results: none
1089 ;"Output: Any IO of M code should be shown in other process's IO
1090 new temp set temp=$$MessageOut("XECUTE "_$get(MCode))
1091 quit
Note: See TracBrowser for help on using the repository browser.