253c6ee1bf
generates self-contained Tcl scripts that present GUIs instead of *.sql files that require a separate program to interpret. FossilOrigin-Name: de2e3cbd08c00d235106c040fa472ec267ef8f1ec13c34ed7d16deac8d50b6cc
254 lines
6.9 KiB
Tcl
254 lines
6.9 KiB
Tcl
|
|
package require sqlite3
|
|
package require Tk
|
|
|
|
#############################################################################
|
|
# Code to set up scrollbars for widgets. This is generic, boring stuff.
|
|
#
|
|
namespace eval autoscroll {
|
|
proc scrollable {widget path args} {
|
|
::ttk::frame $path
|
|
set w [$widget ${path}.widget {*}$args]
|
|
set vs [::ttk::scrollbar ${path}.vs]
|
|
set hs [::ttk::scrollbar ${path}.hs -orient horizontal]
|
|
grid $w -row 0 -column 0 -sticky nsew
|
|
|
|
grid rowconfigure $path 0 -weight 1
|
|
grid columnconfigure $path 0 -weight 1
|
|
|
|
set grid [list grid $vs -row 0 -column 1 -sticky nsew]
|
|
$w configure -yscrollcommand [list ::autoscroll::scrollcommand $grid $vs]
|
|
$vs configure -command [list $w yview]
|
|
set grid [list grid $hs -row 1 -column 0 -sticky nsew]
|
|
$w configure -xscrollcommand [list ::autoscroll::scrollcommand $grid $hs]
|
|
$hs configure -command [list $w xview]
|
|
|
|
return $w
|
|
}
|
|
proc scrollcommand {grid sb args} {
|
|
$sb set {*}$args
|
|
set isRequired [expr {[lindex $args 0] != 0.0 || [lindex $args 1] != 1.0}]
|
|
if {$isRequired && ![winfo ismapped $sb]} {
|
|
{*}$grid
|
|
}
|
|
if {!$isRequired && [winfo ismapped $sb]} {
|
|
grid forget $sb
|
|
}
|
|
}
|
|
namespace export scrollable
|
|
}
|
|
namespace import ::autoscroll::*
|
|
#############################################################################
|
|
|
|
proc populate_text_widget {db} {
|
|
$::O(text) configure -state normal
|
|
set id [lindex [$::O(tree) selection] 0]
|
|
set frame [lindex $id end]
|
|
|
|
set line [$db one {SELECT line FROM frame WHERE frame = $frame}]
|
|
if {$line ne ""} {
|
|
foreach {file line} [split $line :] {}
|
|
set content [$db one "SELECT content FROM file WHERE name = '$file'"]
|
|
$::O(text) delete 0.0 end
|
|
|
|
set iLine 1
|
|
foreach L [split $content "\n"] {
|
|
if {$iLine == $line} {
|
|
$::O(text) insert end "$L\n" highlight
|
|
} else {
|
|
$::O(text) insert end "$L\n"
|
|
}
|
|
incr iLine
|
|
}
|
|
$::O(text) yview -pickplace ${line}.0
|
|
}
|
|
$::O(text) configure -state disabled
|
|
}
|
|
|
|
proc populate_index {db} {
|
|
$::O(text) configure -state normal
|
|
|
|
$::O(text) delete 0.0 end
|
|
$::O(text) insert end "\n\n"
|
|
|
|
set L [format " % -40s%12s%12s\n" "Test Case" "Allocations" "Bytes"]
|
|
$::O(text) insert end $L
|
|
$::O(text) insert end " [string repeat - 64]\n"
|
|
|
|
$db eval {
|
|
SELECT 'TOTAL' AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes
|
|
FROM malloc
|
|
UNION ALL
|
|
SELECT ztest AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes
|
|
FROM malloc
|
|
GROUP BY ztest
|
|
|
|
ORDER BY 3 DESC
|
|
} {
|
|
set tags [list $ztest]
|
|
if {$ztest eq $::O(current)} {
|
|
lappend tags highlight
|
|
}
|
|
set L [format " % -40s%12s%12s\n" $ztest $calls $bytes]
|
|
$::O(text) insert end $L $tags
|
|
|
|
$::O(text) tag bind $ztest <1> [list populate_tree_widget $db $ztest]
|
|
$::O(text) tag bind $ztest <Enter> [list $::O(text) configure -cursor hand2]
|
|
$::O(text) tag bind $ztest <Leave> [list $::O(text) configure -cursor ""]
|
|
}
|
|
|
|
$::O(text) configure -state disabled
|
|
}
|
|
|
|
proc sort_tree_compare {iLeft iRight} {
|
|
global O
|
|
switch -- [expr (int($O(tree_sort)/2))] {
|
|
0 {
|
|
set left [$O(tree) item $iLeft -text]
|
|
set right [$O(tree) item $iRight -text]
|
|
set res [string compare $left $right]
|
|
}
|
|
1 {
|
|
set left [lindex [$O(tree) item $iLeft -values] 0]
|
|
set right [lindex [$O(tree) item $iRight -values] 0]
|
|
set res [expr $left - $right]
|
|
}
|
|
2 {
|
|
set left [lindex [$O(tree) item $iLeft -values] 1]
|
|
set right [lindex [$O(tree) item $iRight -values] 1]
|
|
set res [expr $left - $right]
|
|
}
|
|
}
|
|
if {$O(tree_sort)&0x01} {
|
|
set res [expr -1 * $res]
|
|
}
|
|
return $res
|
|
}
|
|
|
|
proc sort_tree {iMode} {
|
|
global O
|
|
if {$O(tree_sort) == $iMode} {
|
|
incr O(tree_sort)
|
|
} else {
|
|
set O(tree_sort) $iMode
|
|
}
|
|
set T $O(tree)
|
|
set items [$T children {}]
|
|
set items [lsort -command sort_tree_compare $items]
|
|
for {set ii 0} {$ii < [llength $items]} {incr ii} {
|
|
$T move [lindex $items $ii] {} $ii
|
|
}
|
|
}
|
|
|
|
proc trim_frames {stack} {
|
|
while {[info exists ::O(ignore.[lindex $stack 0])]} {
|
|
set stack [lrange $stack 1 end]
|
|
}
|
|
return $stack
|
|
}
|
|
|
|
proc populate_tree_widget {db zTest} {
|
|
$::O(tree) delete [$::O(tree) children {}]
|
|
|
|
for {set ii 0} {$ii < 15} {incr ii} {
|
|
$db eval {
|
|
SELECT
|
|
sum(ncall) AS calls,
|
|
sum(nbyte) AS bytes,
|
|
trim_frames(lrange(lstack, 0, $ii)) AS stack
|
|
FROM malloc
|
|
WHERE (zTest = $zTest OR $zTest = 'TOTAL') AND llength(lstack)>$ii
|
|
GROUP BY stack
|
|
HAVING stack != ''
|
|
} {
|
|
set parent_id [lrange $stack 0 end-1]
|
|
set frame [lindex $stack end]
|
|
set line [$db one {SELECT line FROM frame WHERE frame = $frame}]
|
|
set line [lindex [split $line /] end]
|
|
set v [list $calls $bytes]
|
|
|
|
catch {
|
|
$::O(tree) insert $parent_id end -id $stack -text $line -values $v
|
|
}
|
|
}
|
|
}
|
|
|
|
set ::O(current) $zTest
|
|
populate_index $db
|
|
}
|
|
|
|
|
|
|
|
set O(tree_sort) 0
|
|
|
|
::ttk::panedwindow .pan -orient horizontal
|
|
set O(tree) [scrollable ::ttk::treeview .pan.tree]
|
|
|
|
frame .pan.right
|
|
set O(text) [scrollable text .pan.right.text]
|
|
button .pan.right.index -command {populate_index mddb} -text "Show Index"
|
|
pack .pan.right.index -side top -fill x
|
|
pack .pan.right.text -fill both -expand true
|
|
|
|
$O(text) tag configure highlight -background wheat
|
|
$O(text) configure -wrap none -height 35
|
|
|
|
.pan add .pan.tree
|
|
.pan add .pan.right
|
|
|
|
$O(tree) configure -columns {calls bytes}
|
|
$O(tree) heading #0 -text Line -anchor w -command {sort_tree 0}
|
|
$O(tree) heading calls -text Calls -anchor w -command {sort_tree 2}
|
|
$O(tree) heading bytes -text Bytes -anchor w -command {sort_tree 4}
|
|
$O(tree) column #0 -width 150
|
|
$O(tree) column calls -width 100
|
|
$O(tree) column bytes -width 100
|
|
|
|
pack .pan -fill both -expand 1
|
|
|
|
#--------------------------------------------------------------------
|
|
# Open the database containing the malloc data. The user specifies the
|
|
# database to use by passing the file-name on the command line.
|
|
#
|
|
proc open_database {} {
|
|
if {[info exists ::BUILTIN]} {
|
|
sqlite3 mddb :memory:
|
|
mddb eval $::BUILTIN
|
|
wm title . $::argv0
|
|
} else {
|
|
set zFilename [lindex $::argv 0]
|
|
if {$zFilename eq ""} {
|
|
set zFilename mallocs.sql
|
|
}
|
|
set fd [open $zFilename]
|
|
set zHdr [read $fd 15]
|
|
if {$zHdr eq "SQLite format 3"} {
|
|
close $fd
|
|
sqlite3 mddb $zFilename
|
|
} else {
|
|
seek $fd 0
|
|
sqlite3 mddb :memory:
|
|
mddb eval [read $fd]
|
|
close $fd
|
|
}
|
|
wm title . $zFilename
|
|
}
|
|
|
|
mddb function lrange -argcount 3 lrange
|
|
mddb function llength -argcount 1 llength
|
|
mddb function trim_frames -argcount 1 trim_frames
|
|
|
|
mddb eval {
|
|
SELECT frame FROM frame
|
|
WHERE line LIKE '%malloc.c:%' OR line LIKE '%mem2.c:%'
|
|
} {
|
|
set ::O(ignore.$frame) 1
|
|
}
|
|
}
|
|
|
|
open_database
|
|
bind $O(tree) <<TreeviewSelect>> [list populate_text_widget mddb]
|
|
|
|
populate_tree_widget mddb [mddb one {SELECT zTest FROM malloc LIMIT 1}]
|
|
|