TMGIDE6 ;TMG/kst/GT/M debugger Code Coloration ;4/4/09, 5/27/10 ;;1.0;TMG-LIB;**1**;4/4/09 ; ;" TMG IDE Code Coloration ;" ;" K. Toppenberg ;" 4/4/09 ;" License: GPL Applies ;" ;"------------------------------------------------------------ ;"PUBLIC API ;"------------------------------------------------------------ ;"ShowLine(line,Options,BkColor) -- Encode and write out a line of code with colors ;"WriteMLine(line,BkColor) -- write out markup line, converting tags into colors ;"MarkupLine(line,Options) -- add markup tags that will allow coloration. ;"------------------------------------------------------------ ;"PRIVATE API ;"------------------------------------------------------------ ;"------------------------------------------------------------ ;"------------------------------------------------------------ temp new tempPos,pos,offset set pos="^PSOORFIN" new Options set Options("XCMD")=1 set Options("LCASE")=1 for offset=50:1:58 do . set tempPos="+"_offset_pos . new line set line=$text(@tempPos) . write offset,": " if $$ShowLine(line,.Options,40) write ! do VTATRIB^TMGTERM(0) ;"Reset colors quit ShowPos(Pos) ;"A temp function to show out code at a given position. new line set line=$text(@Pos) write Pos,": " if $$ShowLine(line) write ! quit ShowLine(line,Options,MaxChar) ;"Purpose: to encode and write out a line of code with colors ;"Input: line -- the code line to show ;" Options -- See MarkupLine for format ;" MaxChar -- OPTIONAL. Max count of characters to be allowed written. ;"Results: returns the actual number of chars written to screen. new temp set temp=$$MarkupLine(line,.Options) ;"write "{",$get(MaxChar),"}" new result set result=$$WriteMLine(temp,.MaxChar) quit result WriteMLine(line,MaxChar) ;"Purpose: to write out markup line, converting tags into colors) ;"Input: line -- the text to show, created by MarkupLine. DON'T pass by reference ;" MaxChar -- OPTIONAL. Max count of characters to be allowed written. ;"result: number of actual characters written to screen (removing tags) new result set result=0 set MaxChar=$get(MaxChar,9999) for quit:($length(line)'>0)!(result>MaxChar) do . new p set p=$find(line,"{C") . if p>0 do ;"start color found . . new partS set partS=$extract(line,1,p-3) . . do SetColors^TMGIDE2("NORM") . . do DoWrite(partS,.result,MaxChar) . . ;"write partS set result=result+$length(partS) . . set line=$extract(line,p-2,999) . . new code set code=$$GetWord^TMGSTUTL(line,1,"{","}") . . set line=$extract(line,$length(code)+3,999) ;"shorten to after color tag onward . . new mode set mode=$piece(code,":",2) . . do SetColors^TMGIDE2(mode) . . set p=$find(line,"{C/}") ;"look for close color directive . . if p>0 do . . . set partS=$extract(line,1,p-5) ;"get text up to closing color . . . do DoWrite(partS,.result,MaxChar) . . . ;"write partS set result=result+$length(partS) . . . do SetColors^TMGIDE2("NORM") . . . set line=$extract(line,p,999) ;"shorten to next segment after closing color onward . . else do . . . do DoWrite(line,.result,MaxChar) . . . ;"write line set result=result+$length(line) . . . set line="" . else do . . do DoWrite(line,.result,MaxChar) . . ;"write line set result=result+$length(line) . . set line="" quit result DoWrite(s,CurLen,MaxLen) ;"Purpose: To do a controlled write to the screen. ;"Input: s -- the text to write ;" CurLen -- PASS BY REFERENCE. Current Num chars that have been written ;" MaxLen -- the limit to chars that can be written to screen. new len set len=$length(s) if CurLen+len>MaxLen do . set s=$extract(s,1,(MaxLen-CurLen)) . set len=$length(s) write s set CurLen=CurLen+len quit MarkupLine(line,Options) ;"Purpose: To take an arbitrary line of code and add markup tags ;" that will allow coloration. ;"Input : line -- the line of code to consider. DON'T pass by reference. ;" Options -- PASS BY REFERENCE. OPTIONAL. Format ;" Options('XCMD')=1 --> turn I --> IF etc. (expand commands) ;" Options('UCASE')=1 --> turn commands into UPPER CASE ;" Options('LCASE')=1 --> turn commands into LOWER CASE ;" Options('Tab')=8 --> e.g. turn $char(9) into 8 spaces (Default is 5) ;"Results : returns line with markup added. Format: ;" {C:Name}...{C/}aaaa bbb ccc{C:Name2}ddddd{C/} ;" 'Name' will be one of the following: ;" LABEL -- for a code label ;" CMD -- for a command, e.g. IF F GOTO ELSE etc. ;" FN -- anything starting with $$ ;" MOD -- e.g. ^MYMODULE ;" IFN -- intrinsic function, i.e. starting with $ ;" STR -- a string ;" PC -- a post-conditional ;" # -- a comment new result set result="" new token,cmd,arg,tabStr,p,ch new tabLen set tabLen=$get(Options("Tab"),5) set $piece(tabStr," ",tabLen)="" set line=$get(line) set line=$translate(line,$char(9),tabStr) ;"turn tabs into spaces if $extract(line,1)'=" " do . set token=$piece(line," ",1) . set line=$piece(line," ",2,999) . set result="{C:LABEL}"_token_"{C/} " for p=1:1 quit:(p>$length(line))!($extract(line,p)'=" ") set result=result_$extract(line,1,p-1) ;"get leading space set line=$extract(line,p,999) new comment set comment="" ;"Extract comments first... set p=1 for set p=$find(line,";",p) quit:(p'>0) do . if $$InQt^TMGSTUTL(line,p-1) quit . set comment=$extract(line,p-1,999) . set comment="{C:#}"_comment_"{C/}" . set line=$extract(line,1,p-2) ;"====== Loop to get COMMAND ARG pairs ====" for quit:($length(line)'>0) do . for set ch=$extract(line,1) quit:(" ."'[ch)!(ch="") do . . set result=result_ch,line=$extract(line,2,999) . quit:(line="") . set token=$$NextBlock(.line) . if token[":" do . . set cmd=$$NextBlock(.token,":") . . set result=result_$$HndlCmd(cmd,.Options)_"{C:PC}:{C/}" . . set result=result_$$HndlArgs(token)_" " . else do . . set result=result_$$HndlCmd(token,.Options)_" " . set arg=$$NextBlock(.line) . set arg=$$HndlArgs(arg) . set result=result_arg_" " ; set result=result_comment ;"add back comment (if any) quit result ; HndlArgs(Args) ;"Purpose: to return a formatted arguments text ;"Input: Args -- the text that supplies arguments to a command, OR ;" the text that is post-conditional code ;"results: returns the Args with markup code. new p set p=1 for set p=$find(Args,"$$",p) quit:(p'>0) do quit:(p'>0) ;"Handle functions . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit . new fnName set fnName="$$"_$$GetWord^TMGSTUTL(Args,p,"$","():^= _") . new partA,partB . set partA=$extract(Args,1,p-3) . set partB=$extract(Args,p-2+$length(fnName),999) . set Args=partA_"{C:FN}"_fnName_"{C/}"_partB . set p=p+6+$length(fnName) ;"6=length of {C:FN} set p=1 for set p=$find(Args,"$",p) quit:(p'>0) do quit:(p'>0) ;"Handle intrinsic functions . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit . if $extract(Args,p)="$" set p=p+1 quit ;"avoid $$ matches . new fnName set fnName="$"_$$GetWord^TMGSTUTL(Args,p,"$","():,= _") . new partA,partB . set partA=$extract(Args,1,p-2) . set partB=$extract(Args,p-1+$length(fnName),999) . set Args=partA_"{C:IFN}"_fnName_"{C/}"_partB . set p=p+7+$length(fnName) ;"7=length of {C:IFN} set p=1 for set p=$find(Args,"^",p) quit:(p'>0) do quit:(p'>0);"Handle Modules . if $$InQt^TMGSTUTL(Args,p-1) set p=$find(Args,"""",p) quit . new modName set modName="^"_$$GetWord^TMGSTUTL(Args,p,"^","():,= _") . new partA,partB . set partA=$extract(Args,1,p-2) . set partB=$extract(Args,p-1+$length(modName),999) . set Args=partA_"{C:MOD}"_modName_"{C/}"_partB . set p=p+7+$length(modName) ;"7=length of {C:MOD} set p=1 for set p=$find(Args,"""",p) quit:(p'>0) do ;"Handle Strings . new p2 . if $extract(Args,p)="""" set p2=p . else set p2=$$StrBounds^TMGSTUTL(Args,p) . if p2=0 set p=999 quit . new partA,partB,partC . set partA=$extract(Args,1,p-2) . set partB=$extract(Args,p-1,p2) . set partC=$extract(Args,p2+1,999) . set Args=partA_"{C:STR}"_partB_"{C/}"_partC . set p=p+7+$length(partB) ;"7=length of {C:STR} quit Args HndlCmd(Cmd,Options) ;"Purpose: Return formatted command ;"Input: Cmd -- the mumps command ;" Options -- OPTIONAL. Format: ;" Options('XCMD')=1 --> turn I --> IF etc. (expand commands) ;" Options('SCMD')=1 --> turn IF --> I etc. (shrink commands) ;" Options('UCASE')=1 --> turn commands into UPPER CASE ;" Options('LCASE')=1 --> turn commands into LOWER CASE ;"Results: returns the command with markup code new result set result="" set Cmd=$get(Cmd) new tempCmd set tempCmd=$$UP^XLFSTR(Cmd) if $get(Options("XCMD")) do . if tempCmd="AB" set Cmd="ABLOCK" quit . if tempCmd="A" set Cmd="ASSIGN" quit . if tempCmd="ASTA" set Cmd="ASTART" quit . if tempCmd="ASTO" set Cmd="ASTOP" quit . if tempCmd="AUNB" set Cmd="AUNBLOCK" quit . if tempCmd="B" set Cmd="BREAK" quit . if tempCmd="C" set Cmd="CLOSE" quit . if tempCmd="D" set Cmd="DO" quit . if tempCmd="E" set Cmd="ELSE" quit . if tempCmd="ESTA" set Cmd="ESTART" quit . if tempCmd="ESTO" set Cmd="ESTOP" quit . if tempCmd="ETR" set Cmd="ETRIGGER" quit . if tempCmd="F" set Cmd="FOR" quit . if tempCmd="G" set Cmd="GOTO" quit . ;"if tempCmd="H" set Cmd="HALT" quit . ;"if tempCmd="H" set Cmd="HANG" quit . if tempCmd="I" set Cmd="IF" quit . if tempCmd="J" set Cmd="JOB" quit . if tempCmd="K" set Cmd="KILL" quit . if tempCmd="KS" set Cmd="KSUBSCRIPTS" quit . if tempCmd="KV" set Cmd="KVALUE" quit . if tempCmd="L" set Cmd="LOCK" quit . if tempCmd="M" set Cmd="MERGE" quit . if tempCmd="N" set Cmd="NEW" quit . if tempCmd="O" set Cmd="OPEN" quit . if tempCmd="Q" set Cmd="QUIT" quit . if tempCmd="R" set Cmd="READ" quit . if tempCmd="RL" set Cmd="RLOAD" quit . if tempCmd="RS" set Cmd="RSAVE" quit . if tempCmd="S" set Cmd="SET" quit . if tempCmd="TC" set Cmd="TCOMMIT" quit . if tempCmd="TH" set Cmd="THEN" quit . if tempCmd="TRE" set Cmd="TRESTART" quit . if tempCmd="TRO" set Cmd="TROLLBACK" quit . if tempCmd="TS" set Cmd="TSTART" quit . if tempCmd="U" set Cmd="USE" quit . if tempCmd="V" set Cmd="VIEW" quit . if tempCmd="W" set Cmd="WRITE" quit . if tempCmd="X" set Cmd="XECUTE" quit . if tempCmd="ZWR" set Cmd="ZWRITE" quit if $get(Options("SCMD")) do . if tempCmd="ABLOCK" set Cmd="AB" quit . if tempCmd="ASSIGN" set Cmd="A" quit . if tempCmd="ASTART" set Cmd="ASTA" quit . if tempCmd="ASTOP" set Cmd="ASTO" quit . if tempCmd="AUNBLOCK" set Cmd="AUNB" quit . if tempCmd="BREAK" set Cmd="B" quit . if tempCmd="CLOSE" set Cmd="C" quit . if tempCmd="DO" set Cmd="D" quit . if tempCmd="ELSE" set Cmd="E" quit . if tempCmd="ESTART" set Cmd="ESTA" quit . if tempCmd="ESTOP" set Cmd="ESTO" quit . if tempCmd="ETRIGGER" set Cmd="ETR" quit . if tempCmd="FOR" set Cmd="F" quit . if tempCmd="GOTO" set Cmd="G" quit . if tempCmd="HALT" set Cmd="H" quit . if tempCmd="HANG" set Cmd="H" quit . if tempCmd="IF" set Cmd="I" quit . if tempCmd="JOB" set Cmd="J" quit . if tempCmd="KILL" set Cmd="K" quit . if tempCmd="KSUBSCRIPTS" set Cmd="KS" quit . if tempCmd="KVALUE" set Cmd="KV" quit . if tempCmd="LOCK" set Cmd="L" quit . if tempCmd="MERGE" set Cmd="M" quit . if tempCmd="NEW" set Cmd="N" quit . if tempCmd="OPEN" set Cmd="O" quit . if tempCmd="QUIT" set Cmd="Q" quit . if tempCmd="READ" set Cmd="R" quit . if tempCmd="RLOAD" set Cmd="RL" quit . if tempCmd="RSAVE" set Cmd="RS" quit . if tempCmd="SET" set Cmd="S" quit . if tempCmd="TCOMMIT" set Cmd="TC" quit . if tempCmd="THEN" set Cmd="TH" quit . if tempCmd="TRESTART" set Cmd="TRE" quit . if tempCmd="TROLLBACK" set Cmd="TRO" quit . if tempCmd="TSTART" set Cmd="TS" quit . if tempCmd="USE" set Cmd="U" quit . if tempCmd="VIEW" set Cmd="V" quit . if tempCmd="WRITE" set Cmd="W" quit . if tempCmd="XECUTE" set Cmd="X" quit . if tempCmd="ZWRITE" set Cmd="ZWR" quit if $get(Options("UCASE")) set Cmd=$$UP^XLFSTR(Cmd) if $get(Options("LCASE")) set Cmd=$$LOW^XLFSTR(Cmd) set result="{C:CMD}"_Cmd_"{C/}" quit result NextBlock(line,Div) ;"Purpose: to return from the begining to the next space. Space is ;" discarded. ;" e.g. line='This is a test', then function will return 'This' ;" and line will be changed to be 'is a test' ;" e.g. line='quit:(test) do' will return 'quit:(test)' ;" and line will be changed to ' do' (with 1 space) ;" e.g. line=' do' will return '' ;" and line will be changed to 'do' ;" e.g. line='test' will return 'test' ;" and line will be changed to '' ;" NO e.g. line='..test' will return '...' ;" NO and line will be changed to 'test' ;"Input: line -- PASS BY REFERENCE ;" Div -- the divider of blocks. OPTIONAL. Default=" " ;"Result: the first block, see above. new result set result="" set Div=$get(Div," ") new done set done=0 new p set p=1 for do quit:(done) . set p=$find(line,Div,p) . if p'>0 set result=line,line="",done=1 quit . if $$InQt^TMGSTUTL(line,p-1) quit . set result=$extract(line,1,p-2) . set line=$extract(line,p,999) . set done=1 quit result ; InitColors ;"Purpose: to establish tmgDbgOptions globally-scoped var for colors, new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) ;"write "$DATA(@ref)=",$DATA(@ref),! new refMaster set refMaster=$name(^TMG("TMGIDE","COLORS")) ;"write "refMaster=",refMaster,! ;"write "$DATA(@refMaster)=",$DATA(@refMaster),! ;"write "here is dump...",! ;"zwr ^TMG("TMGIDE","COLORS",*) ;"do PressToCont^TMGUSRIF if ($data(@ref)=0) do . if ($data(@refMaster)'=0) do . . merge @ref=^TMG("TMGIDE","COLORS") ;"copy master into job's . else do . . if $data(TMGcBlack)=0 do SetGlobals^TMGTERM . . set @ref@("BACKGROUND")=TMGcBlue . . set @ref@("HighExecPos")=TMGcGrey . . set @ref@("HighBkPos")=TMGcBRed . . set @ref@("BkPos")=TMGcRed . . set @ref@("Highlight")=TMGcFGBWhite . . ;"----------------------------------- . . set @ref@("LABEL","fg")=TMGcBYellow . . set @ref@("LABEL","bg")=TMGcRed . . set @ref@("SPECIAL","fg")=TMGcBYellow . . set @ref@("SPECIAL","bg")=TMGcRed . . ;"----------------------------------- . . set @ref@("NORM","fg")=TMGcFGBWhite . . set @ref@("NORM","bg")="@" ;"signal to use current background color . . set @ref@("CMD","fg")=TMGcBRed . . set @ref@("CMD","bg")="@" . . set @ref@("FN","fg")=TMGcBCyan . . set @ref@("FN","bg")="@" . . set @ref@("MOD","fg")=TMGcBBlue . . set @ref@("MOD","bg")="@" . . set @ref@("IFN","fg")=TMGcRed . . set @ref@("IFN","bg")="@" . . set @ref@("STR","fg")=TMGcBMagenta . . set @ref@("STR","bg")="@" . . set @ref@("PC","fg")=TMGcBRed . . set @ref@("PC","bg")="@" . . set @ref@("#","fg")=TMGcBYellow . . set @ref@("#","bg")="@" . . merge @refMaster=@ref quit ; EditColors ;"Purpose: Enable Edit Colors write # new ref set ref=$name(^TMG("TMGIDE",$J,"COLORS")) new Menu,Menu2,UsrSlct,UsrSlct2,UsrRaw,fg,bg,ct set ct=1 set Menu(0)="Pick Color to Edit" set Menu(ct)="Window Background color"_$char(9)_"BACKGROUND",ct=ct+1 set Menu(ct)="Current Execution Position Background Color"_$char(9)_"HighExecPos",ct=ct+1 set Menu(ct)="Highlighted Breakpoint Background Color"_$char(9)_"HighBkPos",ct=ct+1 set Menu(ct)="Breakpoint Background Color"_$char(9)_"BkPos",ct=ct+1 set Menu(ct)="Highlight Background Color"_$char(9)_"Highlight",ct=ct+1 set Menu(ct)="Label Foreground & Background Color"_$char(9)_"LABEL",ct=ct+1 set Menu(ct)="'Special' Foreground & Background Color"_$char(9)_"SPECIAL",ct=ct+1 set Menu(ct)="Normal Text Foreground Color"_$char(9)_"NORM",ct=ct+1 set Menu(ct)="Command Foreground Color"_$char(9)_"CMD",ct=ct+1 set Menu(ct)="Functions Foreground Color"_$char(9)_"FN",ct=ct+1 set Menu(ct)="Module/Global reference Foreground Color"_$char(9)_"MOD",ct=ct+1 set Menu(ct)="Mumps intrinsic functions Foreground Color"_$char(9)_"IFN",ct=ct+1 set Menu(ct)="String Foreground Color"_$char(9)_"STR",ct=ct+1 set Menu(ct)="Post-conditional Foreground Color"_$char(9)_"PC",ct=ct+1 set Menu(ct)="Comments Foreground Color"_$char(9)_"#",ct=ct+1 new i M1 set i=0 for set i=$order(Menu(i)) quit:(i="") do . new bg,fg . new mode set mode=$piece(Menu(i),$char(9),2) . if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[mode do . . set bg=$get(@ref@(mode)) . . set fg=$select(bg=0:7,1:10) . else do . . set fg=$get(@ref@(mode,"fg")) . . set bg=$get(@ref@(mode,"bg")) . . if bg="@" set bg=$get(@ref@("BACKGROUND"),0) . set Menu(i,"COLOR","fg")=fg . set Menu(i,"COLOR","bg")=bg ; set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^",.UsrRaw) if UsrSlct="^" goto ECDn if "BACKGROUND,Highlight,HighBkPos,HighExecPos,BkPos"[UsrSlct do goto M1 . set @ref@(UsrSlct)=$$PickBGColor^TMGTERM() if UsrSlct=0 set UsrSlct="" goto M1 if "SPECIAL,LABEL"'[UsrSlct do goto M1 . new bg set bg=$get(@ref@("BACKGROUND"),0) . write "Setting bg=",bg,! . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),bg) new Label set Label=$get(Menu(UsrRaw)) kill Menu2 set Menu2(0)="For "_$piece(Label,$char(9),1)_"..." set Menu2(1)="Edit Foreground color"_$char(9)_"fg" set Menu2(2)="Edit Background color"_$char(9)_"bg" set Menu2(3)="Edit BOTH colors"_$char(9)_"fg&bg" write ! M2 set fg=+$get(@ref@(UsrSlct,"fg"),1) set bg=+$get(@ref@(UsrSlct,"bg"),0) do VCOLORS^TMGTERM(fg,bg) write "Here are the current colors..." do VTATRIB^TMGTERM(0) ;"Reset colors write ! set UsrSlct2=$$Menu^TMGUSRIF(.Menu2,"^",.UsrRaw) if UsrSlct2="^" goto M1 M3 if UsrSlct2="fg" do goto M2 . set @ref@(UsrSlct,"fg")=$$PickFGColor^TMGTERM(@ref@(UsrSlct,"fg"),@ref@(UsrSlct,"bg")) if UsrSlct2="bg" do goto M2 . set @ref@(UsrSlct,"bg")=$$PickBGColor^TMGTERM(@ref@(UsrSlct,"bg")) if UsrSlct2="fg&bg" do goto M2 . do PickColors^TMGTERM(.fg,.bg) . set @ref@(UsrSlct,"fg")=fg . set @ref@(UsrSlct,"bg")=bg goto M2 ECDn new % set %=2 write "Set current colors as default" do YN^DICN if %=1 do . kill ^TMG("TMGIDE","COLORS") . merge ^TMG("TMGIDE","COLORS")=^TMG("TMGIDE",$J,"COLORS") quit ; ; TestColors do InitColors new mode for mode="Highlight","HighExecPos","BkPos","HighBkPos","SPECIAL","NORM","LABEL","CMD","FN","MOD","IFN","STR","PC","#" do . do SetColors^TMGIDE2(mode) . write "Here is text for ",mode,"...." . do SetColors^TMGIDE2("Reset") . write ! quit ;"============== Code for TRACE functionality ================= ShowTrace ;"Purpose: to show current trace record of execution. ;"if $get(tmgDbgOptions("TRACE"))=1 quit new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE")) if $data(@ref) do . write "SHOW TRACE RECORDS:",! . new NumRecs set NumRecs=$order(@ref@(""),-1) . write NumRecs," trace lines to display",! . new count set count=1 . new % set %=1 . write "Also display code for each line" do YN^DICN write ! . if %=-1 quit . new showCode set showCode=(%=1) . new Colorize set Colorize=0 . if %=1 do quit:(%=-1) . . set %=1 write "Colorize code" do YN^DICN write ! . . set Colorize=(%=1) . new %ZIS . set %ZIS("A")="Enter Output Device: " . set %ZIS("B")="HOME" . do ^%ZIS ;"standard device call . if POP do quit . . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening output. Aborting.") . use IO . new i set i="" . for set i=$order(@ref@(i)) quit:(i="")!($get(TMGPTCABORT)=1) do . . new s set s=$get(@ref@(i)) . . write s . . if showCode do . . . new pos set pos=$piece(s,".",$length(s,".")) . . . if pos="" write " ??",! quit . . . ;"write "pos=",pos,! . . . new code . . . do . . . . new $etrap set $etrap="set code=""Error -- ""_pos,$etrap="""",$ecode=""""" . . . . set code=$text(@pos) . . . write ?25,":" . . . new x for x=1:1:$length(s,".")-1 write " " . . . if Colorize do . . . . if $$ShowLine(code,.tmgDbgOptions) . . . . do SetColors^TMGIDE2("Reset") . . . else write code . . . write ! . . else write " ",! . . ;"set count=count+1 . . if count>20 do . . . do PressToCont^TMGUSRIF ;" will set TMGPTCABORT=1 if user entered ^ . . . do CUU^TMGTERM(1) . . . write " ",! . . . do CUU^TMGTERM(1) . . . set count=1 else do . write "(No Trace record found)",! do ^%ZISC ;" Close the output device do PressToCont^TMGUSRIF quit RecordTrace(ExecPos) ;"Purpose: To keep trace record of execution as program runs. ;"Input:ExecPos -- Current execution position new ref set ref=$name(^TMG("TMGIDE",$J,"TRACE")) new Stack do GetStackInfo^TMGIDE2(.Stack,ExecPos) new str set str=$$StackStr(.Stack) new i set i=+$get(@ref)+1 set @ref@(i)=str set @ref=i quit StackStr(Stack) ;"Purpose: Turn stack array into a single string ;"Input: Stack -- PASS BY REFERENCE, Numbered array, as created by GetStackInfo^TMGIDE2 ;"Result: returns string with latest position, with ;" a "." leading for each level of indenction. ;" new result set result="" new count set count=+$order(Stack(""),-1) if count>0 do . new x for x=1:1:(count-1) set result=result_"." . new s set s=$get(Stack(count)) . if s[" <--" set s=$piece(s," <--",1) . if s[" " set s=$piece(s," ",2) . set result=result_s quit result ;"============== Code for VAR TRACING functionality ================= ShowVTrace ;"Purpose: Output changes from last step new tmgRefNum set tmgRefNum=+$order(^TMG("TMGIDE",$J,"VARTRACE","DELTA",""),-1) new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum)) new TMG set TMG(1)="ADDED^Additions",TMG(2)="KILLED^Kills",TMG(3)="CHANGED^Changes" new i for i=1,2,3 do . new node set node=$piece(TMG(i),"^",1) . new title set title=$piece(TMG(i),"^",2) . if $data(@tmgRefDelta@(node)) do . . write title,": " . . new varname set varname="" . . for set varname=$order(@tmgRefDelta@(node,varname)) quit:(varname="") do . . . write varname,"=",$get(@tmgRefDelta@(node,varname))," ; " . . write ! quit RecordVTrace ;"Purpose: To keep a trace of changes to the system variable table. new tmgFullRef set tmgFullRef=$name(^TMG("TMGIDE",$J,"VARTRACE","FULL")) new tmgRefNum set tmgRefNum=+$order(@tmgFullRef@(""),-1)+1 if tmgRefNum'>0 goto RVTDn new tmgRefCurF set tmgRefCurF=$name(@tmgFullRef@(tmgRefNum)) new tmgRefPriorF set tmgRefPriorF=$name(@tmgFullRef@(tmgRefNum-1)) new tmgRefDelta set tmgRefDelta=$name(^TMG("TMGIDE",$J,"VARTRACE","DELTA",tmgRefNum)) do StoreVars(tmgRefCurF) if $data(@tmgRefPriorF) do . do DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta) . kill @tmgRefPriorF RVTDn quit StoreVars(tmgRef) ;"Purpose: To copy system variable table to a storage area ;"Input: Ref -- the NAME of the global to store table at ;"Results: none ;"NOTICE: all vars beginning with "tmg" are NOT shown. new tmgArray zshow "V":tmgArray ;"copy system table to local variable new idx set idx=0 for set idx=$order(tmgArray("V",idx)) quit:(idx="") do . new s set s=tmgArray("V",idx) . new varname set varname=$piece(s,"=",1) . quit:(varname="")!($extract(varname,1,3)="tmg") . new value set value=$p(s,"=",2,999) . set @tmgRef@(varname)=value ;"reformat and store in a global var quit DiffVars(tmgRefCurF,tmgRefPriorF,tmgRefDelta) ;"Purpose: To create a record that shows difference between tmgRefCurF and ;" tmgRefPriorF, and stores the difference ;"Note: Possible differences: ;" 1. New record has a new variable, not previously in existence ;" 2. New record has same variable, but changed value ;" 3. New record does NOT have variable that previously existed. ;"Input: tmgRefCurF -- reference of current full variable store ;" tmgRefPriorF -- reference of prior full viariable store ;" tmgRefDelta -- reference to store changes to. Output Format: ;" @tmgRefDelta@('ADDED',varname)=value ;" @tmgRefDelta@('KILLED',varname)="" ;" @tmgRefDelta@('CHANGED',varname)=new value ;"Result: None. But any prior entry in @tmgRefDelta is deleted and changed as above. ; kill @tmgRefDelta new varname ;"First look for additions and changes set varname="" for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do . if $data(@tmgRefPriorF@(varname)) do quit . . if $get(@tmgRefPriorF@(varname))'=$get(@tmgRefCurF@(varname)) do . . . set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname)) . set @tmgRefDelta@("ADDED",varname)=$get(@tmgRefCurF@(varname)) ; ;"Next, look for deletions set varname="" for set varname=$order(@tmgRefPriorF@(varname)) quit:(varname="") do . if $data(@tmgRefCurF@(varname)) quit . set @tmgRefDelta@("KILLED",varname)=$get(@tmgRefPriorF@(varname)) ; quit ;";"Finally, look for changes ;"set varname="" ;"for set varname=$order(@tmgRefCurF@(varname)) quit:(varname="") do ;". if $data(@tmgRefPriorF@(varname))=0 quit ;". if $get(@tmgRefPriorF@(varname))=$get(@tmgRefCurF@(varname)) quit ;". set @tmgRefDelta@("CHANGED",varname)=$get(@tmgRefCurF@(varname)) ;"quit ;"================================================================