#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# Functions to ignore in the stack testing cause they are not relevant to cisco
# =============================================================================
package require struct
package require report
set in [lindex $argv 0]
set if [open $in r]
set cut [lindex $argv 1]
array set sz {}
array set fn {}
array set fi {}
array set cc {}
if {1} {
set ign {
dissect exec condissect lacon miss freenfa
DoRenameFile CopyFile CopyFileAtts DoCopyFile
TestfilehandlerCmd TclpGetCwd TclpMatchFilesTypes
TclFileAttrsCmd CheckAccess TclDoGlob
Tcl_GetChannelNamesEx StoreStatData
TclpListVolumes Tcl_FileObjCmd compile
TestparsevarnameObjCmd TestsaveresultCmd
TestexprparserObjCmd CopyRenameOneFile
TestparserObjCmd Tcl_GetHostName Tcl_EvalFile
TclpCreateProcess TcpGetOptionProc
TclpCreatePipe cleanst rfree freev
AliasCreate FileCopyRename TraverseUnixTree
SlaveHidden SlaveInvokeHidden TraversalCopy
TraversalDelete AliasDelete AliasList
SlaveExpose SlaveHide SlaveEval TclFileMakeDirs
}
} else {
set ign {}
}
foreach i $ign {set ig($i) .}
while {![eof $if]} {
gets $if line
if {[eof $if]} {break}
foreach {dummy fun file line dummy usage dummy caller} [split $line] break
set fi($fun) [file tail $file]
if {[info exists ig($fun)]} {continue}
if {$cut != {}} {
if {$usage < $cut} {
continue
}
}
set kf $fun
set ks $usage
set kcc $fun,$usage
set df $usage
set ds [list $fun $caller]
set dcc $caller
if {![info exists fn($kf)]} {
set fn($kf) [list $df]
} elseif {[lsearch -exact $fn($kf) $df] < 0} {
lappend fn($kf) $df
}
if {![info exists sz($ks)]} {
set sz($ks) [list $ds]
} elseif {[lsearch -exact $sz($ks) $ds] < 0} {
lappend sz($ks) $ds
}
if {![info exists cc($kcc)]} {
set cc($kcc) [list $dcc]
} elseif {[lsearch -exact $cc($kcc) $dcc] < 0} {
lappend cc($kcc) $dcc
}
}
::report::defstyle html {} {
set c [columns]
set cl $c ; incr cl -1
data set " [split [string repeat " " $cl] ""]
"
for {set col 0} {$col < $c} {incr col} {
pad $col left ""
pad $col right " | "
}
return
}
puts stdout "Stack report"
#####################################
if {0} {
struct::matrix m
m add columns 2
foreach s [lsort -integer -decr [array names sz]] {
set funs [list]
foreach f [lsort $sz($s)] {
foreach {f c} $f break
if {![info exists fi($c)]} {
lappend funs "$f ($fi($f)) -- $c"
} else {
lappend funs "$f ($fi($f)) -- $c ($fi($c))"
}
}
m add row [list $s [join $funs ",
"]]
}
report::report r [m columns] style html
puts stdout "
Stack usage of functions I
"
puts stdout ""
r printmatrix2channel m stdout
puts stdout "
"
r destroy
m destroy
#####################################
#puts stdout ""
#exit
}
if {$ign != {}} {
puts stdout "
Functions excluded from the report
"
puts stdout ""
set n 0
foreach f [lsort $ign] {
if {[info exists fi($f)]} {
set f "$f ($fi($f))"
}
if {$n == 0} {
puts -nonewline stdout ""
}
puts -nonewline "| $f | "
incr n
if {$n == 5} {
puts stdout "
"
set n 0
}
}
if {$n != 0} {
puts stdout ""
}
puts stdout "
"
}
struct::matrix m
m add columns 5
foreach fun [array names fn] {
set ssz [lsort -integer -decr $fn($fun)]
set min [lindex $ssz end]
set max [lindex $ssz 0]
set avg [format %.2f [expr ([join $ssz +])/double([llength $ssz])]]
set sszl [list]
foreach z $ssz {
lappend sszl "$z -- $cc($fun,$z)"
}
if {[info exists fi($fun)]} {
set fun "$fun ($fi($fun))"
}
m add row [list $fun $min $max $avg [join $sszl ",
"]]
}
m set rect 0 0 [lsort -integer -decr -index 2 [m get rect 0 0 end end]]
report::report r [m columns] style html
puts stdout "
Stack usage of functions II
"
puts stdout ""
r printmatrix2channel m stdout
puts stdout "
"
r destroy
m destroy
puts stdout "