- call_graph.tcl - My attempt at a call graph generator like cflow
#! /home/fincher/bin/tclsh
# Thanks to Andy Moskoff <andy@awds27.wx.gtegsc.com> for his encouragement. Andy
# also has a more cflow-like program that follows the thread of execution from a
# main routine.
if {$argc < 1} {
puts "usage: $argv0 \[-r\] \[-v\] \[-o\] file1 \[file2...\]"
puts " This program creates a call graph somewhat like cflow does for c code."
puts " It is easily confused and very naive. It doesn't grok bind or traces"
puts " The -r option reverses the sense of the calltree graph."
puts " The -v option prints the version."
puts " The -o option prints orphans, procs which are not being called."
puts " (Well, maybe not being called, its easily to fool $argv0)"
puts " Example: $argv0 \*.tcl ../sibling/\*.tcl"
puts " Written by Mitch Fincher, 11/96."
puts " (see http://fincher.org for latest email address and version)"
exit 1
}
set filenum 0
set procs ""
set verbs ""
set procname ""
set max_level 15
set option_location [lsearch $argv "-v"]
if { $option_location >= 0 } {
puts stderr "$argv0: version 0.95, Dec 16 1996. Written by Mitch Fincher."
set argv [lreplace $argv $option_location $option_location]
incr argc -1
}
set r_option 0
set option_location [lsearch $argv "-r"]
if { $option_location >= 0 } {
set r_option 1
set argv [lreplace $argv $option_location $option_location]
incr argc -1
}
set o_option 0
set option_location [lsearch $argv "-o"]
if { $option_location >= 0 } {
set o_option 1
set argv [lreplace $argv $option_location $option_location]
incr argc -1
}
set debug 0
set option_location [lsearch $argv "-d"]
if { $option_location >= 0 } {
set debug 1
set argv [lreplace $argv $option_location $option_location]
incr argc -1
}
proc PrintVerb { procname level } {
global $procname procs location max_level
if { $level > $max_level } {
puts stderr "Perhaps you have recursion in proc \"$procname?\""
puts stderr " I am not smart enough to handle that. Sorry."
return
}
set i 0
while { $i < $level } {puts -nonewline "|--"; incr i}
if { $level == 0 } {
puts "$procname <$location($procname)>"
} else {
puts "$procname "
}
if { [ lsearch $procs $procname ] >= 0} {
foreach p [split [set $procname]] {
if { $p != $procname } {
PrintVerb $p [expr $level + 1]
}
}
}
}
proc AddProc { procname filename linenumber } {
global $procname procs location verbs
if { [ lsearch $procs $procname ] < 0} {
# this is the first instanse of the procname
lappend procs $procname
set location($procname) "$filename $linenumber"
}
if { [ lsearch $verbs $procname ] < 0} {
lappend verbs $procname
}
}
proc AddVerb { procname verb } {
global $procname procs verbs
if { [ lsearch [ set $procname] $verb ] < 0} {
lappend $procname $verb
}
if { [ lsearch $verbs $verb ] < 0} {
lappend verbs $verb
}
}
set common_verbs [ concat after append array bgerror break case catch cd \
clock close concat continue eof else error eval exec exit expr fblocked \
fconfigure file fileevent filename flush for foreach format gets glob \
global history if incr info interp join lappend library lindex linsert \
list llength load lrange lreplace lsearch lsort open package pid \
pkgMkIndex proc puts pwd read regexp regsub rename return scan seek \
set socket source split string subst switch tclvars tell time trace \
unknown unset update uplevel upvar vwait while return bell bind bindtags \
bitmap button canvas checkbutton clipboard destroy dialog entry focus \
focusNext frame grab grid image label listbox lower menu menubar \
menubutton message option optionMenu options pack-old pack palette \
photo place popup radiobutton raise scale scrollbar selection send \
text tk tkerror tkvars tkwait toplevel winfo wm tixButtonBox \
tixLabelEntry tixPanedWindow tixScrolledListBox]
while { $filenum < $argc } {
set filename [lindex $argv $filenum]
puts -nonewline stderr "\nprocessing $filename" ; flush stderr
if { ! [file readable $filename] } {
puts stderr "\n$argv0: Warning, cannot read file \"$filename\""
incr filenum
continue
}
set file [open $filename r]
incr filenum
set linenumber 0
while {[gets $file Line] >= 0} {
incr linenumber
set verb ""
#concatanate continuation lines
while { [regexp {(.*)(\\$)} $Line temp OrigLine] } { gets $file NextLine; set Line $OrigLine$NextLine; incr linenumber}
# get rid of comment lines
if {[ regexp {(^[ \t]*\#)} $Line ]} {
#catch Procedure Line
} elseif {[ regexp {(^[ \t]*)(proc[ ]+)([a-zA-Z0-9_:]+)} $Line temp temp1 temp2 procname ]} {
# create the variable $procname and zero it out
if { $debug } { puts "reading proc $procname" }
set $procname ""
puts -nonewline stderr "."; flush stderr
AddProc $procname $filename $linenumber
} elseif { [ regexp {(-command|-browsecmd|-opencmd)([ ]*["]*)([a-zA-Z0-9_:]+)} $Line temp temp1 temp2 verb ] } {
# "
if { $debug } { puts " -option $verb" }
# catch the first word beyond a \[. We naively assume its a function
} elseif { [ regexp {([\[][ ]*catch[ ]*\{)([a-zA-Z0-9_:]+)} $Line temp temp1 verb ] } {
if { $debug } { puts " catching $verb" }
} elseif { [ regexp {([\[][ ]*)([a-zA-Z0-9_:]+)} $Line temp temp1 verb ] } {
# catch the first word beyond a \{. We naively assume its a function
} elseif { [ regexp {([\{][ ]*)([a-zA-Z0-9_:]+)} $Line temp temp1 verb ] } {
if { [ regexp {^\\n} $temp] } {
set verb ""
}
# catch the first word on a line We naively assume its a function
} elseif { [ regexp {(^[ ]*)([a-zA-Z0-9_:]+)} $Line temp temp1 verb ] } {
}
# remove common functions, (eg foreach)
if { $verb != "" } {
if { [ lsearch $common_verbs $verb ] >= 0 } {
set verb ""
}
}
#add the new verb to the array of verbs
if { $verb != "" } {
AddVerb $procname $verb
}
}
close $file
}
puts stderr "\ndone."
# normal graph
if { ! $r_option && ! $o_option } {
puts stderr "writing flow diagram."
foreach p [ lsort [split $procs]] {
PrintVerb $p 0
}
}
# write reverse graph
if { $r_option } {
puts stderr "writing reverse flow diagram."
set verbs [lsort [split $verbs]]
foreach verb $verbs {
puts "$verb"
foreach p $procs {
if { [ lsearch [set $p] $verb ]>= 0 } {
puts " $p"
}
}
}
}
# write orphan list
if { $o_option } {
puts stderr "writing orphan list."
set verbs [lsort [split $verbs]]
foreach verb $verbs {
set hits 0
foreach p $procs {
if { [ lsearch [set $p] $verb ]>= 0 } {
incr hits
}
}
if { $hits == 0 } { puts " $verb" }
}
}
puts stderr "\n$argv0 complete."