source: cprs/branches/tmg-cprs/m_files/TMGIDE.m@ 1742

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

replacing soft links with actual files

File size: 38.3 KB
RevLine 
[896]1TMGIDE ;TMG/kst/A debugger/tracer for GT.M ;03/25/06 ; 5/14/10 6:17pm
2 ;;1.0;TMG-LIB;**1**;03/29/09
3
4 ;" A Debug/Tracer for GT.M
5 ;"
6 ;" K. Toppenberg
7 ;" (c) 4-13-2005
8 ;" License: LGPL Applies
9 ;"
10 ;"
11 ;" This program will launch a shell for the TMG STEP TRAP debugger
12 ;" It provides the user with a prompt, like this:
13 ;"
14 ;" (^ to quit) IDE>
15 ;"
16 ;" Any valid M code may be entered here. To use the tracing
17 ;" ability, launch a function, like this:
18 ;"
19 ;" (^ to quit) IDE>do ^MyFunction
20 ;"
21 ;"
22 ;" Dependancies:
23 ;" Uses TMGIDE2,TMGTERM,TMGUSRIF
24 ;" ^DIM,XGF,XINDX7,XINDX8,XINDEX <-- VA code
25 ;" %ZVEM* (if available)
26 ;"
27 ;"=======================================================================
28 ;" API -- Public Functions.
29 ;"=======================================================================
30 ;"Start^TMGIDE -- launch Debugger
31 ;"BKPT^TMGIDE -- set a breakpoint
32 ;"KBKPT^TMGIDE -- kill (release) breakpoint
33
34 ;"=======================================================================
35 ;"PRIVATE API FUNCTIONS
36 ;"=======================================================================
37 ;"Prompt
38 ;"ShutDown
39 ;"ParsePos(pos,label,offset,routine,dmod)
40 ;"ConvertPos(Pos,pArray)
41 ;"ScanMod(Module,pArray)
42 ;"BROWSENODES(current,Order,paginate,countNodes)
43 ;"ShowNodes(pArray,order,paginate,countNodes)
44 ;"ListCt(pArray)
45 ;"TrimL(S,TrimCh)
46 ;"TrimR(S,TrimCh)
47 ;"Trim(S,TrimCh)
48 ;"Substitute(S,Match,NewValue)
49 ;"REPLACE(IN,SPEC)
50 ;"DebugWrite(DBIndent,s,AddNewline)
51 ;"DebugIndent(DBIndentForced)
52 ;"$$ArrayDump(ArrayP,TMGIDX,indent)
53 ;"ExpandLine(Pos)
54 ;"CREF(X)
55 ;"LGR()
56 ;"UP(X)
57 ;"READ(XGCHARS,XGTO)
58 ;"READ2(XGCHARS,XGTO)
59
60 ;"------------------------------------------------------------
61 ;"------------------------------------------------------------
62
63START
64Start
65 ;"Purpose: To Launch debugger. This is the entry point
66 ;
67 new tmgDbgOptions
68 set tmgDbgOptions("TRACE")=0 ;"Turn off trace record by default
69 set tmgDbgOptions("VARTRACE")=0 ;"Turn off trace vars by default
70 kill ^TMG("TMGIDE",$J,"TRACE") ;"Delete former trace record when starting new run
71 kill ^TMG("TMGIDE",$J,"VARTRACE") ;"Delete former var trace record when starting new run
72 ;
73 set $ZSTEP="" ;"Temporarily clear, in case active from prior run. <-- doesn't work...
74 do EnsureEnv ;"Ensure fileman environment setup.
75 do ClrDeadInfo ;"clear out any old data from dead jobs.
76 ;"Set up variables with global scope (used by TMGIDE2)
77 if $$GetScrnSize^TMGKERNL(,.TMGScrWidth)
78 if $get(TMGScrWidth)="" set TMGScrWidth=$get(IOM,66)-1
79 if $get(TMGScrHeight)="" set TMGScrHeight=10
80 set TMGLROffset=0
81 set TMGTrap=1
82 set tmgStepMode="into"
83 set tmgRunMode=1
84 set TMGZTRAP=$ZTRAP
85
86 new TMGdbgHideList
87 set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST"))
88 kill @TMGdbgHideList
89 if 1=1 do
90 . set @TMGdbgHideList@("TMGIDE*")=""
91 else do
92 . set @TMGdbgHideList@("TMGIDE")=""
93 . set @TMGdbgHideList@("TMGIDE1")=""
94 . set @TMGdbgHideList@("TMGIDE2")=""
95 . set @TMGdbgHideList@("TMGIDE3")=""
96 . set @TMGdbgHideList@("TMGIDE4")=""
97 . set @TMGdbgHideList@("TMGIDE5")=""
98 . ;"set @TMGdbgHideList@("TMGIDE6")=""
99 set @TMGdbgHideList@("TMGTERM")=""
100 set @TMGdbgHideList@("TMGSTUTL")=""
101 set @TMGdbgHideList@("X*")=""
102 set @TMGdbgHideList@("%*")=""
103 ;"set @TMGdbgHideList@("DI*")=""
104 set @TMGdbgHideList@("%ZVE")=""
105 set @TMGdbgHideList@("%ZVEMK")=""
106 set @TMGdbgHideList@("XLFSTR")=""
107 set @TMGdbgHideList@("XGF")=""
108 set @TMGdbgHideList@("XGKB")=""
109
110 do SetGlobals^TMGTERM
111 do EnsureBreakpoints^TMGIDE2()
112 do InitColors^TMGIDE6
113
114 new UsrSlct
115M1 new Menu
116 set Menu(0)="Welcome to the TMG debugging environment"
117 set Menu(1)="Start debugger in THIS window."_$char(9)_"AllInOne"
118 set Menu(2)="Start debugger CONTROLLER for another Process."_$char(9)_"StartController"
119 set Menu(3)="Debug, SENDING control to a Controller."_$char(9)_"StartSender"
120 set Menu(4)="Set a custom breakpoint"_$char(9)_"SetBreakpoint"
121 set Menu(5)="Kill a custom breakpoint"_$char(9)_"KillBreakpoint"
122 set Menu(6)="Debug ANOTHER PROCESS"_$char(9)_"Interrupt"
123 set Menu(7)="KILL ANOTHER PROCESS"_$char(9)_"KillOther"
124 set Menu(8)="Run ^ZJOB"_$char(9)_"ZJob"
125 set Menu(9)="View TRACE log from last run"_$char(9)_"Trace"
126
127 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^")
128 kill Menu ;"Prevent from cluttering variable table during debug run
129
130 if UsrSlct="AllInOne" goto MenuDone
131 if UsrSlct="StartController" do Controller^TMGIDE3 goto M1
132 if UsrSlct="StartSender" do Sender^TMGIDE4() goto M1
133 if UsrSlct="SetBreakpoint" do BKPT goto M1
134 if UsrSlct="KillBreakpoint" do KBKPT goto M1
135 if UsrSlct="Interrupt" do PICKINTR^TMGIDE5 goto M1
136 if UsrSlct="KillOther" do KillOther goto M1
137 if UsrSlct="ZJob" do ^ZJOB goto M1
138 if UsrSlct="Trace" do ShowTrace^TMGIDE6 goto M1
139 if UsrSlct="^" goto Done
140 if UsrSlct=0 set UsrSlct=""
141 goto M1
142
143MenuDone
144 do
145 . new i for i=1:1:10 write !
146 write !,"Welcome to the TMG debugging environment",!
147 write "Enter any valid M command...",!
148 do SetErrTrap
149 do Prompt("AllInOne")
150Done
151 do ShutDown
152 quit
153
154 ;"-------------------------------------------------------------------
155SetErrTrap
156 set $ZTRAP="do ErrTrap^TMGIDE2($ZPOS) break"
157 set $ZSTATUS=""
158 quit
159
160Prompt(Mode)
161 ;"Purpose: to interact with user and run through code.
162 ;"Mode: OPTIONAL: Default is 'AllInOne'
163 ;" AllInOne --> debug output to same window
164 ;" SendOut --> debug output to Controller widow
165
166 set Mode=$get(Mode,"AllInOne")
167 new ideBlankLine
168 new HxI set HxI=""
169 new TMGdbgLine set TMGdbgLine=""
170 new TMGlastline
171 set tmgStepMode="into"
172 do SetupVars
173 do INITKB^XGF() ;"set up keyboard input escape code processing
174
175Ppt2 do CHA^TMGTERM(1) write ideBlankLine
176 do CHA^TMGTERM(1) write "(^ to quit) //",TMGdbgLine
177 ;
178 set TMGdbgLine=$$Read^TMGUSRIF("er",1200,,TMGdbgLine,.tmgXGRT)
179 do INITKB^XGF()
180 do TranslateKeys(.TMGdbgLine,tmgXGRT)
181 ;
182 if TMGdbgLine="?" do ShowHelp goto Ppt2
183 if TMGdbgLine="<DN>" set TMGdbgLine=$$GetHx(.HxI,1) goto Ppt2
184 if TMGdbgLine="<UP>" set TMGdbgLine=$$GetHx(.HxI,-1) goto Ppt2
185 if TMGdbgLine="^" set $ZSTEP="" goto PptDne
186 ;
187 write !
188 do SaveHx(TMGdbgLine)
189 ;
190 set tmgRunMode=1 ;"1=Step-by-step mode
191 set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue"
192 zstep into
193 ;"consider wrapping the following line in an error trap. But would have to be cleared
194 ;" somehow to allow QUIT command...
195 xecute TMGdbgLine
196 set $ZSTEP="" ;"turn off step capture
197 write !
198 ;
199 if '$data(ideBlankLine) do SetupVars ;"without out this, crash after running ^XUP
200 set TMGdbgLine="",HxI=""
201 set tmgStepMode="into"
202 goto Ppt2 ;"loop for prompt again.
203PptDne quit
204
205TranslateKeys(UsrInput,tmgXGRT)
206 ;"Purpose: translate input keys into a standard output.
207 ;"Input: UsrInput -- PASS BY REFERENCE.
208 set tmgXGRT=$get(tmgXGRT)
209 if tmgXGRT="UP" set UsrInput="A"
210 if tmgXGRT="DOWN" set UsrInput="Z"
211 if tmgXGRT="RIGHT" set UsrInput="]"
212 if tmgXGRT="LEFT" set UsrInput="["
213 if (UsrInput="<AU>") set UsrInput="<UP>"
214 if (UsrInput="A") set UsrInput="<UP>"
215 if (UsrInput="<AD>") set UsrInput="<DN>"
216 if (UsrInput="Z") set UsrInput="<DN>"
217 if (UsrInput="<AL>") set UsrInput="<LEFT>"
218 if (UsrInput="[") set UsrInput="<LEFT>"
219 if (UsrInput="<AR>") set UsrInput="<RIGHT>"
220 if (UsrInput="]") set UsrInput="<RIGHT>"
221 ;"
222 if UsrInput="<RIGHT>" set UsrInput="<DN>"
223 if UsrInput="<LEFT>" set UsrInput="<UP>"
224 if UsrInput="" set UsrInput="^"
225 quit
226
227GetHx(HxI,Dir)
228 ;"Purpose: to retrieve saved Hx
229 ;"Input: HxI -- PASS BY REFERENCE. IN and OUT parameter
230 ;" This is index of last command retrieved (or should pass as "" if first time)
231 ;" Dir -- Optional. Default=1.
232 ;" 1 = get previous history item
233 ;" -1 = get next history item
234 ;"Result: returns history item line
235 new result set result=""
236 new HxRef set HxRef=$name(^TMG("TMGIDE",$J,"CMD HISTORY"))
237 set HxI=$order(@HxRef@(HxI),$get(Dir,1))
238 if HxI'="" set result=$get(@HxRef@(HxI))
239 quit result
240
241SaveHx(OneLine)
242 ;"Purpose: To provide interface to saving command line hx.
243 ;"Input: OneLine -- the line to store
244 ;"Output: Will store hx as follows:
245 ;" ^TMG('TMGIDE',$J,'CMD HISTORY',1)=1st line of Hx
246 ;" ^TMG('TMGIDE',$J,'CMD HISTORY',2)=2nd line of Hx
247 ;" ...
248 new HxRef set HxRef=$name(^TMG("TMGIDE",$J,"CMD HISTORY"))
249 new HxI set HxI=+$order(@HxRef@(""),-1)
250 if $get(@HxRef@(HxI))'=OneLine do
251 . set @HxRef@(HxI+1)=OneLine
252 quit
253
254ShowHelp
255 write !,"Here you should enter any valid M command, as would normally be",!
256 write "entered at a GTM> prompt.",!
257 write " Examples: WRITE ""HELLO"",! or DO ^TMGTEST",!
258 quit
259
260SetupVars
261 set Mode=$get(Mode,"AllInOne")
262 set $piece(ideBlankLine," ",78)=" "
263 set TMGlastLine=""
264 set HxShowNum=0
265 quit
266
267EnsureEnv
268 ;"Purpose: So ensure Fileman variables setup.
269 if $text(DT^DICRW)'="" do
270 . do DT^DICRW ;"ensure fileman's required variables are in place
271 if +$get(DUZ)'>0 do
272 . write "Entering TMG IDE. But first, let's set up an environment..."
273 . new DIC set DIC=200
274 . set DIC(0)="MAEQ"
275 . set DIC("A")="Please type your name: "
276 . set DIC("?")="Please enter your user name, to setup environmental variables."
277 . do ^DIC write !
278 . if +Y'>0 quit
279 . do DUZ^XUP(+Y)
280 quit
281
282
283ClrDeadInfo
284 ;"Purpose: to clear out any info from dead (prior) runs
285 new LiveJobs
286 do MJOBS^TMGKERNL(.LiveJobs)
287 new JNum set JNum=""
288 for set JNum=$order(^TMG("TMGIDE",JNum)) quit:(+JNum'>0) do
289 . if $get(TMGDEBUG) write "Job ",JNum," is "
290 . if $data(LiveJobs(JNum)) do quit
291 . . if $get(TMGDEBUG) write "still alive.",!
292 . if $get(TMGDEBUG) write "still dead... killing it's info.",!
293 . kill ^TMG("TMGIDE",JNum)
294 quit
295
296KillOther
297 ;"Purpose: To show currently running jobs, and allow user to kill on
298 ;"Called from TMGIDE
299 ;
300 new array
301K1 kill array
302 do MJOBS^TMGKERNL(.array)
303 kill array($J) ;"don't show this process
304 new Menu,UsrSlct
305 new i,j set i="",j=1
306 for set i=$order(array(i)) quit:(i="") do
307 . set Menu(j)="Job "_$get(array(i))_$char(9)_i
308 . set j=j+1
309 if $data(Menu)=0 do goto KODone
310 set Menu(0)="Pick Job to Kill/Terminate"
311 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^")
312 if UsrSlct="^" goto KODone
313 if UsrSlct=0 set UsrSlct="" goto K1
314 if UsrSlct=+UsrSlct do KillPID^TMGKERNL(UsrSlct) goto K1
315 goto K1
316KODone quit
317
318
319 ;"-------------------------------------------------------------------
320ShutDown
321 do KillGlobals^TMGTERM
322 kill tmgStepMode ;" 2/10/06 kt
323 kill ^TMP("TMGIDE",$J,"MODULES")
324 do VTATRIB^TMGTERM(0)
325 do RESETKB^XGF ;"turn off XGF escape key processing code.
326 write "Leaving TMG debugging environment. Goodbye.",!
327 quit
328
329 ;"-------------------------------------------------------------------
330BKPT
331 ;"Purpose: To ask user for an address, and set a breakpoint there
332 ;" This can be done from GTM prompt, and debugger will be launched
333 ;" when this address is reached during normal execution.
334
335 read "Enter breakpoint (e.g. Label+8^MyFunct): ",Pos,!
336 do SetBreakpoint^TMGIDE2(Pos)
337 set $ZTRAP="" ;"This makes sure that Fileman error trap is not active
338 quit
339
340
341KBKPT
342 ;"Purpose: To ask user for an address, and kill (release) breakpoint there
343 ;" This can be done from GTM prompt
344
345 read "Enter breakpoint to be killed (released) (e.g. Label+8^MyFunct): ",Pos,!
346 do RelBreakpoint^TMGIDE2(Pos)
347 quit
348
349
350 ;"------------------------------------------------------------
351 ;"------------------------------------------------------------
352 ;"Support Functions
353 ;"
354 ;"Note: I copied functions from other modules trying to reduce dependencies
355 ;"------------------------------------------------------------
356 ;"------------------------------------------------------------
357
358ParsePos(pos,label,offset,routine,dmod)
359 ;"NOTE: Duplicate of function in TMGMISC
360 ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts
361 ;"Input: pos -- the string, as example above
362 ;" label -- OUT PARAM, PASS BY REF, would return "x"
363 ;" offset -- OUT PARAM, PASS BY REF, would return "+2"
364 ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE"
365 ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD"
366 ;"Results: none
367 ;"Note: results are shortened to 8 characters.
368
369 new s
370 set s=$get(pos)
371 set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
372 set routine=$piece(s,"^",2)
373 ;"set routine=$extract(routine,1,8) //kt remove 3/1/08, new GTM needs > 8 chars
374 set label=$piece(s,"^",1)
375 set offset=$piece(label,"+",2)
376 set label=$piece(label,"+",1)
377 ;"set label=$extract(label,1,8) //kt remove 3/1/08, new GTM needs > 8 chars
378
379 quit
380
381
382ConvertPos(Pos,pArray)
383 ;"NOTE: Duplicate of function in TMGMISC
384 ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into
385 ;" one that is relative to the start of the file
386 ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT
387 ;"Input: Pos -- a position, as returned from $ZPOS
388 ;" pArray -- pointer to (name of). Array holding holding tag offsets
389 ;" pArray will be in this format:
390 ;" pArray("ModuleA",1,"TAG")="ALabel1"
391 ;" pArray("ModuleA",1,"OFFSET")=1
392 ;" pArray("ModuleA",2,"TAG")="ALabel2"
393 ;" pArray("ModuleA",2,"OFFSET")=9
394 ;" pArray("ModuleA","Label1")=1
395 ;" pArray("ModuleA","Label2")=2
396 ;" pArray("ModuleA","Label3")=3
397 ;" pArray("ModuleB",1,"TAG")="BLabel1"
398 ;" pArray("ModuleB",1,"OFFSET")=4
399 ;" pArray("ModuleB",2,"TAG")="BLabel2"
400 ;" pArray("ModuleB",2,"OFFSET")=23
401 ;" pArray("ModuleB","Label1")=1
402 ;" pArray("ModuleB","Label2")=2
403 ;" pArray("ModuleB","Label3")=3
404 ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it
405 ;"Result: returns the new position line, relative to the start of the file/module
406 ;"
407
408 new cpS
409 new cpResult set cpResult=""
410 new cpRoutine,cpLabel,cpOffset
411
412 set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE
413 if cpS="" do goto CPDone
414 . write "Parse error: Nothing before $ in",cpS,!
415
416 set cpRoutine=$piece(cpS,"^",2)
417 if cpRoutine="" do goto CPDone
418 . write "Parse error: No routine specified in: ",cpS,!
419
420 set cpS=$piece(cpS,"^",1)
421 set cpOffset=+$piece(cpS,"+",2)
422 ;"if cpOffset="" set cpOffset=1
423 ;"else set cpOffset=+cpOffset
424 set cpLabel=$piece(cpS,"+",1)
425
426 if $data(@pArray@(cpRoutine))=0 do
427 . new p2Array set p2Array=$name(@pArray@(cpRoutine))
428 . do ScanMod(cpRoutine,p2Array)
429
430 new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel))
431 if cpIdx=0 do goto CPDone
432 . ;"write "Parse error: Can't find ",cpRoutine,",",cpLabel," in stored source code.",!
433 new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET")
434 set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine
435
436CPDone
437 quit cpResult
438
439
440RelConvertPos(Pos,ViewOffset,pArray)
441 ;"Purpose: to convert a positioning line from one that is relative to
442 ;" the start of the file to one that is relative to the
443 ;" last tag/label
444 ;" e.g. +32^MYFUNCT --> START+8^MYFUNCT
445 ;" I.e. this function in the OPPOSITE of ConvertPos
446 ;"Input: Pos -- a position, as returned from $ZPOS
447 ;" ViewOffset -- the offset from the Pos to get pos for
448 ;" pArray -- pointer to (name of). Array holding holding tag offsets
449 ;" see Description in ConvertPos()
450 ;"Result: returns the new position line, relative to the start of the last tag/label
451
452 ;"write !,"Here in RelConvertPos. Pos=",Pos," ViewOffset=",ViewOffset,!
453 new zbRelPos,zbLabel,zbOffset,zbRoutine
454 do ParsePos^TMGIDE(Pos,.zbLabel,.zbOffset,.zbRoutine)
455 set zbRelPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine
456 new zbTemp set zbTemp=zbRelPos
457 ;"5/27/07 I don't know why following line was here. Removing.
458 ;"It was breaking the setting of breakpoints. I wonder if I have now
459 ;"broken conditional breakpoints... Figure that out later...
460 ;"set zbRelPos=$$ConvertPos^TMGIDE(zbRelPos,pArray)
461 if zbRelPos="" do
462 . write "Before ConvertPos, zbRelPos=",zbTemp,!
463 . write "Afterwards, zbRelPos=""""",!
464 ;"write "Done RelConvertPos. Result=",zbRelPos,!
465 quit zbRelPos
466
467
468ScanMod(Module,pArray)
469 ;"NOTE: Duplicate of function in TMGMISC
470 ;"Purpose: To scan a module and find all the labels/entry points/Entry points
471 ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF")
472 ;" pArray -- pointer to (NAME OF) array Will be filled like this
473 ;" pArray(1,"TAG")="Label1"
474 ;" pArray(1,"OFFSET")=1
475 ;" pArray(2,"TAG")="Label2"
476 ;" pArray(2,"OFFSET")=9
477 ;" pArray(3,"TAG")="Label3" etc.
478 ;" pArray(3,"OFFSET")=15
479 ;" pArray("Label1")=1
480 ;" pArray("Label2")=2
481 ;" pArray("Label3")=3
482 ;"
483 ;" NOTE: there seems to be a problem if the passed pArray value is "pArray",
484 ;" so use another name.
485 ;"
486 ;"Output: Results are put into array
487 ;"Result: none
488
489 new smIdx set smIdx=1
490 new LabelNum set LabelNum=0
491 new smLine set smLine=""
492 if $get(Module)="" goto SMDone
493 ;"look for a var with global scope to see how how many characters are significant to GT.M
494 if $get(zbSigNameLen)="" do
495 . set zbSigNameLen=$$NumSigChs^TMGMISC()
496
497 for do quit:(smLine="")
498 . new smCh
499 . set smLine=$text(+smIdx^@Module)
500 . if smLine="" quit
501 . set smLine=$$Substitute(smLine,$Char(9)," ") ;"replace tabs for 8 spaces
502 . set smCh=$extract(smLine,1)
503 . if (smCh'=" ")&(smCh'=";") do
504 . . new label
505 . . set label=$piece(smLine," ",1)
506 . . set label=$piece(label,"(",1) ;"MyFunct(X,Y) --> MyFunct
507 . . set label=$extract(label,1,zbSigNameLen)
508 . . set LabelNum=LabelNum+1
509 . . set @pArray@(LabelNum,"TAG")=label
510 . . set @pArray@(LabelNum,"OFFSET")=smIdx
511 . . set @pArray@(label)=LabelNum
512 . set smIdx=smIdx+1
513
514SMDone
515 quit
516
517
518
519BROWSENODES(current,Order,paginate,countNodes)
520 ;"NOTE: Duplicate of function in TMGMISC
521 ;"Purpose: to display nodes of specified array
522 ;"Input: Current -- The reference to display
523 ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order
524 ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page
525 ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes.
526
527 new parent,child
528 set parent=""
529 set order=$get(order,1)
530 set paginate=$get(paginate,0)
531 set countNodes=$get(countNodes,0)
532
533 new len set len=$length(current)
534 new lastChar set lastChar=$extract(current,len)
535 if lastChar'=")" do
536 . if current'["(" quit
537 . if lastChar="," set current=$extract(current,1,len-1)
538 . if lastChar="(" set current=$extract(current,1,len-1) quit
539 . set current=current_")"
540
541BNLoop
542 if current="" goto BNDone
543 set child=$$ShowNodes(current,order,paginate,countNodes)
544 if child'="" do
545 . set parent(child)=current
546 . set current=child
547 else set current=$get(parent(current))
548 goto BNLoop
549BNDone
550 quit
551
552
553ShowNodes(pArray,order,paginate,countNodes)
554 ;"NOTE: Duplicate of function in TMGMISC
555 ;"Purpose: To display all the nodes of the given array
556 ;"Input: pArray -- NAME OF array to display
557 ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order
558 ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page
559 ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes.
560 ;"Results: returns NAME OF next node to display (or "" if none)
561
562 new TMGi
563 new count set count=1
564 new Answers
565 new someShown set someShown=0
566 new abort set abort=0
567 set paginate=$get(paginate,0)
568 new pageCount set pageCount=0
569 new pageLen set pageLen=20
570 set countNodes=$get(countNodes,0)
571
572 write pArray,!
573 set TMGi=$order(@pArray@(""),order)
574 if TMGi'="" for do quit:(TMGi="")!(abort=1)
575 . write count,". +--[",TMGi,"]"
576 . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")"
577 . write "=",$extract($get(@pArray@(TMGi)),1,40),!
578 . set someShown=1
579 . set Answers(count)=$name(@pArray@(TMGi))
580 . set count=count+1
581 . new zbTemp read *zbTemp:0
582 . if zbTemp'=-1 set abort=1
583 . set pageCount=pageCount+1
584 . if (paginate=1)&(pageCount>pageLen) do
585 . . new zbTemp
586 . . read "Press [ENTER] to continue (^ to stop list)...",zbTemp:$get(DTIME,3600),!
587 . . if zbTemp="^" set abort=1
588 . . set pageCount=0
589 . set TMGi=$order(@pArray@(TMGi),order)
590
591 if someShown=0 write " (no data)",!
592 write !,"Enter # to browse (^ to backup): ^//"
593 new zbTemp read zbTemp:$get(DTIME,3600),!
594
595 new result set result=$get(Answers(zbTemp))
596
597 quit result
598
599
600ListCt(pArray)
601 ;"NOTE: Duplicate of function in TMGMISC
602 ;"SCOPE: PUBLIC
603 ;"Purpose: to count the number of entries in an array
604 ;"Input: pointer to (name of) array to test.
605 ;"Output: the number of entries at highest level
606 ;" e.g. Array("TELEPHONE")=1234
607 ;" Array("CAR")=4764
608 ;" Array("DOG")=5213
609 ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted.
610 ;" The above array would have a count of 3
611 new i,result set result=0
612
613 do
614 . new $etrap
615 . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit"
616 . set i=$order(@pArray@(""))
617 . if i="" quit
618 . for set result=result+1 set i=$order(@pArray@(i)) quit:i=""
619
620 quit result
621
622
623TrimL(S,TrimCh)
624 ;"NOTE: Duplicate of function in TMGSTUTL
625 ;"Purpose: To a trip a string of leading white space
626 ;" i.e. convert " hello" into "hello"
627 ;"Input: S -- the string to convert. Won't be changed if passed by reference
628 ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " "
629 ;"Results: returns modified string
630 ;"Note: processing limitation is string length=1024
631 set TrimCh=$get(TrimCh," ")
632 new result set result=$get(S)
633 new Ch set Ch=""
634 for do quit:(Ch'=TrimCh)
635 . set Ch=$extract(result,1,1)
636 . if Ch=TrimCh do
637 . . set result=$extract(result,2,1024)
638 quit result
639
640
641TrimR(S,TrimCh)
642 ;"NOTE: Duplicate of function in TMGSTUTL
643 ;"Purpose: To a trip a string of trailing white space
644 ;" i.e. convert "hello " into "hello"
645 ;"Input: S -- the string to convert. Won't be changed if passed by reference
646 ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " "
647 ;"Results: returns modified string
648 ;"Note: processing limitation is string length=1024
649
650 set TrimCh=$get(TrimCh," ")
651
652 new result set result=$get(S)
653 new Ch set Ch=""
654 new L
655
656 for do quit:(Ch'=TrimCh)
657 . set L=$length(result)
658 . set Ch=$extract(result,L,L)
659 . if Ch=TrimCh do
660 . . set result=$extract(result,1,L-1)
661
662 quit result
663
664
665Trim(S,TrimCh)
666 ;"NOTE: Duplicate of function in TMGSTUTL
667 ;"Purpose: To a trip a string of leading and trailing white space
668 ;" i.e. convert " hello " into "hello"
669 ;"Input: S -- the string to convert. Won't be changed if passed by reference
670 ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " "
671 ;"Results: returns modified string
672 ;"Note: processing limitation is string length=1024
673
674 set TrimCh=$get(TrimCh," ")
675
676 new result set result=$get(S)
677 set result=$$TrimL(.result,TrimCh)
678 set result=$$TrimR(.result,TrimCh)
679
680 quit result
681
682
683
684Substitute(S,Match,NewValue)
685 ;"NOTE: Duplicate of function in TMGSTUTL
686 ;"PUBLIC FUNCTION
687 ;"Purpose: to look for all instances of Match in S, and replace with NewValue
688 ;"Input: S - string to alter. Altered if passed by reference
689 ;" Match -- the sequence to look for, i.e. '##'
690 ;" NewValue -- what to replace Match with, i.e. '$$'
691 ;"Note: This is different than $translate, as follows
692 ;" $translate("ABC###DEF","###","*") --> "ABC***DEF"
693 ;" $$Substitute("ABC###DEF","###","*") --> "ABC*DEF"
694 ;"Result: returns altered string (if any alterations indicated)
695 ;"Output: S is altered, if passed by reference.
696
697 new spec
698 set spec($get(Match))=$get(NewValue)
699 set S=$$REPLACE(S,.spec)
700 quit S
701
702
703REPLACE(IN,SPEC) ;"See $$REPLACE in MDC minutes.
704 ;"Taken from REPLACE^XLFSTR
705 quit:'$D(IN) ""
706 quit:$D(SPEC)'>9 IN
707 N %1,%2,%3,%4,%5,%6,%7,%8
708 set %1=$L(IN)
709 set %7=$J("",%1)
710 set %3=""
711 set %6=9999
712 for set %3=$order(SPEC(%3)) quit:%3="" set %6(%6)=%3,%6=%6-1
713 for %6=0:0 set %6=$O(%6(%6)) quit:%6'>0 set %3=%6(%6) do:$D(SPEC(%3))#2 RE1
714 set %8=""
715 for %2=1:1:%1 do RE3
716 quit %8
717RE1 set %4=$L(%3)
718 set %5=0 for S %5=$F(IN,%3,%5) Q:%5<1 D RE2
719 Q
720RE2 Q:$E(%7,%5-%4,%5-1)["X" S %8(%5-%4)=SPEC(%3)
721 F %2=%5-%4:1:%5-1 S %7=$E(%7,1,%2-1)_"X"_$E(%7,%2+1,%1)
722 Q
723RE3 I $E(%7,%2)=" " S %8=%8_$E(IN,%2) Q
724 S:$D(%8(%2)) %8=%8_%8(%2)
725 Q
726
727
728KeyPress(wantChar,waitTime)
729 ;"NOTE: Duplicate of function in TMGUSRIF
730 ;"Purpose: to check for a keypress
731 ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value
732 ;" waitTime -- OPTIONAL, default is 0 (immediate return)
733 ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1)
734 ;"Note: this does NOT wait for user to press key
735
736 new zbTemp
737 set waitTime=$get(waitTime,0)
738 read *zbTemp:waitTime
739 if $get(wantChar)=1 set zbTemp=$char(zbTemp)
740 quit zbTemp
741
742
743
744DebugWrite(DBIndent,s,AddNewline)
745 ;"NOTE: Duplicate of function in TMGDEBUG
746 ;"PUBLIC FUNCTION
747 ;"Purpose: to write debug output. Having the proc separate will allow
748 ;" easier dump to file etc.
749 ;"Input:DBIndent, the amount of indentation expected for output.
750 ;" s -- the text to write
751 ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s
752
753 ;"Relevant DEBUG values
754 ;" cdbNone - no debug (0)
755 ;" cdbToScrn - Debug output to screen (1)
756 ;" cdbToFile - Debug output to file (2)
757 ;" cdbToTail - Debug output to X tail dialog box. (3)
758 ;"Note: If above values are not defined, then functionality will be ignored.
759
760 set TMGDEBUG=$get(TMGDEBUG,0)
761 if TMGDEBUG=0 quit
762 if (TMGDEBUG=2)!(TMGDEBUG=3),$data(DebugFile) use DebugFile
763 write s
764 if $get(AddNewline)=1 write !
765 if (TMGDEBUG=2)!(TMGDEBUG=3) use $PRINCIPAL
766 quit
767
768
769DebugIndent(DBIndentForced)
770 ;"NOTE: Duplicate of function in TMGDEBUG
771 ;"PUBLIC FUNCTION
772 ;"Purpose: to provide a unified indentation for debug messages
773 ;"Input: DBIndent = number of indentations
774 ;" Forced = 1 if to indent regardless of DEBUG mode
775
776 set Forced=$get(Forced,0)
777
778 if ($get(TMGDEBUG,0)=0)&(Forced=0) quit
779 new i
780 for i=1:1:DBIndent do
781 . if Forced do DebugWrite(DBIndent," ")
782 . else do DebugWrite(DBIndent,". ")
783 quit
784
785
786ArrayDump(ArrayP,TMGIDX,indent)
787 ;"NOTE: Duplicate of function in TMGDEBUG
788 ;"PUBLIC FUNCTION
789 ;"Purpose: to get a custom version of GTM's "zwr" command
790 ;"Input: Uses global scope var DBIndent (if defined)
791 ;" ArrayP: NAME of global to display, i.e. "^VA(200)"
792 ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5)
793 ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces)
794 ;" OPTIONAL: indent may be an array, with information about columns
795 ;" to skip. For example:
796 ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2
797 ;"Result: 0=OK to continue, 1=user aborted display
798
799 new result set result=0
800 if $$UserAborted^TMGUSRIF set result=1 goto ADDone
801 new $etrap set $etrap="set result="""",$etrap="""",$ecode="""""
802
803AD1 if $data(ArrayP)=0 goto ADDone
804 new abort set abort=0
805 if (ArrayP["@") do goto:(abort=1) ADDone
806 . new zbTemp set zbTemp=$piece($extract(ArrayP,2,99),"@",1)
807 . if $data(zbTemp)#10=0 set abort=1
808 ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes.
809 new X set X="SET zbTemp=$GET("_ArrayP_")"
810 set X=$$UP(X)
811 do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference.
812 if $get(X)="" goto ADDone
813
814 set DBIndent=$get(DBIndent,0)
815 set cTrue=$get(cTrue,1)
816 set cFalse=$get(cFalse,0)
817
818 ;"Force this function to output, even if TMGDEBUG is not defined.
819 ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working
820 new TMGDEBUG ;"//kt added 1-16-06
821 set TMGDEBUG=1
822
823 new ChildP,TMGi
824
825 set TMGIDX=$get(TMGIDX,"")
826 set indent=$get(indent,0)
827 new SavIndex set SavIndex=TMGIDX
828
829 do DebugIndent(DBIndent)
830
831 if indent>0 do
832 . for TMGi=1:1:indent-1 do
833 . . new s set s=""
834 . . if $get(indent(TMGi),-1)=0 set s=" "
835 . . else set s="| "
836 . . do DebugWrite(DBIndent,s)
837 . do DebugWrite(DBIndent,"}~")
838
839 if TMGIDX'="" do
840 . if $data(@ArrayP@(TMGIDX))#10=1 do
841 . . new s set s=@ArrayP@(TMGIDX)
842 . . if s="" set s=""""""
843 . . new qt set qt=""
844 . . if +TMGIDX'=TMGIDX set qt=""""
845 . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue)
846 . else do
847 . . do DebugWrite(DBIndent,TMGIDX,1)
848 . set ArrayP=$name(@ArrayP@(TMGIDX))
849 else do
850 . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse)
851 . do DebugWrite(DBIndent,ArrayP,cFalse)
852 . if $data(@ArrayP)#10=1 do
853 . . do DebugWrite(0,"="_$get(@ArrayP),cFalse)
854 . do DebugWrite(0,"",cTrue)
855
856 set TMGIDX=$order(@ArrayP@(""))
857 if TMGIDX="" goto ADDone
858 set indent=indent+1
859
860 for do quit:TMGIDX="" if result=1 goto ADDone
861 . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX))
862 . if tTMGIDX="" set indent(indent)=0
863 . new tIndent merge tIndent=indent
864 . set result=$$ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively
865 . set TMGIDX=$order(@ArrayP@(TMGIDX))
866
867 ;"Put in a blank space at end of subbranch
868 do DebugIndent(DBIndent)
869
870 if indent>0 do
871 . for TMGi=1:1:indent-1 do
872 . . new s set s=""
873 . . if $get(indent(TMGi),-1)=0 set s=" "
874 . . else set s="| "
875 . . do DebugWrite(DBIndent,s)
876 . do DebugWrite(DBIndent," ",1)
877
878ADDone
879 quit result
880
881
882ExpandLine(Pos)
883 ;"NOTE: Duplicate of function in TMGDEBUG
884 ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality
885 ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS)
886 ;"Output: Writes to the currently selecte IO device and expansion of one line of code
887 ;"Note: This is used for taking the very long lines of code, as found in Fileman, and
888 ;" convert them to a format with one command on each line.
889 ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA
890 ;" conventions--such as commands must be UPPERCASE etc.
891
892 ;"--- copied and modified from XINDX8.m ---
893
894 kill ^UTILITY($J)
895
896 new label,offset,RTN,dmod
897 do ParsePos(Pos,.label,.offset,.RTN,.dmod)
898 if label'="" do ;"change position from one relative to label into one relative to top of file
899 . new CodeArray
900 . set Pos=$$ConvertPos(Pos,"CodeArray")
901 . do ParsePos(Pos,.label,.offset,.RTN,.dmod)
902
903 if RTN="" goto ELDone
904
905 do BUILD^XINDX7
906 set ^UTILITY($J,RTN)=""
907 do LOAD^XINDEX
908 set CCN=0
909 do
910 . new I
911 . for I=1:1:+^UTILITY($J,1,RTN,0,0) set CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2
912 . set ^UTILITY($J,1,RTN,0)=CCN
913 ;"do ^XINDX8 -- included below
914
915 new Q,DDOT,LO,PG,LIN,ML,IDT
916 new tIOSL set tIOSL=IOSL
917 set IOSL=999999 ;"really long 'page length' prevents header printout (and error)
918
919 set Q=""""
920 set DDOT=0
921 set LO=0
922 set PG=+$G(PG)
923
924 set LC=offset
925 if $D(^UTILITY($J,1,RTN,0,LC)) do
926 . set LIN=^(LC,0),ML=0,IDT=10
927 . set LO=LC-1
928 . do CD^XINDX8
929
930 kill AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY
931
932 set IOSL=tIOSL ;"restore saved IOSL
933ELDone
934 quit
935
936
937
938CREF(X)
939 ;"Taken from CREF^DILF --> ENCREF^DIQGU
940 ;"Convert an open reference to a closed reference
941 new L,X1,X2,X3
942 set X1=$piece(X,"(")
943 set X2=$piece(X,"(",2,99)
944 set L=$length(X2)
945 set X3=$translate($extract(X2,L),",)")
946 set X2=$extract(X2,1,(L-1))_X3
947
948 quit X1_$select(X2]"":"("_X2_")",1:"")
949
950
951LGR()
952 ;"Taken from LGR^%ZOSV
953 ;" Last global reference ($REFERENCE)
954 quit $R
955
956UP(X)
957 ;"Taken from UP^XLFSTR
958 quit $translate(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
959
960
961READ()
962 ;"Purpose: To read user input, with knowledge of arrow keys
963 ;" This will use VPE keyboard handling if available, otherwise XGF stuff
964 ;"Result: Will return all user input up to a terminator (RETURN, or a special key)
965 ;" See code in %ZVEMKRN for possible code returns. <xx> format
966
967 ;"9/3/06 -- don't use VPE keyboard anymore
968 quit $$OLDREAD(,604800) ;"set timeout to 1 week (604800 secs).
969
970 if $text(+0^%ZVEMKRN)="" quit $$OLDREAD()
971
972 new key,FnKey
973 new done set done=0
974 new result set result=""
975
976 for do quit:(done=1)
977 . ;"READ^%ZVEMKRN(PROMPT,LENGTH,NOECHO) ;
978 . ;"PROMPT Display prompt.
979 . ;"LENGTH Maximum # of characters user may enter.
980 . ;"NOECHO 1=Do not echo what user types.
981 . set key=$$READ^%ZVEMKRN("",1,0)
982 . set FnKey=$get(VEE("K"))
983 . if FnKey="<RET>" set done=1,FnKey="" quit
984 . if (FnKey="<BS>")!(FnKey="<DEL>") do
985 . . set result=$extract(result,1,$length(result)-1)
986 . . write $char(8)_" "_$char(8) ;"a backspace char
987 . . set FnKey="" set key=""
988 . if FnKey'="" set key=FnKey,done=1
989 . if key'="" set result=result_key
990
991 quit result
992
993
994OLDREAD(XGCHARS,XGTO)
995 ;"Taken from READ^XGF
996 ;"read the keyboard
997 ;"XGCHARS:number of chars to read, XGTO:timeout
998 quit $$READ2($G(XGCHARS),$G(XGTO))
999
1000
1001READ2(XGCHARS,XGTO) ;"Taken from READ^XGKB
1002 ;"Purpose: Read a number of characters, using escape processing.
1003 ;"Input: XGCHARS -- number of characters to read
1004 ;" XGTO -- timeout (optional).
1005 ;"Result -- User input is returned.
1006 ;" -- Char that terminated the read will be in tmgXGRT
1007 ;" e.g. "UP"
1008 ;" "PREV"
1009 ;" "DOWN"
1010 ;" "NEXT"
1011 ;" "RIGHT"
1012 ;" "LEFT"
1013
1014 N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence
1015 K DTOUT
1016 S tmgXGRT=""
1017 D:$G(XGTO)="" ;set timeout value if one wasn't passed
1018 . I $D(XGT) D Q ;if timers are defined
1019 . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers
1020 . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window
1021 . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name
1022 . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever
1023 . S XGTO=$G(DTIME,600)
1024 ;
1025 I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read
1026 E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible
1027 S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^
1028 ;
1029 S:$L($ZB) tmgXGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any
1030 I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out
1031 . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER")
1032 E I $L(tmgXGRT),$D(^TMP("XGKEY",$J,tmgXGRT)) X ^(tmgXGRT) ;do some action
1033 ; this really should be handled by keyboard mapping -- later
1034 Q S
Note: See TracBrowser for help on using the repository browser.