| 1 | TMGCODT1 ;TMG/kst/A Code Analysis Tools ;08/17/08
|
|---|
| 2 | ;;1.0;TMG-LIB;**1**;08/17/08
|
|---|
| 3 |
|
|---|
| 4 | ScanAll
|
|---|
| 5 | new pArray
|
|---|
| 6 | set pArray=$name(^TMG("MODULE CALLS"))
|
|---|
| 7 |
|
|---|
| 8 | new Itr,index
|
|---|
| 9 | new abort set abort=0
|
|---|
| 10 | set index=$$ItrAInit^TMGITR($name(^DIC(9.8,"B")),.Itr)
|
|---|
| 11 | do PrepProgress^TMGITR(.Itr,20,1,"index")
|
|---|
| 12 | set index="TMGKIDS" ;"temp!
|
|---|
| 13 | if index'="" for do quit:($$ItrANext^TMGITR(.Itr,.index)="")!abort
|
|---|
| 14 | . if $$UserAborted^TMGUSRIF set abort=1 quit
|
|---|
| 15 | . ;"write index,!
|
|---|
| 16 | . do GetCalls(index,pArray)
|
|---|
| 17 | do ProgressDone^TMGITR(.Itr)
|
|---|
| 18 |
|
|---|
| 19 | quit
|
|---|
| 20 |
|
|---|
| 21 | GetCalls(Module,pArray)
|
|---|
| 22 | ;"Purpose: To scan one code module and look for *static* calls to other
|
|---|
| 23 | ;" modules. It will NOT detect indirection (i.e. do @X).
|
|---|
| 24 | ;" Call MUST have a tag. MyTag^MyMod is detected, but ^MyMod is NOT
|
|---|
| 25 | ;"Input: Module -- the name of the module to scan, as would be used
|
|---|
| 26 | ;" in $text(). I.e. XUP, but not ^XUP, not XUP.m
|
|---|
| 27 | ;" Array -- PASS BY NAME, an OUT PARAMETER. Format below.
|
|---|
| 28 | ;"Output: Array filled as follows:
|
|---|
| 29 | ;" Array(Module,Addr)=OutSideAddr (Example of Addr=A+5^MYFUNCT)
|
|---|
| 30 |
|
|---|
| 31 | new curModule set curModule=$get(Module)
|
|---|
| 32 | new blankLines set blankLines=0
|
|---|
| 33 | new offset set offset=1
|
|---|
| 34 | new curLabel set curLabel=""
|
|---|
| 35 |
|
|---|
| 36 | for do quit:(blankLines>30)
|
|---|
| 37 | . new Addr set Addr=curLabel_"+"_offset_"^"_curModule
|
|---|
| 38 | . new oneLine set oneLine=$text(@Addr)
|
|---|
| 39 | . new firstChar set firstChar=$extract(oneLine,1,1)
|
|---|
| 40 | . set offset=offset+1
|
|---|
| 41 | . if oneLine="" set blankLines=blankLines+1 quit
|
|---|
| 42 | . set oneLine=$$CutComment(oneLine)
|
|---|
| 43 | . new tempLabel set tempLabel=$$GetLabel(oneLine)
|
|---|
| 44 | . if tempLabel'="" set curLabel=tempLabel,offset=1
|
|---|
| 45 | . new tempS set tempS=oneLine
|
|---|
| 46 | . if tempS'["^" quit
|
|---|
| 47 | . new done set done=0
|
|---|
| 48 | . for quit:(tempS'["^")!(done=1) do
|
|---|
| 49 | . . if $$InQt^TMGSTUTL(tempS,$find(tempS,"^")-1)=1 set done=1 quit
|
|---|
| 50 | . . new preS,postS
|
|---|
| 51 | . . do GetPrePost(.tempS,.preS,.postS)
|
|---|
| 52 | . . if (preS="")!(postS="") quit
|
|---|
| 53 | . . ;"write curLabel,"+",offset,"--> "
|
|---|
| 54 | . . ;"write preS,"^",postS," [",$$Trim^TMGSTUTL(oneLine),"]",!
|
|---|
| 55 | . . ;"if preS["$" quit
|
|---|
| 56 | . . new tempAddr set tempAddr=preS_"^"_postS
|
|---|
| 57 | . . ;"write "==> ",$text(@tempAddr),!
|
|---|
| 58 | . . ;"set @pArray@("CALLS OUT",curModule,curLabel,offset,tempAddr)=""
|
|---|
| 59 | . . set @pArray@("CALLS IN",postS_"::"_preS,curModule,curLabel,offset)=""
|
|---|
| 60 |
|
|---|
| 61 | quit
|
|---|
| 62 |
|
|---|
| 63 |
|
|---|
| 64 | CutComment(oneLine)
|
|---|
| 65 | ;"Purpose: to cut off any comments from line, indicated by ;
|
|---|
| 66 | ;"Input: oneLine : string to alter
|
|---|
| 67 | ;"Result: modified inputline
|
|---|
| 68 |
|
|---|
| 69 | new i,L,result
|
|---|
| 70 | set result=$get(oneLine)
|
|---|
| 71 | if result'[";" goto CCmDone
|
|---|
| 72 |
|
|---|
| 73 | new inStr,done,ch
|
|---|
| 74 | set inStr=0,done=0
|
|---|
| 75 | set L=$length(oneLine)
|
|---|
| 76 | for i=1:1:L do quit:done
|
|---|
| 77 | . set ch=$extract(oneLine,i)
|
|---|
| 78 | . if ch="""" do
|
|---|
| 79 | . . if inStr=0 set inStr=1 quit
|
|---|
| 80 | . . if $extract(oneLine,i+1)="""" set i=i+1 quit
|
|---|
| 81 | . . set inStr=0
|
|---|
| 82 | . if (ch=";")&(inStr=0) do quit
|
|---|
| 83 | . . set result=$extract(oneLine,1,i-1)
|
|---|
| 84 | . . set done=1
|
|---|
| 85 |
|
|---|
| 86 | CCmDone quit result
|
|---|
| 87 |
|
|---|
| 88 |
|
|---|
| 89 | GetLabel(oneLine)
|
|---|
| 90 | ;"Purpose: Get label for a line, if one exists
|
|---|
| 91 | ;"Input: oneLine : string to scan
|
|---|
| 92 | ;"Result: Label, or "" if none
|
|---|
| 93 |
|
|---|
| 94 | new result set result=$get(oneLine) ;"default to entire line is label
|
|---|
| 95 | new ch set ch=$extract(oneLine,1)
|
|---|
| 96 | if (ch=" ")!(ch=$char(9)) do goto GLDone
|
|---|
| 97 | . set result=""
|
|---|
| 98 |
|
|---|
| 99 | new i,done set done=0
|
|---|
| 100 | for i=1:1:$length(oneLine) do quit:done
|
|---|
| 101 | . set ch=$extract(oneLine,i)
|
|---|
| 102 | . if (ch=" ")!(ch=$char(9))!(ch="(")!(ch=";") do quit
|
|---|
| 103 | . . set result=$extract(oneLine,1,i-1)
|
|---|
| 104 | . . set done=1
|
|---|
| 105 |
|
|---|
| 106 | GLDone quit result
|
|---|
| 107 |
|
|---|
| 108 |
|
|---|
| 109 | GetPrePost(oneLine,preS,postS)
|
|---|
| 110 | ;"Purpose: To take a string like 'write $$MyFunct^MyModule(123)' and return
|
|---|
| 111 | ;" '$$MyFunct' in preS, and 'MyModule' in postS. Also shorten
|
|---|
| 112 | ;" input string, oneLine, so that other calls on the same line
|
|---|
| 113 | ;" can be processed on a separate run.
|
|---|
| 114 | ;"Input: oneLine -- the string to process. PASS BY REFERENCE to get back
|
|---|
| 115 | ;" shortened line with first instance cut off.
|
|---|
| 116 | ;" preS -- PASS BY REFERENCE, an OUT PARAMETER
|
|---|
| 117 | ;" postS -- PASS BY REFERENCE, an OUT PARAMETER
|
|---|
| 118 | ;"Output: See purpose above
|
|---|
| 119 | ;"Result: none
|
|---|
| 120 |
|
|---|
| 121 | new done,p
|
|---|
| 122 |
|
|---|
| 123 | ;"Work first on preS
|
|---|
| 124 | set preS=$piece(oneLine,"^",1)
|
|---|
| 125 | set p=$length(preS)
|
|---|
| 126 | set done=0
|
|---|
| 127 | if p>0 for do quit:(p=0)!(done=1)
|
|---|
| 128 | . new ch set ch=$extract(preS,p)
|
|---|
| 129 | . set p=p-1
|
|---|
| 130 | . if ch?1(1A,1N) quit
|
|---|
| 131 | . set p=p+2,done=1
|
|---|
| 132 | set preS=$extract(preS,p,999)
|
|---|
| 133 |
|
|---|
| 134 | ;"weed out entries like '_^DIC' or '_U_^TMP'
|
|---|
| 135 | ;"if ($extract(preS,1)="_")!($extract(preS,$length(preS))="_" set preS=""
|
|---|
| 136 |
|
|---|
| 137 |
|
|---|
| 138 | ;"Now work on postS
|
|---|
| 139 | set postS=$piece(oneLine,"^",2,$length(oneLine,"^"))
|
|---|
| 140 | set p=1,done=0
|
|---|
| 141 | for do quit:(p>$length(postS))!(done=1)
|
|---|
| 142 | . new ch set ch=$extract(postS,p)
|
|---|
| 143 | . set p=p+1
|
|---|
| 144 | . if ch?1(1A,1N,1"_") quit
|
|---|
| 145 | . set p=p-2,done=1
|
|---|
| 146 |
|
|---|
| 147 | set oneLine=$extract(postS,p+1,999)
|
|---|
| 148 | set postS=$extract(postS,1,p)
|
|---|
| 149 |
|
|---|
| 150 | quit
|
|---|
| 151 |
|
|---|
| 152 | ;"=======================================================
|
|---|
| 153 | test
|
|---|
| 154 | new array
|
|---|
| 155 | new DIC,X,Y
|
|---|
| 156 | set DIC=9.8
|
|---|
| 157 | set DIC(0)="MAEQ"
|
|---|
| 158 | t1
|
|---|
| 159 | do ^DIC write !
|
|---|
| 160 | if +Y'>0 goto testDone
|
|---|
| 161 | ;"kill array
|
|---|
| 162 | do GetCallsOut($piece(Y,"^",2),"array")
|
|---|
| 163 | if $data(array) zwr array
|
|---|
| 164 | goto t1
|
|---|
| 165 |
|
|---|
| 166 | testDone
|
|---|
| 167 | quit
|
|---|
| 168 |
|
|---|
