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

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

Initial upload

File size: 27.9 KB
RevLine 
[796]1TMGIDE6 ;TMG/kst/GT/M debugger Code Coloration ;4/4/09
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
24temp
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
38ShowPos(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
45ShowLine(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
56WriteMLine(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
92DoWrite(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
105MarkupLine(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 ;
164HndlArgs(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
212HndlCmd(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
311NextBlock(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 ;
340InitColors
341 ;"Purpose: to establish tmgDbgOptions globally-scoped var for colors,
342 new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS"))
343 new refMaster set refMaster=$name(^TMG("TMGIDE","COLORS"))
344 if ($data(@ref)=0)&($data(@refMaster)'=0) do
345 . merge @ref=^TMG("TMGIDE","COLORS") ;"copy master into job's
346 else do
347 . if $data(TMGcBlack)=0 do SetGlobals^TMGTERM
348 . set @ref@("BACKGROUND")=TMGcBlue
349 . set @ref@("HighExecPos")=TMGcGrey
350 . set @ref@("HighBkPos")=TMGcBRed
351 . set @ref@("BkPos")=TMGcRed
352 . set @ref@("Highlight")=TMGcFGBWhite
353 . ;"-----------------------------------
354 . set @ref@("LABEL","fg")=TMGcBYellow
355 . set @ref@("LABEL","bg")=TMGcRed
356 . set @ref@("SPECIAL","fg")=TMGcBYellow
357 . set @ref@("SPECIAL","bg")=TMGcRed
358 . ;"-----------------------------------
359 . set @ref@("NORM","fg")=TMGcFGBWhite
360 . set @ref@("NORM","bg")="@" ;"signal to use current background color
361 . set @ref@("CMD","fg")=TMGcBRed
362 . set @ref@("CMD","bg")="@"
363 . set @ref@("FN","fg")=TMGcBCyan
364 . set @ref@("FN","bg")="@"
365 . set @ref@("MOD","fg")=TMGcBBlue
366 . set @ref@("MOD","bg")="@"
367 . set @ref@("IFN","fg")=TMGcRed
368 . set @ref@("IFN","bg")="@"
369 . set @ref@("STR","fg")=TMGcBMagenta
370 . set @ref@("STR","bg")="@"
371 . set @ref@("PC","fg")=TMGcBRed
372 . set @ref@("PC","bg")="@"
373 . set @ref@("#","fg")=TMGcBYellow
374 . set @ref@("#","bg")="@"
375 . merge @refMaster=@ref
376 quit
377 ;
378EditColors
379 ;"Purpose: Enable Edit Colors
380 write #
381 new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS"))
382 new Menu,Menu2,UsrSlct,UsrSlct2,UsrRaw,fg,bg,ct
383 set ct=1
384 set Menu(0)="Pick Color to Edit"
385 set Menu(ct)="Window Background color"_$char(9)_"BACKGROUND",ct=ct+1
386 set Menu(ct)="Current Execution Position Background Color"_$char(9)_"HighExecPos",ct=ct+1
387 set Menu(ct)="Highlighted Breakpoint Background Color"_$char(9)_"HighBkPos",ct=ct+1
388 set Menu(ct)="Breakpoint Background Color"_$char(9)_"BkPos",ct=ct+1
389 set Menu(ct)="Highlight Background Color"_$char(9)_"Highlight",ct=ct+1
390
391 set Menu(ct)="Label Foreground & Background Color"_$char(9)_"LABEL",ct=ct+1
392 set Menu(ct)="'Special' Foreground & Background Color"_$char(9)_"SPECIAL",ct=ct+1
393
394 set Menu(ct)="Normal Text Foreground Color"_$char(9)_"NORM",ct=ct+1
395 set Menu(ct)="Command Foreground Color"_$char(9)_"CMD",ct=ct+1
396 set Menu(ct)="Functions Foreground Color"_$char(9)_"FN",ct=ct+1
397 set Menu(ct)="Module/Global reference Foreground Color"_$char(9)_"MOD",ct=ct+1
398 set Menu(ct)="Mumps intrinsic functions Foreground Color"_$char(9)_"IFN",ct=ct+1
399 set Menu(ct)="String Foreground Color"_$char(9)_"STR",ct=ct+1
400 set Menu(ct)="Post-conditional Foreground Color"_$char(9)_"PC",ct=ct+1
401 set Menu(ct)="Comments Foreground Color"_$char(9)_"#",ct=ct+1
402 new i
403M1 set i=0
404 for set i=$order(Menu(i)) quit:(i="") do
405 . new bg,fg
406 . new mode set mode=$piece(Menu(i),$char(9),2)
407 . if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[mode do
408 . . set bg=$get(@ref@(mode))
409 . . set fg=$select(bg=0:7,1:10)
410 . else do
411 . . set fg=$get(@ref@(mode,"fg"))
412 . . set bg=$get(@ref@(mode,"bg"))
413 . . if bg="@" set bg=$get(@ref@("BACKGROUND"),0)
414 . set Menu(i,"COLOR","fg")=fg
415 . set Menu(i,"COLOR","bg")=bg
416 ;
417 set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^",.UsrRaw)
418 if UsrSlct="^" goto ECDn
419 if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[UsrSlct do goto M1
420 . set @ref@(UsrSlct)=$$PickBGColor^TMGTERM()
421 if UsrSlct=0 set UsrSlct="" goto M1
422 if "SPECIAL,LABEL"'[UsrSlct do goto M1
423 . new bg set bg=$get(@ref@("BACKGROUND"),0)
424 . write "Setting bg=",bg,!
425 . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),bg)
426
427 new Label set Label=$get(Menu(UsrRaw))
428 kill Menu2
429 set Menu2(0)="For "_$piece(Label,$char(9),1)_"..."
430 set Menu2(1)="Edit Foreground color"_$char(9)_"fg"
431 set Menu2(2)="Edit Background color"_$char(9)_"bg"
432 set Menu2(3)="Edit BOTH colors"_$char(9)_"fg&bg"
433 write !
434M2 set fg=+$get(@ref@(UsrSlct,"fg"),1)
435 set bg=+$get(@ref@(UsrSlct,"bg"),0)
436 do VCOLORS^TMGTERM(fg,bg)
437 write "Here are the current colors..."
438 do VTATRIB^TMGTERM(0) ;"Reset colors
439 write !
440 set UsrSlct2=$$Menu^TMGUSRIF(.Menu2,"^",.UsrRaw)
441 if UsrSlct2="^" goto M1
442
443M3 if UsrSlct2="fg" do goto M2
444 . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),@ref@(UsrSlct,"bg"))
445 if UsrSlct2="bg" do goto M2
446 . set @ref@(UsrSlct,"bg")=$$PickBGColor^TMGTERM(@ref@(UsrSlct,"bg"))
447 if UsrSlct2="fg&bg" do goto M2
448 . do PickColors^TMGTERM(.fg,.bg)
449 . set @ref@(UsrSlct,"fg")=fg
450 . set @ref@(UsrSlct,"bg")=bg
451 goto M2
452
453ECDn
454 new % set %=2
455 write "Set current colors as default"
456 do YN^DICN
457 if %=1 do
458 . kill ^TMG("TMGIDE","COLORS")
459 . merge ^TMG("TMGIDE","COLORS")=^TMG("TMGIDE",$J,"COLORS")
460 quit
461 ;
462 ;
463TestColors
464 do InitColors
465 new mode
466 for mode="Highlight","HighExecPos","BkPos","HighBkPos","SPECIAL","NORM","LABEL","CMD","FN","MOD","IFN","STR","PC","#" do
467 . do SetColors^TMGIDE2(mode)
468 . write "Here is text for ",mode,"...."
469 . do SetColors^TMGIDE2("Reset")
470 . write !
471 quit
472
473
474 ;"============== Code for TRACE functionality =================
475
476ShowTrace
477 ;"Purpose: to show current trace record of execution.
478 ;"if $get(tmgDbgOptions("TRACE"))=1 quit
479 new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE"))
480 if $data(@ref) do
481 . write "SHOW TRACE RECORDS:",!
482 . new NumRecs set NumRecs=$order(@ref@(""),-1)
483 . write NumRecs," trace lines to display",!
484 . new count set count=1
485 . new % set %=1
486 . write "Also display code for each line" do YN^DICN write !
487 . if %=-1 quit
488 . new showCode set showCode=(%=1)
489 . new Colorize set Colorize=0
490 . if %=1 do quit:(%=-1)
491 . . set %=1 write "Colorize code" do YN^DICN write !
492 . . set Colorize=(%=1)
493 . new %ZIS
494 . set %ZIS("A")="Enter Output Device: "
495 . set %ZIS("B")="HOME"
496 . do ^%ZIS ;"standard device call
497 . if POP do quit
498 . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.")
499 . use IO
500 . new i set i=""
501 . for set i=$order(@ref@(i)) quit:(i="")!($get(TMGPTCABORT)=1) do
502 . . new s set s=$get(@ref@(i))
503 . . write s
504 . . if showCode do
505 . . . new pos set pos=$piece(s,".",$length(s,"."))
506 . . . if pos="" write " ??",! quit
507 . . . ;"write "pos=",pos,!
508 . . . new code
509 . . . do
510 . . . . new $etrap set $etrap="set code=""Error -- ""_pos,$etrap="""",$ecode="""""
511 . . . . set code=$text(@pos)
512 . . . write ?25,":"
513 . . . new x for x=1:1:$length(s,".")-1 write " "
514 . . . if Colorize do
515 . . . . if $$ShowLine(code,.tmgDbgOptions)
516 . . . . do SetColors^TMGIDE2("Reset")
517 . . . else write code
518 . . . write !
519 . . else write " ",!
520 . . ;"set count=count+1
521 . . if count>20 do
522 . . . do PressToCont^TMGUSRIF ;" will set TMGPTCABORT=1 if user entered ^
523 . . . do CUU^TMGTERM(1)
524 . . . write " ",!
525 . . . do CUU^TMGTERM(1)
526 . . . set count=1
527 else do
528 . write "(No Trace record found)",!
529 do ^%ZISC ;" Close the output device
530 do PressToCont^TMGUSRIF
531 quit
532
533RecordTrace(ExecPos)
534 ;"Purpose: To keep trace record of execution as program runs.
535 ;"Input:ExecPos -- Current execution position
536 new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE"))
537 new Stack do GetStackInfo^TMGIDE2(.Stack,ExecPos)
538 new str set str=$$StackStr(.Stack)
539 new i set i=+$get(@ref)+1
540 set @ref@(i)=str
541 set @ref=i
542 quit
543
544StackStr(Stack)
545 ;"Purpose: Turn stack array into a single string
546 ;"Input: Stack -- PASS BY REFERENCE, Numbered array, as created by GetStackInfo^TMGIDE2
547 ;"Result: returns string with latest position, with
548 ;" a "." leading for each level of indenction.
549 ;"
550 new result set result=""
551 new count set count=+$order(Stack(""),-1)
552 if count>0 do
553 . new x for x=1:1:(count-1) set result=result_"."
554 . new s set s=$get(Stack(count))
555 . if s[" <--" set s=$piece(s," <--",1)
556 . if s[" " set s=$piece(s," ",2)
557 . set result=result_s
558 quit result
559
560 ;"============== Code for VAR TRACING functionality =================
561
562ShowVTrace
563 ;"Purpose: Output changes from last step
564 new tmgRefNum set tmgRefNum=+$order(^TMG("TMGIDE",$J,"VARTRACE","DELTA",""),-1)
565 new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum))
566 new TMG set TMG(1)="ADDED^Additions",TMG(2)="KILLED^Kills",TMG(3)="CHANGED^Changes"
567 new i for i=1,2,3 do
568 . new node set node=$piece(TMG(i),"^",1)
569 . new title set title=$piece(TMG(i),"^",2)
570 . if $data(@tmgRefDelta@(node)) do
571 . . write title,": "
572 . . new varname set varname=""
573 . . for set varname=$order(@tmgRefDelta@(node,varname)) quit:(varname="") do
574 . . . write varname,"=",$get(@tmgRefDelta@(node,varname))," ; "
575 . . write !
576 quit
577
578
579RecordVTrace
580 ;"Purpose: To keep a trace of changes to the system variable table.
581 new tmgFullRef set tmgFullRef=$name(^TMG("TMGIDE",$J,"VARTRACE","FULL"))
582 new tmgRefNum set tmgRefNum=+$order(@tmgFullRef@(""),-1)+1
583 if tmgRefNum'>0 goto RVTDn
584 new tmgRefCurF set tmgRefCurF=$name(@tmgFullRef@(tmgRefNum))
585 new tmgRefPriorF set tmgRefPriorF=$name(@tmgFullRef@(tmgRefNum-1))
586 new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum))
587 do StoreVars(tmgRefCurF)
588 if $data(@tmgRefPriorF) do
589 . do DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta)
590 . kill @tmgRefPriorF
591RVTDn quit
592
593StoreVars(tmgRef)
594 ;"Purpose: To copy system variable table to a storage area
595 ;"Input: Ref -- the NAME of the global to store table at
596 ;"Results: none
597 ;"NOTICE: all vars beginning with "tmg" are NOT shown.
598 new tmgArray zshow "V":tmgArray ;"copy system table to local variable
599 new idx set idx=0
600 for set idx=$order(tmgArray("V",idx)) quit:(idx="") do
601 . new s set s=tmgArray("V",idx)
602 . new varname set varname=$piece(s,"=",1)
603 . quit:(varname="")!($extract(varname,1,3)="tmg")
604 . new value set value=$p(s,"=",2,999)
605 . set @tmgRef@(varname)=value ;"reformat and store in a global var
606 quit
607
608DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta)
609 ;"Purpose: To create a record that shows difference between tmgRefCurF and
610 ;" tmgRefPriorF, and stores the difference
611 ;"Note: Possible differences:
612 ;" 1. New record has a new variable, not previously in existence
613 ;" 2. New record has same variable, but changed value
614 ;" 3. New record does NOT have variable that previously existed.
615 ;"Input: tmgRefCurF -- reference of current full variable store
616 ;" tmgRefPriorF -- reference of prior full viariable store
617 ;" tmgRefDelta -- reference to store changes to. Output Format:
618 ;" @tmgRefDelta@('ADDED',varname)=value
619 ;" @tmgRefDelta@('KILLED',varname)=""
620 ;" @tmgRefDelta@('CHANGED',varname)=new value
621 ;"Result: None. But any prior entry in @tmgRefDelta is deleted and changed as above.
622 ;
623 kill @tmgRefDelta
624 new varname
625 ;"First look for additions and changes
626 set varname=""
627 for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do
628 . if $data(@tmgRefPriorF@(varname)) do quit
629 . . if $get(@tmgRefPriorF@(varname))'=$get(@tmgRefCurF@(varname)) do
630 . . . set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname))
631 . set @tmgRefDelta@("ADDED",varname)=$get(@tmgRefCurF@(varname))
632 ;
633 ;"Next, look for deletions
634 set varname=""
635 for set varname=$order(@tmgRefPriorF@(varname)) quit:(varname="") do
636 . if $data(@tmgRefCurF@(varname)) quit
637 . set @tmgRefDelta@("KILLED",varname)=$get(@tmgRefPriorF@(varname))
638 ;
639 quit
640 ;";"Finally, look for changes
641 ;"set varname=""
642 ;"for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do
643 ;". if $data(@tmgRefPriorF@(varname))=0 quit
644 ;". if $get(@tmgRefPriorF@(varname))=$get(@tmgRefCurF@(varname)) quit
645 ;". set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname))
646 ;"quit
647
648 ;"================================================================
Note: See TracBrowser for help on using the repository browser.