| 1 | TMGIDE ;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 |
|
|---|
| 63 | START
|
|---|
| 64 | Start
|
|---|
| 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
|
|---|
| 115 | M1 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 |
|
|---|
| 143 | MenuDone
|
|---|
| 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")
|
|---|
| 150 | Done
|
|---|
| 151 | do ShutDown
|
|---|
| 152 | quit
|
|---|
| 153 |
|
|---|
| 154 | ;"-------------------------------------------------------------------
|
|---|
| 155 | SetErrTrap
|
|---|
| 156 | set $ZTRAP="do ErrTrap^TMGIDE2($ZPOS) break"
|
|---|
| 157 | set $ZSTATUS=""
|
|---|
| 158 | quit
|
|---|
| 159 |
|
|---|
| 160 | Prompt(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 |
|
|---|
| 175 | Ppt2 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.
|
|---|
| 203 | PptDne quit
|
|---|
| 204 |
|
|---|
| 205 | TranslateKeys(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 |
|
|---|
| 227 | GetHx(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 |
|
|---|
| 241 | SaveHx(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 |
|
|---|
| 254 | ShowHelp
|
|---|
| 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 |
|
|---|
| 260 | SetupVars
|
|---|
| 261 | set Mode=$get(Mode,"AllInOne")
|
|---|
| 262 | set $piece(ideBlankLine," ",78)=" "
|
|---|
| 263 | set TMGlastLine=""
|
|---|
| 264 | set HxShowNum=0
|
|---|
| 265 | quit
|
|---|
| 266 |
|
|---|
| 267 | EnsureEnv
|
|---|
| 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 |
|
|---|
| 283 | ClrDeadInfo
|
|---|
| 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 |
|
|---|
| 296 | KillOther
|
|---|
| 297 | ;"Purpose: To show currently running jobs, and allow user to kill on
|
|---|
| 298 | ;"Called from TMGIDE
|
|---|
| 299 | ;
|
|---|
| 300 | new array
|
|---|
| 301 | K1 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
|
|---|
| 316 | KODone quit
|
|---|
| 317 |
|
|---|
| 318 |
|
|---|
| 319 | ;"-------------------------------------------------------------------
|
|---|
| 320 | ShutDown
|
|---|
| 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 | ;"-------------------------------------------------------------------
|
|---|
| 330 | BKPT
|
|---|
| 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 |
|
|---|
| 341 | KBKPT
|
|---|
| 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 |
|
|---|
| 358 | ParsePos(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 |
|
|---|
| 382 | ConvertPos(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 |
|
|---|
| 436 | CPDone
|
|---|
| 437 | quit cpResult
|
|---|
| 438 |
|
|---|
| 439 |
|
|---|
| 440 | RelConvertPos(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 |
|
|---|
| 468 | ScanMod(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 |
|
|---|
| 514 | SMDone
|
|---|
| 515 | quit
|
|---|
| 516 |
|
|---|
| 517 |
|
|---|
| 518 |
|
|---|
| 519 | BROWSENODES(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 |
|
|---|
| 541 | BNLoop
|
|---|
| 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
|
|---|
| 549 | BNDone
|
|---|
| 550 | quit
|
|---|
| 551 |
|
|---|
| 552 |
|
|---|
| 553 | ShowNodes(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 |
|
|---|
| 600 | ListCt(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 |
|
|---|
| 623 | TrimL(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 |
|
|---|
| 641 | TrimR(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 |
|
|---|
| 665 | Trim(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 |
|
|---|
| 684 | Substitute(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 |
|
|---|
| 703 | REPLACE(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
|
|---|
| 717 | RE1 set %4=$L(%3)
|
|---|
| 718 | set %5=0 for S %5=$F(IN,%3,%5) Q:%5<1 D RE2
|
|---|
| 719 | Q
|
|---|
| 720 | RE2 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
|
|---|
| 723 | RE3 I $E(%7,%2)=" " S %8=%8_$E(IN,%2) Q
|
|---|
| 724 | S:$D(%8(%2)) %8=%8_%8(%2)
|
|---|
| 725 | Q
|
|---|
| 726 |
|
|---|
| 727 |
|
|---|
| 728 | KeyPress(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 |
|
|---|
| 744 | DebugWrite(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 |
|
|---|
| 769 | DebugIndent(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 |
|
|---|
| 786 | ArrayDump(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 |
|
|---|
| 803 | AD1 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 |
|
|---|
| 878 | ADDone
|
|---|
| 879 | quit result
|
|---|
| 880 |
|
|---|
| 881 |
|
|---|
| 882 | ExpandLine(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
|
|---|
| 933 | ELDone
|
|---|
| 934 | quit
|
|---|
| 935 |
|
|---|
| 936 |
|
|---|
| 937 |
|
|---|
| 938 | CREF(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 |
|
|---|
| 951 | LGR()
|
|---|
| 952 | ;"Taken from LGR^%ZOSV
|
|---|
| 953 | ;" Last global reference ($REFERENCE)
|
|---|
| 954 | quit $R
|
|---|
| 955 |
|
|---|
| 956 | UP(X)
|
|---|
| 957 | ;"Taken from UP^XLFSTR
|
|---|
| 958 | quit $translate(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 959 |
|
|---|
| 960 |
|
|---|
| 961 | READ()
|
|---|
| 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 |
|
|---|
| 994 | OLDREAD(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 |
|
|---|
| 1001 | READ2(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
|
|---|
