TMGIDE ;TMG/kst/A debugger/tracer for GT.M ;03/25/06 ; 5/14/10 6:17pm ;;1.0;TMG-LIB;**1**;03/29/09 ;" A Debug/Tracer for GT.M ;" ;" K. Toppenberg ;" (c) 4-13-2005 ;" License: LGPL Applies ;" ;" ;" This program will launch a shell for the TMG STEP TRAP debugger ;" It provides the user with a prompt, like this: ;" ;" (^ to quit) IDE> ;" ;" Any valid M code may be entered here. To use the tracing ;" ability, launch a function, like this: ;" ;" (^ to quit) IDE>do ^MyFunction ;" ;" ;" Dependancies: ;" Uses TMGIDE2,TMGTERM,TMGUSRIF ;" ^DIM,XGF,XINDX7,XINDX8,XINDEX <-- VA code ;" %ZVEM* (if available) ;" ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"Start^TMGIDE -- launch Debugger ;"BKPT^TMGIDE -- set a breakpoint ;"KBKPT^TMGIDE -- kill (release) breakpoint ;"======================================================================= ;"PRIVATE API FUNCTIONS ;"======================================================================= ;"Prompt ;"ShutDown ;"ParsePos(pos,label,offset,routine,dmod) ;"ConvertPos(Pos,pArray) ;"ScanMod(Module,pArray) ;"BROWSENODES(current,Order,paginate,countNodes) ;"ShowNodes(pArray,order,paginate,countNodes) ;"ListCt(pArray) ;"TrimL(S,TrimCh) ;"TrimR(S,TrimCh) ;"Trim(S,TrimCh) ;"Substitute(S,Match,NewValue) ;"REPLACE(IN,SPEC) ;"DebugWrite(DBIndent,s,AddNewline) ;"DebugIndent(DBIndentForced) ;"$$ArrayDump(ArrayP,TMGIDX,indent) ;"ExpandLine(Pos) ;"CREF(X) ;"LGR() ;"UP(X) ;"READ(XGCHARS,XGTO) ;"READ2(XGCHARS,XGTO) ;"------------------------------------------------------------ ;"------------------------------------------------------------ START Start ;"Purpose: To Launch debugger. This is the entry point ; new tmgDbgOptions set tmgDbgOptions("TRACE")=0 ;"Turn off trace record by default set tmgDbgOptions("VARTRACE")=0 ;"Turn off trace vars by default kill ^TMG("TMGIDE",$J,"TRACE") ;"Delete former trace record when starting new run kill ^TMG("TMGIDE",$J,"VARTRACE") ;"Delete former var trace record when starting new run ; set $ZSTEP="" ;"Temporarily clear, in case active from prior run. <-- doesn't work... do EnsureEnv ;"Ensure fileman environment setup. do ClrDeadInfo ;"clear out any old data from dead jobs. ;"Set up variables with global scope (used by TMGIDE2) if $$GetScrnSize^TMGKERNL(,.TMGScrWidth) if $get(TMGScrWidth)="" set TMGScrWidth=$get(IOM,66)-1 if $get(TMGScrHeight)="" set TMGScrHeight=10 set TMGLROffset=0 set TMGTrap=1 set tmgStepMode="into" set tmgRunMode=1 set TMGZTRAP=$ZTRAP new TMGdbgHideList set TMGdbgHideList=$name(^TMG("TMGIDE",$J,"HIDE LIST")) kill @TMGdbgHideList if 1=1 do . set @TMGdbgHideList@("TMGIDE*")="" else do . set @TMGdbgHideList@("TMGIDE")="" . set @TMGdbgHideList@("TMGIDE1")="" . set @TMGdbgHideList@("TMGIDE2")="" . set @TMGdbgHideList@("TMGIDE3")="" . set @TMGdbgHideList@("TMGIDE4")="" . set @TMGdbgHideList@("TMGIDE5")="" . ;"set @TMGdbgHideList@("TMGIDE6")="" set @TMGdbgHideList@("TMGTERM")="" set @TMGdbgHideList@("TMGSTUTL")="" set @TMGdbgHideList@("X*")="" set @TMGdbgHideList@("%*")="" ;"set @TMGdbgHideList@("DI*")="" set @TMGdbgHideList@("%ZVE")="" set @TMGdbgHideList@("%ZVEMK")="" set @TMGdbgHideList@("XLFSTR")="" set @TMGdbgHideList@("XGF")="" set @TMGdbgHideList@("XGKB")="" do SetGlobals^TMGTERM do EnsureBreakpoints^TMGIDE2() do InitColors^TMGIDE6 new UsrSlct M1 new Menu set Menu(0)="Welcome to the TMG debugging environment" set Menu(1)="Start debugger in THIS window."_$char(9)_"AllInOne" set Menu(2)="Start debugger CONTROLLER for another Process."_$char(9)_"StartController" set Menu(3)="Debug, SENDING control to a Controller."_$char(9)_"StartSender" set Menu(4)="Set a custom breakpoint"_$char(9)_"SetBreakpoint" set Menu(5)="Kill a custom breakpoint"_$char(9)_"KillBreakpoint" set Menu(6)="Debug ANOTHER PROCESS"_$char(9)_"Interrupt" set Menu(7)="KILL ANOTHER PROCESS"_$char(9)_"KillOther" set Menu(8)="Run ^ZJOB"_$char(9)_"ZJob" set Menu(9)="View TRACE log from last run"_$char(9)_"Trace" set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") kill Menu ;"Prevent from cluttering variable table during debug run if UsrSlct="AllInOne" goto MenuDone if UsrSlct="StartController" do Controller^TMGIDE3 goto M1 if UsrSlct="StartSender" do Sender^TMGIDE4() goto M1 if UsrSlct="SetBreakpoint" do BKPT goto M1 if UsrSlct="KillBreakpoint" do KBKPT goto M1 if UsrSlct="Interrupt" do PICKINTR^TMGIDE5 goto M1 if UsrSlct="KillOther" do KillOther goto M1 if UsrSlct="ZJob" do ^ZJOB goto M1 if UsrSlct="Trace" do ShowTrace^TMGIDE6 goto M1 if UsrSlct="^" goto Done if UsrSlct=0 set UsrSlct="" goto M1 MenuDone do . new i for i=1:1:10 write ! write !,"Welcome to the TMG debugging environment",! write "Enter any valid M command...",! do SetErrTrap do Prompt("AllInOne") Done do ShutDown quit ;"------------------------------------------------------------------- SetErrTrap set $ZTRAP="do ErrTrap^TMGIDE2($ZPOS) break" set $ZSTATUS="" quit Prompt(Mode) ;"Purpose: to interact with user and run through code. ;"Mode: OPTIONAL: Default is 'AllInOne' ;" AllInOne --> debug output to same window ;" SendOut --> debug output to Controller widow set Mode=$get(Mode,"AllInOne") new ideBlankLine new HxI set HxI="" new TMGdbgLine set TMGdbgLine="" new TMGlastline set tmgStepMode="into" do SetupVars do INITKB^XGF() ;"set up keyboard input escape code processing Ppt2 do CHA^TMGTERM(1) write ideBlankLine do CHA^TMGTERM(1) write "(^ to quit) //",TMGdbgLine ; set TMGdbgLine=$$Read^TMGUSRIF("er",1200,,TMGdbgLine,.tmgXGRT) do INITKB^XGF() do TranslateKeys(.TMGdbgLine,tmgXGRT) ; if TMGdbgLine="?" do ShowHelp goto Ppt2 if TMGdbgLine="" set TMGdbgLine=$$GetHx(.HxI,1) goto Ppt2 if TMGdbgLine="" set TMGdbgLine=$$GetHx(.HxI,-1) goto Ppt2 if TMGdbgLine="^" set $ZSTEP="" goto PptDne ; write ! do SaveHx(TMGdbgLine) ; set tmgRunMode=1 ;"1=Step-by-step mode set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGIDE2($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" zstep into ;"consider wrapping the following line in an error trap. But would have to be cleared ;" somehow to allow QUIT command... xecute TMGdbgLine set $ZSTEP="" ;"turn off step capture write ! ; if '$data(ideBlankLine) do SetupVars ;"without out this, crash after running ^XUP set TMGdbgLine="",HxI="" set tmgStepMode="into" goto Ppt2 ;"loop for prompt again. PptDne quit TranslateKeys(UsrInput,tmgXGRT) ;"Purpose: translate input keys into a standard output. ;"Input: UsrInput -- PASS BY REFERENCE. set tmgXGRT=$get(tmgXGRT) if tmgXGRT="UP" set UsrInput="A" if tmgXGRT="DOWN" set UsrInput="Z" if tmgXGRT="RIGHT" set UsrInput="]" if tmgXGRT="LEFT" set UsrInput="[" if (UsrInput="") set UsrInput="" if (UsrInput="A") set UsrInput="" if (UsrInput="") set UsrInput="" if (UsrInput="Z") set UsrInput="" if (UsrInput="") set UsrInput="" if (UsrInput="[") set UsrInput="" if (UsrInput="") set UsrInput="" if (UsrInput="]") set UsrInput="" ;" if UsrInput="" set UsrInput="" if UsrInput="" set UsrInput="" if UsrInput="" set UsrInput="^" quit GetHx(HxI,Dir) ;"Purpose: to retrieve saved Hx ;"Input: HxI -- PASS BY REFERENCE. IN and OUT parameter ;" This is index of last command retrieved (or should pass as "" if first time) ;" Dir -- Optional. Default=1. ;" 1 = get previous history item ;" -1 = get next history item ;"Result: returns history item line new result set result="" new HxRef set HxRef=$name(^TMG("TMGIDE",$J,"CMD HISTORY")) set HxI=$order(@HxRef@(HxI),$get(Dir,1)) if HxI'="" set result=$get(@HxRef@(HxI)) quit result SaveHx(OneLine) ;"Purpose: To provide interface to saving command line hx. ;"Input: OneLine -- the line to store ;"Output: Will store hx as follows: ;" ^TMG('TMGIDE',$J,'CMD HISTORY',1)=1st line of Hx ;" ^TMG('TMGIDE',$J,'CMD HISTORY',2)=2nd line of Hx ;" ... new HxRef set HxRef=$name(^TMG("TMGIDE",$J,"CMD HISTORY")) new HxI set HxI=+$order(@HxRef@(""),-1) if $get(@HxRef@(HxI))'=OneLine do . set @HxRef@(HxI+1)=OneLine quit ShowHelp write !,"Here you should enter any valid M command, as would normally be",! write "entered at a GTM> prompt.",! write " Examples: WRITE ""HELLO"",! or DO ^TMGTEST",! quit SetupVars set Mode=$get(Mode,"AllInOne") set $piece(ideBlankLine," ",78)=" " set TMGlastLine="" set HxShowNum=0 quit EnsureEnv ;"Purpose: So ensure Fileman variables setup. if $text(DT^DICRW)'="" do . do DT^DICRW ;"ensure fileman's required variables are in place if +$get(DUZ)'>0 do . write "Entering TMG IDE. But first, let's set up an environment..." . new DIC set DIC=200 . set DIC(0)="MAEQ" . set DIC("A")="Please type your name: " . set DIC("?")="Please enter your user name, to setup environmental variables." . do ^DIC write ! . if +Y'>0 quit . do DUZ^XUP(+Y) quit ClrDeadInfo ;"Purpose: to clear out any info from dead (prior) runs new LiveJobs do MJOBS^TMGKERNL(.LiveJobs) new JNum set JNum="" for set JNum=$order(^TMG("TMGIDE",JNum)) quit:(+JNum'>0) do . if $get(TMGDEBUG) write "Job ",JNum," is " . if $data(LiveJobs(JNum)) do quit . . if $get(TMGDEBUG) write "still alive.",! . if $get(TMGDEBUG) write "still dead... killing it's info.",! . kill ^TMG("TMGIDE",JNum) quit KillOther ;"Purpose: To show currently running jobs, and allow user to kill on ;"Called from TMGIDE ; new array K1 kill array do MJOBS^TMGKERNL(.array) kill array($J) ;"don't show this process new Menu,UsrSlct new i,j set i="",j=1 for set i=$order(array(i)) quit:(i="") do . set Menu(j)="Job "_$get(array(i))_$char(9)_i . set j=j+1 if $data(Menu)=0 do goto KODone set Menu(0)="Pick Job to Kill/Terminate" set UsrSlct=$$Menu^TMGUSRIF(.Menu,"^") if UsrSlct="^" goto KODone if UsrSlct=0 set UsrSlct="" goto K1 if UsrSlct=+UsrSlct do KillPID^TMGKERNL(UsrSlct) goto K1 goto K1 KODone quit ;"------------------------------------------------------------------- ShutDown do KillGlobals^TMGTERM kill tmgStepMode ;" 2/10/06 kt kill ^TMP("TMGIDE",$J,"MODULES") do VTATRIB^TMGTERM(0) do RESETKB^XGF ;"turn off XGF escape key processing code. write "Leaving TMG debugging environment. Goodbye.",! quit ;"------------------------------------------------------------------- BKPT ;"Purpose: To ask user for an address, and set a breakpoint there ;" This can be done from GTM prompt, and debugger will be launched ;" when this address is reached during normal execution. read "Enter breakpoint (e.g. Label+8^MyFunct): ",Pos,! do SetBreakpoint^TMGIDE2(Pos) set $ZTRAP="" ;"This makes sure that Fileman error trap is not active quit KBKPT ;"Purpose: To ask user for an address, and kill (release) breakpoint there ;" This can be done from GTM prompt read "Enter breakpoint to be killed (released) (e.g. Label+8^MyFunct): ",Pos,! do RelBreakpoint^TMGIDE2(Pos) quit ;"------------------------------------------------------------ ;"------------------------------------------------------------ ;"Support Functions ;" ;"Note: I copied functions from other modules trying to reduce dependencies ;"------------------------------------------------------------ ;"------------------------------------------------------------ ParsePos(pos,label,offset,routine,dmod) ;"NOTE: Duplicate of function in TMGMISC ;"Purpose: to convert a pos string (e.g. X+2^ROUTINE$DMOD) into componant parts ;"Input: pos -- the string, as example above ;" label -- OUT PARAM, PASS BY REF, would return "x" ;" offset -- OUT PARAM, PASS BY REF, would return "+2" ;" routine -- OUT PARAM, PASS BY REF, would return "ROUTINE" ;" dmod -- OUT PARAM, PASS BY REF, would return "DMOD" ;"Results: none ;"Note: results are shortened to 8 characters. new s set s=$get(pos) set dmod=$piece(s,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE set routine=$piece(s,"^",2) ;"set routine=$extract(routine,1,8) //kt remove 3/1/08, new GTM needs > 8 chars set label=$piece(s,"^",1) set offset=$piece(label,"+",2) set label=$piece(label,"+",1) ;"set label=$extract(label,1,8) //kt remove 3/1/08, new GTM needs > 8 chars quit ConvertPos(Pos,pArray) ;"NOTE: Duplicate of function in TMGMISC ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into ;" one that is relative to the start of the file ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT ;"Input: Pos -- a position, as returned from $ZPOS ;" pArray -- pointer to (name of). Array holding holding tag offsets ;" pArray will be in this format: ;" pArray("ModuleA",1,"TAG")="ALabel1" ;" pArray("ModuleA",1,"OFFSET")=1 ;" pArray("ModuleA",2,"TAG")="ALabel2" ;" pArray("ModuleA",2,"OFFSET")=9 ;" pArray("ModuleA","Label1")=1 ;" pArray("ModuleA","Label2")=2 ;" pArray("ModuleA","Label3")=3 ;" pArray("ModuleB",1,"TAG")="BLabel1" ;" pArray("ModuleB",1,"OFFSET")=4 ;" pArray("ModuleB",2,"TAG")="BLabel2" ;" pArray("ModuleB",2,"OFFSET")=23 ;" pArray("ModuleB","Label1")=1 ;" pArray("ModuleB","Label2")=2 ;" pArray("ModuleB","Label3")=3 ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it ;"Result: returns the new position line, relative to the start of the file/module ;" new cpS new cpResult set cpResult="" new cpRoutine,cpLabel,cpOffset set cpS=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE if cpS="" do goto CPDone . write "Parse error: Nothing before $ in",cpS,! set cpRoutine=$piece(cpS,"^",2) if cpRoutine="" do goto CPDone . write "Parse error: No routine specified in: ",cpS,! set cpS=$piece(cpS,"^",1) set cpOffset=+$piece(cpS,"+",2) ;"if cpOffset="" set cpOffset=1 ;"else set cpOffset=+cpOffset set cpLabel=$piece(cpS,"+",1) if $data(@pArray@(cpRoutine))=0 do . new p2Array set p2Array=$name(@pArray@(cpRoutine)) . do ScanMod(cpRoutine,p2Array) new cpIdx set cpIdx=+$get(@pArray@(cpRoutine,cpLabel)) if cpIdx=0 do goto CPDone . ;"write "Parse error: Can't find ",cpRoutine,",",cpLabel," in stored source code.",! new cpGOffset set cpGOffset=@pArray@(cpRoutine,cpIdx,"OFFSET") set cpResult="+"_+(cpGOffset+cpOffset)_"^"_cpRoutine CPDone quit cpResult RelConvertPos(Pos,ViewOffset,pArray) ;"Purpose: to convert a positioning line from one that is relative to ;" the start of the file to one that is relative to the ;" last tag/label ;" e.g. +32^MYFUNCT --> START+8^MYFUNCT ;" I.e. this function in the OPPOSITE of ConvertPos ;"Input: Pos -- a position, as returned from $ZPOS ;" ViewOffset -- the offset from the Pos to get pos for ;" pArray -- pointer to (name of). Array holding holding tag offsets ;" see Description in ConvertPos() ;"Result: returns the new position line, relative to the start of the last tag/label ;"write !,"Here in RelConvertPos. Pos=",Pos," ViewOffset=",ViewOffset,! new zbRelPos,zbLabel,zbOffset,zbRoutine do ParsePos^TMGIDE(Pos,.zbLabel,.zbOffset,.zbRoutine) set zbRelPos=zbLabel_"+"_+(zbOffset+ViewOffset)_"^"_zbRoutine new zbTemp set zbTemp=zbRelPos ;"5/27/07 I don't know why following line was here. Removing. ;"It was breaking the setting of breakpoints. I wonder if I have now ;"broken conditional breakpoints... Figure that out later... ;"set zbRelPos=$$ConvertPos^TMGIDE(zbRelPos,pArray) if zbRelPos="" do . write "Before ConvertPos, zbRelPos=",zbTemp,! . write "Afterwards, zbRelPos=""""",! ;"write "Done RelConvertPos. Result=",zbRelPos,! quit zbRelPos ScanMod(Module,pArray) ;"NOTE: Duplicate of function in TMGMISC ;"Purpose: To scan a module and find all the labels/entry points/Entry points ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") ;" pArray -- pointer to (NAME OF) array Will be filled like this ;" pArray(1,"TAG")="Label1" ;" pArray(1,"OFFSET")=1 ;" pArray(2,"TAG")="Label2" ;" pArray(2,"OFFSET")=9 ;" pArray(3,"TAG")="Label3" etc. ;" pArray(3,"OFFSET")=15 ;" pArray("Label1")=1 ;" pArray("Label2")=2 ;" pArray("Label3")=3 ;" ;" NOTE: there seems to be a problem if the passed pArray value is "pArray", ;" so use another name. ;" ;"Output: Results are put into array ;"Result: none new smIdx set smIdx=1 new LabelNum set LabelNum=0 new smLine set smLine="" if $get(Module)="" goto SMDone ;"look for a var with global scope to see how how many characters are significant to GT.M if $get(zbSigNameLen)="" do . set zbSigNameLen=$$NumSigChs^TMGMISC() for do quit:(smLine="") . new smCh . set smLine=$text(+smIdx^@Module) . if smLine="" quit . set smLine=$$Substitute(smLine,$Char(9)," ") ;"replace tabs for 8 spaces . set smCh=$extract(smLine,1) . if (smCh'=" ")&(smCh'=";") do . . new label . . set label=$piece(smLine," ",1) . . set label=$piece(label,"(",1) ;"MyFunct(X,Y) --> MyFunct . . set label=$extract(label,1,zbSigNameLen) . . set LabelNum=LabelNum+1 . . set @pArray@(LabelNum,"TAG")=label . . set @pArray@(LabelNum,"OFFSET")=smIdx . . set @pArray@(label)=LabelNum . set smIdx=smIdx+1 SMDone quit BROWSENODES(current,Order,paginate,countNodes) ;"NOTE: Duplicate of function in TMGMISC ;"Purpose: to display nodes of specified array ;"Input: Current -- The reference to display ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. new parent,child set parent="" set order=$get(order,1) set paginate=$get(paginate,0) set countNodes=$get(countNodes,0) new len set len=$length(current) new lastChar set lastChar=$extract(current,len) if lastChar'=")" do . if current'["(" quit . if lastChar="," set current=$extract(current,1,len-1) . if lastChar="(" set current=$extract(current,1,len-1) quit . set current=current_")" BNLoop if current="" goto BNDone set child=$$ShowNodes(current,order,paginate,countNodes) if child'="" do . set parent(child)=current . set current=child else set current=$get(parent(current)) goto BNLoop BNDone quit ShowNodes(pArray,order,paginate,countNodes) ;"NOTE: Duplicate of function in TMGMISC ;"Purpose: To display all the nodes of the given array ;"Input: pArray -- NAME OF array to display ;" order -- OPTIONAL, default=1; 1 for forward, -1 for backwards order ;" paginate -- OPTIONAL, default=0; 0=no pagination, 1=pause after each page ;" countNodes -- OPTIONAL, default=0; 1=show number of child nodes. ;"Results: returns NAME OF next node to display (or "" if none) new TMGi new count set count=1 new Answers new someShown set someShown=0 new abort set abort=0 set paginate=$get(paginate,0) new pageCount set pageCount=0 new pageLen set pageLen=20 set countNodes=$get(countNodes,0) write pArray,! set TMGi=$order(@pArray@(""),order) if TMGi'="" for do quit:(TMGi="")!(abort=1) . write count,". +--[",TMGi,"]" . if countNodes=1 write "(",$$ListCt($name(@pArray@(TMGi))),")" . write "=",$extract($get(@pArray@(TMGi)),1,40),! . set someShown=1 . set Answers(count)=$name(@pArray@(TMGi)) . set count=count+1 . new zbTemp read *zbTemp:0 . if zbTemp'=-1 set abort=1 . set pageCount=pageCount+1 . if (paginate=1)&(pageCount>pageLen) do . . new zbTemp . . read "Press [ENTER] to continue (^ to stop list)...",zbTemp:$get(DTIME,3600),! . . if zbTemp="^" set abort=1 . . set pageCount=0 . set TMGi=$order(@pArray@(TMGi),order) if someShown=0 write " (no data)",! write !,"Enter # to browse (^ to backup): ^//" new zbTemp read zbTemp:$get(DTIME,3600),! new result set result=$get(Answers(zbTemp)) quit result ListCt(pArray) ;"NOTE: Duplicate of function in TMGMISC ;"SCOPE: PUBLIC ;"Purpose: to count the number of entries in an array ;"Input: pointer to (name of) array to test. ;"Output: the number of entries at highest level ;" e.g. Array("TELEPHONE")=1234 ;" Array("CAR")=4764 ;" Array("DOG")=5213 ;" Array("DOG","COLLAR")=5213 <-- not highest level,not counted. ;" The above array would have a count of 3 new i,result set result=0 do . new $etrap . set $etrap="write ""?? Error Trapped ??"",! set $ECODE="""" quit" . set i=$order(@pArray@("")) . if i="" quit . for set result=result+1 set i=$order(@pArray@(i)) quit:i="" quit result TrimL(S,TrimCh) ;"NOTE: Duplicate of function in TMGSTUTL ;"Purpose: To a trip a string of leading white space ;" i.e. convert " hello" into "hello" ;"Input: S -- the string to convert. Won't be changed if passed by reference ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " ;"Results: returns modified string ;"Note: processing limitation is string length=1024 set TrimCh=$get(TrimCh," ") new result set result=$get(S) new Ch set Ch="" for do quit:(Ch'=TrimCh) . set Ch=$extract(result,1,1) . if Ch=TrimCh do . . set result=$extract(result,2,1024) quit result TrimR(S,TrimCh) ;"NOTE: Duplicate of function in TMGSTUTL ;"Purpose: To a trip a string of trailing white space ;" i.e. convert "hello " into "hello" ;"Input: S -- the string to convert. Won't be changed if passed by reference ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " ;"Results: returns modified string ;"Note: processing limitation is string length=1024 set TrimCh=$get(TrimCh," ") new result set result=$get(S) new Ch set Ch="" new L for do quit:(Ch'=TrimCh) . set L=$length(result) . set Ch=$extract(result,L,L) . if Ch=TrimCh do . . set result=$extract(result,1,L-1) quit result Trim(S,TrimCh) ;"NOTE: Duplicate of function in TMGSTUTL ;"Purpose: To a trip a string of leading and trailing white space ;" i.e. convert " hello " into "hello" ;"Input: S -- the string to convert. Won't be changed if passed by reference ;" TrimCh -- OPTIONAL: Charachter to trim. Default is " " ;"Results: returns modified string ;"Note: processing limitation is string length=1024 set TrimCh=$get(TrimCh," ") new result set result=$get(S) set result=$$TrimL(.result,TrimCh) set result=$$TrimR(.result,TrimCh) quit result Substitute(S,Match,NewValue) ;"NOTE: Duplicate of function in TMGSTUTL ;"PUBLIC FUNCTION ;"Purpose: to look for all instances of Match in S, and replace with NewValue ;"Input: S - string to alter. Altered if passed by reference ;" Match -- the sequence to look for, i.e. '##' ;" NewValue -- what to replace Match with, i.e. '$$' ;"Note: This is different than $translate, as follows ;" $translate("ABC###DEF","###","*") --> "ABC***DEF" ;" $$Substitute("ABC###DEF","###","*") --> "ABC*DEF" ;"Result: returns altered string (if any alterations indicated) ;"Output: S is altered, if passed by reference. new spec set spec($get(Match))=$get(NewValue) set S=$$REPLACE(S,.spec) quit S REPLACE(IN,SPEC) ;"See $$REPLACE in MDC minutes. ;"Taken from REPLACE^XLFSTR quit:'$D(IN) "" quit:$D(SPEC)'>9 IN N %1,%2,%3,%4,%5,%6,%7,%8 set %1=$L(IN) set %7=$J("",%1) set %3="" set %6=9999 for set %3=$order(SPEC(%3)) quit:%3="" set %6(%6)=%3,%6=%6-1 for %6=0:0 set %6=$O(%6(%6)) quit:%6'>0 set %3=%6(%6) do:$D(SPEC(%3))#2 RE1 set %8="" for %2=1:1:%1 do RE3 quit %8 RE1 set %4=$L(%3) set %5=0 for S %5=$F(IN,%3,%5) Q:%5<1 D RE2 Q RE2 Q:$E(%7,%5-%4,%5-1)["X" S %8(%5-%4)=SPEC(%3) F %2=%5-%4:1:%5-1 S %7=$E(%7,1,%2-1)_"X"_$E(%7,%2+1,%1) Q RE3 I $E(%7,%2)=" " S %8=%8_$E(IN,%2) Q S:$D(%8(%2)) %8=%8_%8(%2) Q KeyPress(wantChar,waitTime) ;"NOTE: Duplicate of function in TMGUSRIF ;"Purpose: to check for a keypress ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value ;" waitTime -- OPTIONAL, default is 0 (immediate return) ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1) ;"Note: this does NOT wait for user to press key new zbTemp set waitTime=$get(waitTime,0) read *zbTemp:waitTime if $get(wantChar)=1 set zbTemp=$char(zbTemp) quit zbTemp DebugWrite(DBIndent,s,AddNewline) ;"NOTE: Duplicate of function in TMGDEBUG ;"PUBLIC FUNCTION ;"Purpose: to write debug output. Having the proc separate will allow ;" easier dump to file etc. ;"Input:DBIndent, the amount of indentation expected for output. ;" s -- the text to write ;" AddNewline -- boolean, 1 if ! (i.e. newline) should be written after s ;"Relevant DEBUG values ;" cdbNone - no debug (0) ;" cdbToScrn - Debug output to screen (1) ;" cdbToFile - Debug output to file (2) ;" cdbToTail - Debug output to X tail dialog box. (3) ;"Note: If above values are not defined, then functionality will be ignored. set TMGDEBUG=$get(TMGDEBUG,0) if TMGDEBUG=0 quit if (TMGDEBUG=2)!(TMGDEBUG=3),$data(DebugFile) use DebugFile write s if $get(AddNewline)=1 write ! if (TMGDEBUG=2)!(TMGDEBUG=3) use $PRINCIPAL quit DebugIndent(DBIndentForced) ;"NOTE: Duplicate of function in TMGDEBUG ;"PUBLIC FUNCTION ;"Purpose: to provide a unified indentation for debug messages ;"Input: DBIndent = number of indentations ;" Forced = 1 if to indent regardless of DEBUG mode set Forced=$get(Forced,0) if ($get(TMGDEBUG,0)=0)&(Forced=0) quit new i for i=1:1:DBIndent do . if Forced do DebugWrite(DBIndent," ") . else do DebugWrite(DBIndent,". ") quit ArrayDump(ArrayP,TMGIDX,indent) ;"NOTE: Duplicate of function in TMGDEBUG ;"PUBLIC FUNCTION ;"Purpose: to get a custom version of GTM's "zwr" command ;"Input: Uses global scope var DBIndent (if defined) ;" ArrayP: NAME of global to display, i.e. "^VA(200)" ;" TMGIDX: initial index (i.e. 5 if wanting to start with ^VA(200,5) ;" indent: spacing from left margin to begin with. (A number. Each count is 2 spaces) ;" OPTIONAL: indent may be an array, with information about columns ;" to skip. For example: ;" indent=3, indent(2)=0 --> show | for columns 1 & 3, but NOT 2 ;"Result: 0=OK to continue, 1=user aborted display new result set result=0 if $$UserAborted^TMGUSRIF set result=1 goto ADDone new $etrap set $etrap="set result="""",$etrap="""",$ecode=""""" AD1 if $data(ArrayP)=0 goto ADDone new abort set abort=0 if (ArrayP["@") do goto:(abort=1) ADDone . new zbTemp set zbTemp=$piece($extract(ArrayP,2,99),"@",1) . if $data(zbTemp)#10=0 set abort=1 ;"Note: I need to do some validation to ensure ArrayP doesn't have any null nodes. new X set X="SET zbTemp=$GET("_ArrayP_")" set X=$$UP(X) do ^DIM ;"a method to ensure ArrayP doesn't have an invalid reference. if $get(X)="" goto ADDone set DBIndent=$get(DBIndent,0) set cTrue=$get(cTrue,1) set cFalse=$get(cFalse,0) ;"Force this function to output, even if TMGDEBUG is not defined. ;"if $data(TMGDEBUG)=0 new TMGDEBUG ;"//kt 1-16-06, doesn't seem to be working new TMGDEBUG ;"//kt added 1-16-06 set TMGDEBUG=1 new ChildP,TMGi set TMGIDX=$get(TMGIDX,"") set indent=$get(indent,0) new SavIndex set SavIndex=TMGIDX do DebugIndent(DBIndent) if indent>0 do . for TMGi=1:1:indent-1 do . . new s set s="" . . if $get(indent(TMGi),-1)=0 set s=" " . . else set s="| " . . do DebugWrite(DBIndent,s) . do DebugWrite(DBIndent,"}~") if TMGIDX'="" do . if $data(@ArrayP@(TMGIDX))#10=1 do . . new s set s=@ArrayP@(TMGIDX) . . if s="" set s="""""" . . new qt set qt="" . . if +TMGIDX'=TMGIDX set qt="""" . . do DebugWrite(DBIndent,qt_TMGIDX_qt_" = "_s,cTrue) . else do . . do DebugWrite(DBIndent,TMGIDX,1) . set ArrayP=$name(@ArrayP@(TMGIDX)) else do . ;"do DebugWrite(DBIndent,ArrayP_"(*)",cFalse) . do DebugWrite(DBIndent,ArrayP,cFalse) . if $data(@ArrayP)#10=1 do . . do DebugWrite(0,"="_$get(@ArrayP),cFalse) . do DebugWrite(0,"",cTrue) set TMGIDX=$order(@ArrayP@("")) if TMGIDX="" goto ADDone set indent=indent+1 for do quit:TMGIDX="" if result=1 goto ADDone . new tTMGIDX set tTMGIDX=$order(@ArrayP@(TMGIDX)) . if tTMGIDX="" set indent(indent)=0 . new tIndent merge tIndent=indent . set result=$$ArrayDump(ArrayP,TMGIDX,.tIndent) ;"Call self recursively . set TMGIDX=$order(@ArrayP@(TMGIDX)) ;"Put in a blank space at end of subbranch do DebugIndent(DBIndent) if indent>0 do . for TMGi=1:1:indent-1 do . . new s set s="" . . if $get(indent(TMGi),-1)=0 set s=" " . . else set s="| " . . do DebugWrite(DBIndent,s) . do DebugWrite(DBIndent," ",1) ADDone quit result ExpandLine(Pos) ;"NOTE: Duplicate of function in TMGDEBUG ;"Purpose: to expand a line of code, found at position "Pos", using ^XINDX8 functionality ;"Input: Pos: a position as returned by $ZPOS (e.g. G+5^DIS, or +23^DIS) ;"Output: Writes to the currently selecte IO device and expansion of one line of code ;"Note: This is used for taking the very long lines of code, as found in Fileman, and ;" convert them to a format with one command on each line. ;" Note: it appears to do syntax checking and shows ERROR if syntax is not per VA ;" conventions--such as commands must be UPPERCASE etc. ;"--- copied and modified from XINDX8.m --- kill ^UTILITY($J) new label,offset,RTN,dmod do ParsePos(Pos,.label,.offset,.RTN,.dmod) if label'="" do ;"change position from one relative to label into one relative to top of file . new CodeArray . set Pos=$$ConvertPos(Pos,"CodeArray") . do ParsePos(Pos,.label,.offset,.RTN,.dmod) if RTN="" goto ELDone do BUILD^XINDX7 set ^UTILITY($J,RTN)="" do LOAD^XINDEX set CCN=0 do . new I . for I=1:1:+^UTILITY($J,1,RTN,0,0) set CCN=CCN+$L(^UTILITY($J,1,RTN,0,I,0))+2 . set ^UTILITY($J,1,RTN,0)=CCN ;"do ^XINDX8 -- included below new Q,DDOT,LO,PG,LIN,ML,IDT new tIOSL set tIOSL=IOSL set IOSL=999999 ;"really long 'page length' prevents header printout (and error) set Q="""" set DDOT=0 set LO=0 set PG=+$G(PG) set LC=offset if $D(^UTILITY($J,1,RTN,0,LC)) do . set LIN=^(LC,0),ML=0,IDT=10 . set LO=LC-1 . do CD^XINDX8 kill AGR,EOC,IDT,JJ,LO,ML,OLD,SAV,TY set IOSL=tIOSL ;"restore saved IOSL ELDone quit CREF(X) ;"Taken from CREF^DILF --> ENCREF^DIQGU ;"Convert an open reference to a closed reference new L,X1,X2,X3 set X1=$piece(X,"(") set X2=$piece(X,"(",2,99) set L=$length(X2) set X3=$translate($extract(X2,L),",)") set X2=$extract(X2,1,(L-1))_X3 quit X1_$select(X2]"":"("_X2_")",1:"") LGR() ;"Taken from LGR^%ZOSV ;" Last global reference ($REFERENCE) quit $R UP(X) ;"Taken from UP^XLFSTR quit $translate(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") READ() ;"Purpose: To read user input, with knowledge of arrow keys ;" This will use VPE keyboard handling if available, otherwise XGF stuff ;"Result: Will return all user input up to a terminator (RETURN, or a special key) ;" See code in %ZVEMKRN for possible code returns. format ;"9/3/06 -- don't use VPE keyboard anymore quit $$OLDREAD(,604800) ;"set timeout to 1 week (604800 secs). if $text(+0^%ZVEMKRN)="" quit $$OLDREAD() new key,FnKey new done set done=0 new result set result="" for do quit:(done=1) . ;"READ^%ZVEMKRN(PROMPT,LENGTH,NOECHO) ; . ;"PROMPT Display prompt. . ;"LENGTH Maximum # of characters user may enter. . ;"NOECHO 1=Do not echo what user types. . set key=$$READ^%ZVEMKRN("",1,0) . set FnKey=$get(VEE("K")) . if FnKey="" set done=1,FnKey="" quit . if (FnKey="")!(FnKey="") do . . set result=$extract(result,1,$length(result)-1) . . write $char(8)_" "_$char(8) ;"a backspace char . . set FnKey="" set key="" . if FnKey'="" set key=FnKey,done=1 . if key'="" set result=result_key quit result OLDREAD(XGCHARS,XGTO) ;"Taken from READ^XGF ;"read the keyboard ;"XGCHARS:number of chars to read, XGTO:timeout quit $$READ2($G(XGCHARS),$G(XGTO)) READ2(XGCHARS,XGTO) ;"Taken from READ^XGKB ;"Purpose: Read a number of characters, using escape processing. ;"Input: XGCHARS -- number of characters to read ;" XGTO -- timeout (optional). ;"Result -- User input is returned. ;" -- Char that terminated the read will be in tmgXGRT ;" e.g. "UP" ;" "PREV" ;" "DOWN" ;" "NEXT" ;" "RIGHT" ;" "LEFT" N S,XGW1,XGT1,XGSEQ ;string,window,timer,timer sequence K DTOUT S tmgXGRT="" D:$G(XGTO)="" ;set timeout value if one wasn't passed . I $D(XGT) D Q ;if timers are defined . . S XGTO=$O(XGT(0,"")) ;get shortest time left of all timers . . S XGW1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,1) ;get timer's window . . S XGT1=$P(XGT(0,XGTO,$O(XGT(0,XGTO,"")),"ID"),U,3) ;get timer's name . I $D(XGW) S XGTO=99999999 Q ;in emulation read forever . S XGTO=$G(DTIME,600) ; I $G(XGCHARS)>0 R S#XGCHARS:XGTO S:'$T DTOUT=1 I 1 ;fixed length read E R S:XGTO S:'$T DTOUT=1 I 1 ;read as many as possible S:$G(DTOUT)&('$D(XGT1)) S=U ;stuff ^ ; S:$L($ZB) tmgXGRT=$G(^XUTL("XGKB",$ZB)) ;get terminator if any I $G(DTOUT),$D(XGT1),$D(^TMP("XGW",$J,XGW1,"T",XGT1,"EVENT","TIMER")) D I 1 ;if timed out . D E^XGEVNT1(XGW1,"T",XGT1,"","TIMER") E I $L(tmgXGRT),$D(^TMP("XGKEY",$J,tmgXGRT)) X ^(tmgXGRT) ;do some action ; this really should be handled by keyboard mapping -- later Q S