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

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

replacing soft links with actual files

File size: 28.2 KB
Line 
1TMGIDE6 ;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
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 ;"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 ;
385EditColors
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
410M1 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 !
441M2 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
450M3 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
460ECDn
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 ;
470TestColors
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
483ShowTrace
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
540RecordTrace(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
551StackStr(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
569ShowVTrace
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
586RecordVTrace
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
598RVTDn quit
599
600StoreVars(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
615DiffVars(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 ;"================================================================
Note: See TracBrowser for help on using the repository browser.