| [896] | 1 | TMGIDE6 ;TMG/kst/GT/M debugger Code Coloration ;4/4/09, 5/27/10
|
|---|
| 2 | ;;1.0;TMG-LIB;**1**;4/4/09
|
|---|
| 3 | ;
|
|---|
| 4 | ;" TMG IDE Code Coloration
|
|---|
| 5 | ;"
|
|---|
| 6 | ;" K. Toppenberg
|
|---|
| 7 | ;" 4/4/09
|
|---|
| 8 | ;" License: GPL Applies
|
|---|
| 9 | ;"
|
|---|
| 10 | ;"------------------------------------------------------------
|
|---|
| 11 | ;"PUBLIC API
|
|---|
| 12 | ;"------------------------------------------------------------
|
|---|
| 13 | ;"ShowLine(line,Options,BkColor) -- Encode and write out a line of code with colors
|
|---|
| 14 | ;"WriteMLine(line,BkColor) -- write out markup line, converting tags into colors
|
|---|
| 15 | ;"MarkupLine(line,Options) -- add markup tags that will allow coloration.
|
|---|
| 16 |
|
|---|
| 17 | ;"------------------------------------------------------------
|
|---|
| 18 | ;"PRIVATE API
|
|---|
| 19 | ;"------------------------------------------------------------
|
|---|
| 20 |
|
|---|
| 21 | ;"------------------------------------------------------------
|
|---|
| 22 | ;"------------------------------------------------------------
|
|---|
| 23 |
|
|---|
| 24 | temp
|
|---|
| 25 | new tempPos,pos,offset
|
|---|
| 26 | set pos="^PSOORFIN"
|
|---|
| 27 | new Options
|
|---|
| 28 | set Options("XCMD")=1
|
|---|
| 29 | set Options("LCASE")=1
|
|---|
| 30 | for offset=50:1:58 do
|
|---|
| 31 | . set tempPos="+"_offset_pos
|
|---|
| 32 | . new line set line=$text(@tempPos)
|
|---|
| 33 | . write offset,": " if $$ShowLine(line,.Options,40) write !
|
|---|
| 34 | do VTATRIB^TMGTERM(0) ;"Reset colors
|
|---|
| 35 | quit
|
|---|
| 36 |
|
|---|
| 37 |
|
|---|
| 38 | ShowPos(Pos)
|
|---|
| 39 | ;"A temp function to show out code at a given position.
|
|---|
| 40 | new line set line=$text(@Pos)
|
|---|
| 41 | write Pos,": " if $$ShowLine(line) write !
|
|---|
| 42 | quit
|
|---|
| 43 |
|
|---|
| 44 |
|
|---|
| 45 | ShowLine(line,Options,MaxChar)
|
|---|
| 46 | ;"Purpose: to encode and write out a line of code with colors
|
|---|
| 47 | ;"Input: line -- the code line to show
|
|---|
| 48 | ;" Options -- See MarkupLine for format
|
|---|
| 49 | ;" MaxChar -- OPTIONAL. Max count of characters to be allowed written.
|
|---|
| 50 | ;"Results: returns the actual number of chars written to screen.
|
|---|
| 51 | new temp set temp=$$MarkupLine(line,.Options)
|
|---|
| 52 | ;"write "{",$get(MaxChar),"}"
|
|---|
| 53 | new result set result=$$WriteMLine(temp,.MaxChar)
|
|---|
| 54 | quit result
|
|---|
| 55 |
|
|---|
| 56 | WriteMLine(line,MaxChar)
|
|---|
| 57 | ;"Purpose: to write out markup line, converting tags into colors)
|
|---|
| 58 | ;"Input: line -- the text to show, created by MarkupLine. DON'T pass by reference
|
|---|
| 59 | ;" MaxChar -- OPTIONAL. Max count of characters to be allowed written.
|
|---|
| 60 | ;"result: number of actual characters written to screen (removing tags)
|
|---|
| 61 | new result set result=0
|
|---|
| 62 | set MaxChar=$get(MaxChar,9999)
|
|---|
| 63 | for quit:($length(line)'>0)!(result>MaxChar) do
|
|---|
| 64 | . new p set p=$find(line,"{C")
|
|---|
| 65 | . if p>0 do ;"start color found
|
|---|
| 66 | . . new partS set partS=$extract(line,1,p-3)
|
|---|
| 67 | . . do SetColors^TMGIDE2("NORM")
|
|---|
| 68 | . . do DoWrite(partS,.result,MaxChar)
|
|---|
| 69 | . . ;"write partS set result=result+$length(partS)
|
|---|
| 70 | . . set line=$extract(line,p-2,999)
|
|---|
| 71 | . . new code set code=$$GetWord^TMGSTUTL(line,1,"{","}")
|
|---|
| 72 | . . set line=$extract(line,$length(code)+3,999) ;"shorten to after color tag onward
|
|---|
| 73 | . . new mode set mode=$piece(code,":",2)
|
|---|
| 74 | . . do SetColors^TMGIDE2(mode)
|
|---|
| 75 | . . set p=$find(line,"{C/}") ;"look for close color directive
|
|---|
| 76 | . . if p>0 do
|
|---|
| 77 | . . . set partS=$extract(line,1,p-5) ;"get text up to closing color
|
|---|
| 78 | . . . do DoWrite(partS,.result,MaxChar)
|
|---|
| 79 | . . . ;"write partS set result=result+$length(partS)
|
|---|
| 80 | . . . do SetColors^TMGIDE2("NORM")
|
|---|
| 81 | . . . set line=$extract(line,p,999) ;"shorten to next segment after closing color onward
|
|---|
| 82 | . . else do
|
|---|
| 83 | . . . do DoWrite(line,.result,MaxChar)
|
|---|
| 84 | . . . ;"write line set result=result+$length(line)
|
|---|
| 85 | . . . set line=""
|
|---|
| 86 | . else do
|
|---|
| 87 | . . do DoWrite(line,.result,MaxChar)
|
|---|
| 88 | . . ;"write line set result=result+$length(line)
|
|---|
| 89 | . . set line=""
|
|---|
| 90 | quit result
|
|---|
| 91 |
|
|---|
| 92 | DoWrite(s,CurLen,MaxLen)
|
|---|
| 93 | ;"Purpose: To do a controlled write to the screen.
|
|---|
| 94 | ;"Input: s -- the text to write
|
|---|
| 95 | ;" CurLen -- PASS BY REFERENCE. Current Num chars that have been written
|
|---|
| 96 | ;" MaxLen -- the limit to chars that can be written to screen.
|
|---|
| 97 | new len set len=$length(s)
|
|---|
| 98 | if CurLen+len>MaxLen do
|
|---|
| 99 | . set s=$extract(s,1,(MaxLen-CurLen))
|
|---|
| 100 | . set len=$length(s)
|
|---|
| 101 | write s
|
|---|
| 102 | set CurLen=CurLen+len
|
|---|
| 103 | quit
|
|---|
| 104 |
|
|---|
| 105 | MarkupLine(line,Options)
|
|---|
| 106 | ;"Purpose: To take an arbitrary line of code and add markup tags
|
|---|
| 107 | ;" that will allow coloration.
|
|---|
| 108 | ;"Input : line -- the line of code to consider. DON'T pass by reference.
|
|---|
| 109 | ;" Options -- PASS BY REFERENCE. OPTIONAL. Format
|
|---|
| 110 | ;" Options('XCMD')=1 --> turn I --> IF etc. (expand commands)
|
|---|
| 111 | ;" Options('UCASE')=1 --> turn commands into UPPER CASE
|
|---|
| 112 | ;" Options('LCASE')=1 --> turn commands into LOWER CASE
|
|---|
| 113 | ;" Options('Tab')=8 --> e.g. turn $char(9) into 8 spaces (Default is 5)
|
|---|
| 114 | ;"Results : returns line with markup added. Format:
|
|---|
| 115 | ;" {C:Name}...{C/}aaaa bbb ccc{C:Name2}ddddd{C/}
|
|---|
| 116 | ;" 'Name' will be one of the following:
|
|---|
| 117 | ;" LABEL -- for a code label
|
|---|
| 118 | ;" CMD -- for a command, e.g. IF F GOTO ELSE etc.
|
|---|
| 119 | ;" FN -- anything starting with $$
|
|---|
| 120 | ;" MOD -- e.g. ^MYMODULE
|
|---|
| 121 | ;" IFN -- intrinsic function, i.e. starting with $
|
|---|
| 122 | ;" STR -- a string
|
|---|
| 123 | ;" PC -- a post-conditional
|
|---|
| 124 | ;" # -- a comment
|
|---|
| 125 | new result set result=""
|
|---|
| 126 | new token,cmd,arg,tabStr,p,ch
|
|---|
| 127 | new tabLen set tabLen=$get(Options("Tab"),5)
|
|---|
| 128 | set $piece(tabStr," ",tabLen)=""
|
|---|
| 129 | set line=$get(line)
|
|---|
| 130 | set line=$translate(line,$char(9),tabStr) ;"turn tabs into spaces
|
|---|
| 131 | if $extract(line,1)'=" " do
|
|---|
| 132 | . set token=$piece(line," ",1)
|
|---|
| 133 | . set line=$piece(line," ",2,999)
|
|---|
| 134 | . set result="{C:LABEL}"_token_"{C/} "
|
|---|
| 135 | for p=1:1 quit:(p>$length(line))!($extract(line,p)'=" ")
|
|---|
| 136 | set result=result_$extract(line,1,p-1) ;"get leading space
|
|---|
| 137 | set line=$extract(line,p,999)
|
|---|
| 138 | new comment set comment=""
|
|---|
| 139 | ;"Extract comments first...
|
|---|
| 140 | set p=1 for set p=$find(line,";",p) quit:(p'>0) do
|
|---|
| 141 | . if $$InQt^TMGSTUTL(line,p-1) quit
|
|---|
| 142 | . set comment=$extract(line,p-1,999)
|
|---|
| 143 | . set comment="{C:#}"_comment_"{C/}"
|
|---|
| 144 | . set line=$extract(line,1,p-2)
|
|---|
| 145 | ;"====== Loop to get COMMAND ARG pairs ===="
|
|---|
| 146 | for quit:($length(line)'>0) do
|
|---|
| 147 | . for set ch=$extract(line,1) quit:(" ."'[ch)!(ch="") do
|
|---|
| 148 | . . set result=result_ch,line=$extract(line,2,999)
|
|---|
| 149 | . quit:(line="")
|
|---|
| 150 | . set token=$$NextBlock(.line)
|
|---|
| 151 | . if token[":" do
|
|---|
| 152 | . . set cmd=$$NextBlock(.token,":")
|
|---|
| 153 | . . set result=result_$$HndlCmd(cmd,.Options)_"{C:PC}:{C/}"
|
|---|
| 154 | . . set result=result_$$HndlArgs(token)_" "
|
|---|
| 155 | . else do
|
|---|
| 156 | . . set result=result_$$HndlCmd(token,.Options)_" "
|
|---|
| 157 | . set arg=$$NextBlock(.line)
|
|---|
| 158 | . set arg=$$HndlArgs(arg)
|
|---|
| 159 | . set result=result_arg_" "
|
|---|
| 160 | ;
|
|---|
| 161 | set result=result_comment ;"add back comment (if any)
|
|---|
| 162 | quit result
|
|---|
| 163 | ;
|
|---|
| 164 | HndlArgs(Args)
|
|---|
| 165 | ;"Purpose: to return a formatted arguments text
|
|---|
| 166 | ;"Input: Args -- the text that supplies arguments to a command, OR
|
|---|
| 167 | ;" the text that is post-conditional code
|
|---|
| 168 | ;"results: returns the Args with markup code.
|
|---|
| 169 | new p set p=1
|
|---|
| 170 | for set p=$find(Args,"$$",p) quit:(p'>0) do quit:(p'>0) ;"Handle functions
|
|---|
| 171 | . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit
|
|---|
| 172 | . new fnName set fnName="$$"_$$GetWord^TMGSTUTL(Args,p,"$","():^= _")
|
|---|
| 173 | . new partA,partB
|
|---|
| 174 | . set partA=$extract(Args,1,p-3)
|
|---|
| 175 | . set partB=$extract(Args,p-2+$length(fnName),999)
|
|---|
| 176 | . set Args=partA_"{C:FN}"_fnName_"{C/}"_partB
|
|---|
| 177 | . set p=p+6+$length(fnName) ;"6=length of {C:FN}
|
|---|
| 178 | set p=1
|
|---|
| 179 | for set p=$find(Args,"$",p) quit:(p'>0) do quit:(p'>0) ;"Handle intrinsic functions
|
|---|
| 180 | . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit
|
|---|
| 181 | . if $extract(Args,p)="$" set p=p+1 quit ;"avoid $$ matches
|
|---|
| 182 | . new fnName set fnName="$"_$$GetWord^TMGSTUTL(Args,p,"$","():,= _")
|
|---|
| 183 | . new partA,partB
|
|---|
| 184 | . set partA=$extract(Args,1,p-2)
|
|---|
| 185 | . set partB=$extract(Args,p-1+$length(fnName),999)
|
|---|
| 186 | . set Args=partA_"{C:IFN}"_fnName_"{C/}"_partB
|
|---|
| 187 | . set p=p+7+$length(fnName) ;"7=length of {C:IFN}
|
|---|
| 188 | set p=1
|
|---|
| 189 | for set p=$find(Args,"^",p) quit:(p'>0) do quit:(p'>0);"Handle Modules
|
|---|
| 190 | . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit
|
|---|
| 191 | . new modName set modName="^"_$$GetWord^TMGSTUTL(Args,p,"^","():,= _")
|
|---|
| 192 | . new partA,partB
|
|---|
| 193 | . set partA=$extract(Args,1,p-2)
|
|---|
| 194 | . set partB=$extract(Args,p-1+$length(modName),999)
|
|---|
| 195 | . set Args=partA_"{C:MOD}"_modName_"{C/}"_partB
|
|---|
| 196 | . set p=p+7+$length(modName) ;"7=length of {C:MOD}
|
|---|
| 197 | set p=1
|
|---|
| 198 | for set p=$find(Args,"""",p) quit:(p'>0) do ;"Handle Strings
|
|---|
| 199 | . new p2
|
|---|
| 200 | . if $extract(Args,p)="""" set p2=p
|
|---|
| 201 | . else set p2=$$StrBounds^TMGSTUTL(Args,p)
|
|---|
| 202 | . if p2=0 set p=999 quit
|
|---|
| 203 | . new partA,partB,partC
|
|---|
| 204 | . set partA=$extract(Args,1,p-2)
|
|---|
| 205 | . set partB=$extract(Args,p-1,p2)
|
|---|
| 206 | . set partC=$extract(Args,p2+1,999)
|
|---|
| 207 | . set Args=partA_"{C:STR}"_partB_"{C/}"_partC
|
|---|
| 208 | . set p=p+7+$length(partB) ;"7=length of {C:STR}
|
|---|
| 209 | quit Args
|
|---|
| 210 |
|
|---|
| 211 |
|
|---|
| 212 | HndlCmd(Cmd,Options)
|
|---|
| 213 | ;"Purpose: Return formatted command
|
|---|
| 214 | ;"Input: Cmd -- the mumps command
|
|---|
| 215 | ;" Options -- OPTIONAL. Format:
|
|---|
| 216 | ;" Options('XCMD')=1 --> turn I --> IF etc. (expand commands)
|
|---|
| 217 | ;" Options('SCMD')=1 --> turn IF --> I etc. (shrink commands)
|
|---|
| 218 | ;" Options('UCASE')=1 --> turn commands into UPPER CASE
|
|---|
| 219 | ;" Options('LCASE')=1 --> turn commands into LOWER CASE
|
|---|
| 220 | ;"Results: returns the command with markup code
|
|---|
| 221 | new result set result=""
|
|---|
| 222 | set Cmd=$get(Cmd)
|
|---|
| 223 | new tempCmd set tempCmd=$$UP^XLFSTR(Cmd)
|
|---|
| 224 | if $get(Options("XCMD")) do
|
|---|
| 225 | . if tempCmd="AB" set Cmd="ABLOCK" quit
|
|---|
| 226 | . if tempCmd="A" set Cmd="ASSIGN" quit
|
|---|
| 227 | . if tempCmd="ASTA" set Cmd="ASTART" quit
|
|---|
| 228 | . if tempCmd="ASTO" set Cmd="ASTOP" quit
|
|---|
| 229 | . if tempCmd="AUNB" set Cmd="AUNBLOCK" quit
|
|---|
| 230 | . if tempCmd="B" set Cmd="BREAK" quit
|
|---|
| 231 | . if tempCmd="C" set Cmd="CLOSE" quit
|
|---|
| 232 | . if tempCmd="D" set Cmd="DO" quit
|
|---|
| 233 | . if tempCmd="E" set Cmd="ELSE" quit
|
|---|
| 234 | . if tempCmd="ESTA" set Cmd="ESTART" quit
|
|---|
| 235 | . if tempCmd="ESTO" set Cmd="ESTOP" quit
|
|---|
| 236 | . if tempCmd="ETR" set Cmd="ETRIGGER" quit
|
|---|
| 237 | . if tempCmd="F" set Cmd="FOR" quit
|
|---|
| 238 | . if tempCmd="G" set Cmd="GOTO" quit
|
|---|
| 239 | . ;"if tempCmd="H" set Cmd="HALT" quit
|
|---|
| 240 | . ;"if tempCmd="H" set Cmd="HANG" quit
|
|---|
| 241 | . if tempCmd="I" set Cmd="IF" quit
|
|---|
| 242 | . if tempCmd="J" set Cmd="JOB" quit
|
|---|
| 243 | . if tempCmd="K" set Cmd="KILL" quit
|
|---|
| 244 | . if tempCmd="KS" set Cmd="KSUBSCRIPTS" quit
|
|---|
| 245 | . if tempCmd="KV" set Cmd="KVALUE" quit
|
|---|
| 246 | . if tempCmd="L" set Cmd="LOCK" quit
|
|---|
| 247 | . if tempCmd="M" set Cmd="MERGE" quit
|
|---|
| 248 | . if tempCmd="N" set Cmd="NEW" quit
|
|---|
| 249 | . if tempCmd="O" set Cmd="OPEN" quit
|
|---|
| 250 | . if tempCmd="Q" set Cmd="QUIT" quit
|
|---|
| 251 | . if tempCmd="R" set Cmd="READ" quit
|
|---|
| 252 | . if tempCmd="RL" set Cmd="RLOAD" quit
|
|---|
| 253 | . if tempCmd="RS" set Cmd="RSAVE" quit
|
|---|
| 254 | . if tempCmd="S" set Cmd="SET" quit
|
|---|
| 255 | . if tempCmd="TC" set Cmd="TCOMMIT" quit
|
|---|
| 256 | . if tempCmd="TH" set Cmd="THEN" quit
|
|---|
| 257 | . if tempCmd="TRE" set Cmd="TRESTART" quit
|
|---|
| 258 | . if tempCmd="TRO" set Cmd="TROLLBACK" quit
|
|---|
| 259 | . if tempCmd="TS" set Cmd="TSTART" quit
|
|---|
| 260 | . if tempCmd="U" set Cmd="USE" quit
|
|---|
| 261 | . if tempCmd="V" set Cmd="VIEW" quit
|
|---|
| 262 | . if tempCmd="W" set Cmd="WRITE" quit
|
|---|
| 263 | . if tempCmd="X" set Cmd="XECUTE" quit
|
|---|
| 264 | . if tempCmd="ZWR" set Cmd="ZWRITE" quit
|
|---|
| 265 | if $get(Options("SCMD")) do
|
|---|
| 266 | . if tempCmd="ABLOCK" set Cmd="AB" quit
|
|---|
| 267 | . if tempCmd="ASSIGN" set Cmd="A" quit
|
|---|
| 268 | . if tempCmd="ASTART" set Cmd="ASTA" quit
|
|---|
| 269 | . if tempCmd="ASTOP" set Cmd="ASTO" quit
|
|---|
| 270 | . if tempCmd="AUNBLOCK" set Cmd="AUNB" quit
|
|---|
| 271 | . if tempCmd="BREAK" set Cmd="B" quit
|
|---|
| 272 | . if tempCmd="CLOSE" set Cmd="C" quit
|
|---|
| 273 | . if tempCmd="DO" set Cmd="D" quit
|
|---|
| 274 | . if tempCmd="ELSE" set Cmd="E" quit
|
|---|
| 275 | . if tempCmd="ESTART" set Cmd="ESTA" quit
|
|---|
| 276 | . if tempCmd="ESTOP" set Cmd="ESTO" quit
|
|---|
| 277 | . if tempCmd="ETRIGGER" set Cmd="ETR" quit
|
|---|
| 278 | . if tempCmd="FOR" set Cmd="F" quit
|
|---|
| 279 | . if tempCmd="GOTO" set Cmd="G" quit
|
|---|
| 280 | . if tempCmd="HALT" set Cmd="H" quit
|
|---|
| 281 | . if tempCmd="HANG" set Cmd="H" quit
|
|---|
| 282 | . if tempCmd="IF" set Cmd="I" quit
|
|---|
| 283 | . if tempCmd="JOB" set Cmd="J" quit
|
|---|
| 284 | . if tempCmd="KILL" set Cmd="K" quit
|
|---|
| 285 | . if tempCmd="KSUBSCRIPTS" set Cmd="KS" quit
|
|---|
| 286 | . if tempCmd="KVALUE" set Cmd="KV" quit
|
|---|
| 287 | . if tempCmd="LOCK" set Cmd="L" quit
|
|---|
| 288 | . if tempCmd="MERGE" set Cmd="M" quit
|
|---|
| 289 | . if tempCmd="NEW" set Cmd="N" quit
|
|---|
| 290 | . if tempCmd="OPEN" set Cmd="O" quit
|
|---|
| 291 | . if tempCmd="QUIT" set Cmd="Q" quit
|
|---|
| 292 | . if tempCmd="READ" set Cmd="R" quit
|
|---|
| 293 | . if tempCmd="RLOAD" set Cmd="RL" quit
|
|---|
| 294 | . if tempCmd="RSAVE" set Cmd="RS" quit
|
|---|
| 295 | . if tempCmd="SET" set Cmd="S" quit
|
|---|
| 296 | . if tempCmd="TCOMMIT" set Cmd="TC" quit
|
|---|
| 297 | . if tempCmd="THEN" set Cmd="TH" quit
|
|---|
| 298 | . if tempCmd="TRESTART" set Cmd="TRE" quit
|
|---|
| 299 | . if tempCmd="TROLLBACK" set Cmd="TRO" quit
|
|---|
| 300 | . if tempCmd="TSTART" set Cmd="TS" quit
|
|---|
| 301 | . if tempCmd="USE" set Cmd="U" quit
|
|---|
| 302 | . if tempCmd="VIEW" set Cmd="V" quit
|
|---|
| 303 | . if tempCmd="WRITE" set Cmd="W" quit
|
|---|
| 304 | . if tempCmd="XECUTE" set Cmd="X" quit
|
|---|
| 305 | . if tempCmd="ZWRITE" set Cmd="ZWR" quit
|
|---|
| 306 | if $get(Options("UCASE")) set Cmd=$$UP^XLFSTR(Cmd)
|
|---|
| 307 | if $get(Options("LCASE")) set Cmd=$$LOW^XLFSTR(Cmd)
|
|---|
| 308 | set result="{C:CMD}"_Cmd_"{C/}"
|
|---|
| 309 | quit result
|
|---|
| 310 |
|
|---|
| 311 | NextBlock(line,Div)
|
|---|
| 312 | ;"Purpose: to return from the begining to the next space. Space is
|
|---|
| 313 | ;" discarded.
|
|---|
| 314 | ;" e.g. line='This is a test', then function will return 'This'
|
|---|
| 315 | ;" and line will be changed to be 'is a test'
|
|---|
| 316 | ;" e.g. line='quit:(test) do' will return 'quit:(test)'
|
|---|
| 317 | ;" and line will be changed to ' do' (with 1 space)
|
|---|
| 318 | ;" e.g. line=' do' will return ''
|
|---|
| 319 | ;" and line will be changed to 'do'
|
|---|
| 320 | ;" e.g. line='test' will return 'test'
|
|---|
| 321 | ;" and line will be changed to ''
|
|---|
| 322 | ;" NO e.g. line='..test' will return '...'
|
|---|
| 323 | ;" NO and line will be changed to 'test'
|
|---|
| 324 | ;"Input: line -- PASS BY REFERENCE
|
|---|
| 325 | ;" Div -- the divider of blocks. OPTIONAL. Default=" "
|
|---|
| 326 | ;"Result: the first block, see above.
|
|---|
| 327 | new result set result=""
|
|---|
| 328 | set Div=$get(Div," ")
|
|---|
| 329 | new done set done=0
|
|---|
| 330 | new p set p=1
|
|---|
| 331 | for do quit:(done)
|
|---|
| 332 | . set p=$find(line,Div,p)
|
|---|
| 333 | . if p'>0 set result=line,line="",done=1 quit
|
|---|
| 334 | . if $$InQt^TMGSTUTL(line,p-1) quit
|
|---|
| 335 | . set result=$extract(line,1,p-2)
|
|---|
| 336 | . set line=$extract(line,p,999)
|
|---|
| 337 | . set done=1
|
|---|
| 338 | quit result
|
|---|
| 339 | ;
|
|---|
| 340 | InitColors
|
|---|
| 341 | ;"Purpose: to establish tmgDbgOptions globally-scoped var for colors,
|
|---|
| 342 | new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS"))
|
|---|
| 343 | ;"write "$DATA(@ref)=",$DATA(@ref),!
|
|---|
| 344 | new refMaster set refMaster=$name(^TMG("TMGIDE","COLORS"))
|
|---|
| 345 | ;"write "refMaster=",refMaster,!
|
|---|
| 346 | ;"write "$DATA(@refMaster)=",$DATA(@refMaster),!
|
|---|
| 347 | ;"write "here is dump...",!
|
|---|
| 348 | ;"zwr ^TMG("TMGIDE","COLORS",*)
|
|---|
| 349 | ;"do PressToCont^TMGUSRIF
|
|---|
| 350 | if ($data(@ref)=0) do
|
|---|
| 351 | . if ($data(@refMaster)'=0) do
|
|---|
| 352 | . . merge @ref=^TMG("TMGIDE","COLORS") ;"copy master into job's
|
|---|
| 353 | . else do
|
|---|
| 354 | . . if $data(TMGcBlack)=0 do SetGlobals^TMGTERM
|
|---|
| 355 | . . set @ref@("BACKGROUND")=TMGcBlue
|
|---|
| 356 | . . set @ref@("HighExecPos")=TMGcGrey
|
|---|
| 357 | . . set @ref@("HighBkPos")=TMGcBRed
|
|---|
| 358 | . . set @ref@("BkPos")=TMGcRed
|
|---|
| 359 | . . set @ref@("Highlight")=TMGcFGBWhite
|
|---|
| 360 | . . ;"-----------------------------------
|
|---|
| 361 | . . set @ref@("LABEL","fg")=TMGcBYellow
|
|---|
| 362 | . . set @ref@("LABEL","bg")=TMGcRed
|
|---|
| 363 | . . set @ref@("SPECIAL","fg")=TMGcBYellow
|
|---|
| 364 | . . set @ref@("SPECIAL","bg")=TMGcRed
|
|---|
| 365 | . . ;"-----------------------------------
|
|---|
| 366 | . . set @ref@("NORM","fg")=TMGcFGBWhite
|
|---|
| 367 | . . set @ref@("NORM","bg")="@" ;"signal to use current background color
|
|---|
| 368 | . . set @ref@("CMD","fg")=TMGcBRed
|
|---|
| 369 | . . set @ref@("CMD","bg")="@"
|
|---|
| 370 | . . set @ref@("FN","fg")=TMGcBCyan
|
|---|
| 371 | . . set @ref@("FN","bg")="@"
|
|---|
| 372 | . . set @ref@("MOD","fg")=TMGcBBlue
|
|---|
| 373 | . . set @ref@("MOD","bg")="@"
|
|---|
| 374 | . . set @ref@("IFN","fg")=TMGcRed
|
|---|
| 375 | . . set @ref@("IFN","bg")="@"
|
|---|
| 376 | . . set @ref@("STR","fg")=TMGcBMagenta
|
|---|
| 377 | . . set @ref@("STR","bg")="@"
|
|---|
| 378 | . . set @ref@("PC","fg")=TMGcBRed
|
|---|
| 379 | . . set @ref@("PC","bg")="@"
|
|---|
| 380 | . . set @ref@("#","fg")=TMGcBYellow
|
|---|
| 381 | . . set @ref@("#","bg")="@"
|
|---|
| 382 | . . merge @refMaster=@ref
|
|---|
| 383 | quit
|
|---|
| 384 | ;
|
|---|
| 385 | EditColors
|
|---|
| 386 | ;"Purpose: Enable Edit Colors
|
|---|
| 387 | write #
|
|---|
| 388 | new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS"))
|
|---|
| 389 | new Menu,Menu2,UsrSlct,UsrSlct2,UsrRaw,fg,bg,ct
|
|---|
| 390 | set ct=1
|
|---|
| 391 | set Menu(0)="Pick Color to Edit"
|
|---|
| 392 | set Menu(ct)="Window Background color"_$char(9)_"BACKGROUND",ct=ct+1
|
|---|
| 393 | set Menu(ct)="Current Execution Position Background Color"_$char(9)_"HighExecPos",ct=ct+1
|
|---|
| 394 | set Menu(ct)="Highlighted Breakpoint Background Color"_$char(9)_"HighBkPos",ct=ct+1
|
|---|
| 395 | set Menu(ct)="Breakpoint Background Color"_$char(9)_"BkPos",ct=ct+1
|
|---|
| 396 | set Menu(ct)="Highlight Background Color"_$char(9)_"Highlight",ct=ct+1
|
|---|
| 397 |
|
|---|
| 398 | set Menu(ct)="Label Foreground & Background Color"_$char(9)_"LABEL",ct=ct+1
|
|---|
| 399 | set Menu(ct)="'Special' Foreground & Background Color"_$char(9)_"SPECIAL",ct=ct+1
|
|---|
| 400 |
|
|---|
| 401 | set Menu(ct)="Normal Text Foreground Color"_$char(9)_"NORM",ct=ct+1
|
|---|
| 402 | set Menu(ct)="Command Foreground Color"_$char(9)_"CMD",ct=ct+1
|
|---|
| 403 | set Menu(ct)="Functions Foreground Color"_$char(9)_"FN",ct=ct+1
|
|---|
| 404 | set Menu(ct)="Module/Global reference Foreground Color"_$char(9)_"MOD",ct=ct+1
|
|---|
| 405 | set Menu(ct)="Mumps intrinsic functions Foreground Color"_$char(9)_"IFN",ct=ct+1
|
|---|
| 406 | set Menu(ct)="String Foreground Color"_$char(9)_"STR",ct=ct+1
|
|---|
| 407 | set Menu(ct)="Post-conditional Foreground Color"_$char(9)_"PC",ct=ct+1
|
|---|
| 408 | set Menu(ct)="Comments Foreground Color"_$char(9)_"#",ct=ct+1
|
|---|
| 409 | new i
|
|---|
| 410 | M1 set i=0
|
|---|
| 411 | for set i=$order(Menu(i)) quit:(i="") do
|
|---|
| 412 | . new bg,fg
|
|---|
| 413 | . new mode set mode=$piece(Menu(i),$char(9),2)
|
|---|
| 414 | . if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[mode do
|
|---|
| 415 | . . set bg=$get(@ref@(mode))
|
|---|
| 416 | . . set fg=$select(bg=0:7,1:10)
|
|---|
| 417 | . else do
|
|---|
| 418 | . . set fg=$get(@ref@(mode,"fg"))
|
|---|
| 419 | . . set bg=$get(@ref@(mode,"bg"))
|
|---|
| 420 | . . if bg="@" set bg=$get(@ref@("BACKGROUND"),0)
|
|---|
| 421 | . set Menu(i,"COLOR","fg")=fg
|
|---|
| 422 | . set Menu(i,"COLOR","bg")=bg
|
|---|
| 423 | ;
|
|---|
| 424 | set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^",.UsrRaw)
|
|---|
| 425 | if UsrSlct="^" goto ECDn
|
|---|
| 426 | if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[UsrSlct do goto M1
|
|---|
| 427 | . set @ref@(UsrSlct)=$$PickBGColor^TMGTERM()
|
|---|
| 428 | if UsrSlct=0 set UsrSlct="" goto M1
|
|---|
| 429 | if "SPECIAL,LABEL"'[UsrSlct do goto M1
|
|---|
| 430 | . new bg set bg=$get(@ref@("BACKGROUND"),0)
|
|---|
| 431 | . write "Setting bg=",bg,!
|
|---|
| 432 | . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),bg)
|
|---|
| 433 |
|
|---|
| 434 | new Label set Label=$get(Menu(UsrRaw))
|
|---|
| 435 | kill Menu2
|
|---|
| 436 | set Menu2(0)="For "_$piece(Label,$char(9),1)_"..."
|
|---|
| 437 | set Menu2(1)="Edit Foreground color"_$char(9)_"fg"
|
|---|
| 438 | set Menu2(2)="Edit Background color"_$char(9)_"bg"
|
|---|
| 439 | set Menu2(3)="Edit BOTH colors"_$char(9)_"fg&bg"
|
|---|
| 440 | write !
|
|---|
| 441 | M2 set fg=+$get(@ref@(UsrSlct,"fg"),1)
|
|---|
| 442 | set bg=+$get(@ref@(UsrSlct,"bg"),0)
|
|---|
| 443 | do VCOLORS^TMGTERM(fg,bg)
|
|---|
| 444 | write "Here are the current colors..."
|
|---|
| 445 | do VTATRIB^TMGTERM(0) ;"Reset colors
|
|---|
| 446 | write !
|
|---|
| 447 | set UsrSlct2=$$Menu^TMGUSRIF(.Menu2,"^",.UsrRaw)
|
|---|
| 448 | if UsrSlct2="^" goto M1
|
|---|
| 449 |
|
|---|
| 450 | M3 if UsrSlct2="fg" do goto M2
|
|---|
| 451 | . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),@ref@(UsrSlct,"bg"))
|
|---|
| 452 | if UsrSlct2="bg" do goto M2
|
|---|
| 453 | . set @ref@(UsrSlct,"bg")=$$PickBGColor^TMGTERM(@ref@(UsrSlct,"bg"))
|
|---|
| 454 | if UsrSlct2="fg&bg" do goto M2
|
|---|
| 455 | . do PickColors^TMGTERM(.fg,.bg)
|
|---|
| 456 | . set @ref@(UsrSlct,"fg")=fg
|
|---|
| 457 | . set @ref@(UsrSlct,"bg")=bg
|
|---|
| 458 | goto M2
|
|---|
| 459 |
|
|---|
| 460 | ECDn
|
|---|
| 461 | new % set %=2
|
|---|
| 462 | write "Set current colors as default"
|
|---|
| 463 | do YN^DICN
|
|---|
| 464 | if %=1 do
|
|---|
| 465 | . kill ^TMG("TMGIDE","COLORS")
|
|---|
| 466 | . merge ^TMG("TMGIDE","COLORS")=^TMG("TMGIDE",$J,"COLORS")
|
|---|
| 467 | quit
|
|---|
| 468 | ;
|
|---|
| 469 | ;
|
|---|
| 470 | TestColors
|
|---|
| 471 | do InitColors
|
|---|
| 472 | new mode
|
|---|
| 473 | for mode="Highlight","HighExecPos","BkPos","HighBkPos","SPECIAL","NORM","LABEL","CMD","FN","MOD","IFN","STR","PC","#" do
|
|---|
| 474 | . do SetColors^TMGIDE2(mode)
|
|---|
| 475 | . write "Here is text for ",mode,"...."
|
|---|
| 476 | . do SetColors^TMGIDE2("Reset")
|
|---|
| 477 | . write !
|
|---|
| 478 | quit
|
|---|
| 479 |
|
|---|
| 480 |
|
|---|
| 481 | ;"============== Code for TRACE functionality =================
|
|---|
| 482 |
|
|---|
| 483 | ShowTrace
|
|---|
| 484 | ;"Purpose: to show current trace record of execution.
|
|---|
| 485 | ;"if $get(tmgDbgOptions("TRACE"))=1 quit
|
|---|
| 486 | new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE"))
|
|---|
| 487 | if $data(@ref) do
|
|---|
| 488 | . write "SHOW TRACE RECORDS:",!
|
|---|
| 489 | . new NumRecs set NumRecs=$order(@ref@(""),-1)
|
|---|
| 490 | . write NumRecs," trace lines to display",!
|
|---|
| 491 | . new count set count=1
|
|---|
| 492 | . new % set %=1
|
|---|
| 493 | . write "Also display code for each line" do YN^DICN write !
|
|---|
| 494 | . if %=-1 quit
|
|---|
| 495 | . new showCode set showCode=(%=1)
|
|---|
| 496 | . new Colorize set Colorize=0
|
|---|
| 497 | . if %=1 do quit:(%=-1)
|
|---|
| 498 | . . set %=1 write "Colorize code" do YN^DICN write !
|
|---|
| 499 | . . set Colorize=(%=1)
|
|---|
| 500 | . new %ZIS
|
|---|
| 501 | . set %ZIS("A")="Enter Output Device: "
|
|---|
| 502 | . set %ZIS("B")="HOME"
|
|---|
| 503 | . do ^%ZIS ;"standard device call
|
|---|
| 504 | . if POP do quit
|
|---|
| 505 | . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.")
|
|---|
| 506 | . use IO
|
|---|
| 507 | . new i set i=""
|
|---|
| 508 | . for set i=$order(@ref@(i)) quit:(i="")!($get(TMGPTCABORT)=1) do
|
|---|
| 509 | . . new s set s=$get(@ref@(i))
|
|---|
| 510 | . . write s
|
|---|
| 511 | . . if showCode do
|
|---|
| 512 | . . . new pos set pos=$piece(s,".",$length(s,"."))
|
|---|
| 513 | . . . if pos="" write " ??",! quit
|
|---|
| 514 | . . . ;"write "pos=",pos,!
|
|---|
| 515 | . . . new code
|
|---|
| 516 | . . . do
|
|---|
| 517 | . . . . new $etrap set $etrap="set code=""Error -- ""_pos,$etrap="""",$ecode="""""
|
|---|
| 518 | . . . . set code=$text(@pos)
|
|---|
| 519 | . . . write ?25,":"
|
|---|
| 520 | . . . new x for x=1:1:$length(s,".")-1 write " "
|
|---|
| 521 | . . . if Colorize do
|
|---|
| 522 | . . . . if $$ShowLine(code,.tmgDbgOptions)
|
|---|
| 523 | . . . . do SetColors^TMGIDE2("Reset")
|
|---|
| 524 | . . . else write code
|
|---|
| 525 | . . . write !
|
|---|
| 526 | . . else write " ",!
|
|---|
| 527 | . . ;"set count=count+1
|
|---|
| 528 | . . if count>20 do
|
|---|
| 529 | . . . do PressToCont^TMGUSRIF ;" will set TMGPTCABORT=1 if user entered ^
|
|---|
| 530 | . . . do CUU^TMGTERM(1)
|
|---|
| 531 | . . . write " ",!
|
|---|
| 532 | . . . do CUU^TMGTERM(1)
|
|---|
| 533 | . . . set count=1
|
|---|
| 534 | else do
|
|---|
| 535 | . write "(No Trace record found)",!
|
|---|
| 536 | do ^%ZISC ;" Close the output device
|
|---|
| 537 | do PressToCont^TMGUSRIF
|
|---|
| 538 | quit
|
|---|
| 539 |
|
|---|
| 540 | RecordTrace(ExecPos)
|
|---|
| 541 | ;"Purpose: To keep trace record of execution as program runs.
|
|---|
| 542 | ;"Input:ExecPos -- Current execution position
|
|---|
| 543 | new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE"))
|
|---|
| 544 | new Stack do GetStackInfo^TMGIDE2(.Stack,ExecPos)
|
|---|
| 545 | new str set str=$$StackStr(.Stack)
|
|---|
| 546 | new i set i=+$get(@ref)+1
|
|---|
| 547 | set @ref@(i)=str
|
|---|
| 548 | set @ref=i
|
|---|
| 549 | quit
|
|---|
| 550 |
|
|---|
| 551 | StackStr(Stack)
|
|---|
| 552 | ;"Purpose: Turn stack array into a single string
|
|---|
| 553 | ;"Input: Stack -- PASS BY REFERENCE, Numbered array, as created by GetStackInfo^TMGIDE2
|
|---|
| 554 | ;"Result: returns string with latest position, with
|
|---|
| 555 | ;" a "." leading for each level of indenction.
|
|---|
| 556 | ;"
|
|---|
| 557 | new result set result=""
|
|---|
| 558 | new count set count=+$order(Stack(""),-1)
|
|---|
| 559 | if count>0 do
|
|---|
| 560 | . new x for x=1:1:(count-1) set result=result_"."
|
|---|
| 561 | . new s set s=$get(Stack(count))
|
|---|
| 562 | . if s[" <--" set s=$piece(s," <--",1)
|
|---|
| 563 | . if s[" " set s=$piece(s," ",2)
|
|---|
| 564 | . set result=result_s
|
|---|
| 565 | quit result
|
|---|
| 566 |
|
|---|
| 567 | ;"============== Code for VAR TRACING functionality =================
|
|---|
| 568 |
|
|---|
| 569 | ShowVTrace
|
|---|
| 570 | ;"Purpose: Output changes from last step
|
|---|
| 571 | new tmgRefNum set tmgRefNum=+$order(^TMG("TMGIDE",$J,"VARTRACE","DELTA",""),-1)
|
|---|
| 572 | new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum))
|
|---|
| 573 | new TMG set TMG(1)="ADDED^Additions",TMG(2)="KILLED^Kills",TMG(3)="CHANGED^Changes"
|
|---|
| 574 | new i for i=1,2,3 do
|
|---|
| 575 | . new node set node=$piece(TMG(i),"^",1)
|
|---|
| 576 | . new title set title=$piece(TMG(i),"^",2)
|
|---|
| 577 | . if $data(@tmgRefDelta@(node)) do
|
|---|
| 578 | . . write title,": "
|
|---|
| 579 | . . new varname set varname=""
|
|---|
| 580 | . . for set varname=$order(@tmgRefDelta@(node,varname)) quit:(varname="") do
|
|---|
| 581 | . . . write varname,"=",$get(@tmgRefDelta@(node,varname))," ; "
|
|---|
| 582 | . . write !
|
|---|
| 583 | quit
|
|---|
| 584 |
|
|---|
| 585 |
|
|---|
| 586 | RecordVTrace
|
|---|
| 587 | ;"Purpose: To keep a trace of changes to the system variable table.
|
|---|
| 588 | new tmgFullRef set tmgFullRef=$name(^TMG("TMGIDE",$J,"VARTRACE","FULL"))
|
|---|
| 589 | new tmgRefNum set tmgRefNum=+$order(@tmgFullRef@(""),-1)+1
|
|---|
| 590 | if tmgRefNum'>0 goto RVTDn
|
|---|
| 591 | new tmgRefCurF set tmgRefCurF=$name(@tmgFullRef@(tmgRefNum))
|
|---|
| 592 | new tmgRefPriorF set tmgRefPriorF=$name(@tmgFullRef@(tmgRefNum-1))
|
|---|
| 593 | new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum))
|
|---|
| 594 | do StoreVars(tmgRefCurF)
|
|---|
| 595 | if $data(@tmgRefPriorF) do
|
|---|
| 596 | . do DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta)
|
|---|
| 597 | . kill @tmgRefPriorF
|
|---|
| 598 | RVTDn quit
|
|---|
| 599 |
|
|---|
| 600 | StoreVars(tmgRef)
|
|---|
| 601 | ;"Purpose: To copy system variable table to a storage area
|
|---|
| 602 | ;"Input: Ref -- the NAME of the global to store table at
|
|---|
| 603 | ;"Results: none
|
|---|
| 604 | ;"NOTICE: all vars beginning with "tmg" are NOT shown.
|
|---|
| 605 | new tmgArray zshow "V":tmgArray ;"copy system table to local variable
|
|---|
| 606 | new idx set idx=0
|
|---|
| 607 | for set idx=$order(tmgArray("V",idx)) quit:(idx="") do
|
|---|
| 608 | . new s set s=tmgArray("V",idx)
|
|---|
| 609 | . new varname set varname=$piece(s,"=",1)
|
|---|
| 610 | . quit:(varname="")!($extract(varname,1,3)="tmg")
|
|---|
| 611 | . new value set value=$p(s,"=",2,999)
|
|---|
| 612 | . set @tmgRef@(varname)=value ;"reformat and store in a global var
|
|---|
| 613 | quit
|
|---|
| 614 |
|
|---|
| 615 | DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta)
|
|---|
| 616 | ;"Purpose: To create a record that shows difference between tmgRefCurF and
|
|---|
| 617 | ;" tmgRefPriorF, and stores the difference
|
|---|
| 618 | ;"Note: Possible differences:
|
|---|
| 619 | ;" 1. New record has a new variable, not previously in existence
|
|---|
| 620 | ;" 2. New record has same variable, but changed value
|
|---|
| 621 | ;" 3. New record does NOT have variable that previously existed.
|
|---|
| 622 | ;"Input: tmgRefCurF -- reference of current full variable store
|
|---|
| 623 | ;" tmgRefPriorF -- reference of prior full viariable store
|
|---|
| 624 | ;" tmgRefDelta -- reference to store changes to. Output Format:
|
|---|
| 625 | ;" @tmgRefDelta@('ADDED',varname)=value
|
|---|
| 626 | ;" @tmgRefDelta@('KILLED',varname)=""
|
|---|
| 627 | ;" @tmgRefDelta@('CHANGED',varname)=new value
|
|---|
| 628 | ;"Result: None. But any prior entry in @tmgRefDelta is deleted and changed as above.
|
|---|
| 629 | ;
|
|---|
| 630 | kill @tmgRefDelta
|
|---|
| 631 | new varname
|
|---|
| 632 | ;"First look for additions and changes
|
|---|
| 633 | set varname=""
|
|---|
| 634 | for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do
|
|---|
| 635 | . if $data(@tmgRefPriorF@(varname)) do quit
|
|---|
| 636 | . . if $get(@tmgRefPriorF@(varname))'=$get(@tmgRefCurF@(varname)) do
|
|---|
| 637 | . . . set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname))
|
|---|
| 638 | . set @tmgRefDelta@("ADDED",varname)=$get(@tmgRefCurF@(varname))
|
|---|
| 639 | ;
|
|---|
| 640 | ;"Next, look for deletions
|
|---|
| 641 | set varname=""
|
|---|
| 642 | for set varname=$order(@tmgRefPriorF@(varname)) quit:(varname="") do
|
|---|
| 643 | . if $data(@tmgRefCurF@(varname)) quit
|
|---|
| 644 | . set @tmgRefDelta@("KILLED",varname)=$get(@tmgRefPriorF@(varname))
|
|---|
| 645 | ;
|
|---|
| 646 | quit
|
|---|
| 647 | ;";"Finally, look for changes
|
|---|
| 648 | ;"set varname=""
|
|---|
| 649 | ;"for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do
|
|---|
| 650 | ;". if $data(@tmgRefPriorF@(varname))=0 quit
|
|---|
| 651 | ;". if $get(@tmgRefPriorF@(varname))=$get(@tmgRefCurF@(varname)) quit
|
|---|
| 652 | ;". set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname))
|
|---|
| 653 | ;"quit
|
|---|
| 654 |
|
|---|
| 655 | ;"================================================================ |
|---|
