Tcl/Tk

  1. call_graph.tcl - My attempt at a call graph generator like cflow
    #! /home/fincher/bin/tclsh
    # Thanks to Andy Moskoff <[email protected]> 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."