Adding upstream version 1.37.0.
Signed-off-by: Daniel Baumann <daniel@debian.org>
This commit is contained in:
parent
42613ad5c6
commit
271b368104
GPG key ID:
FBB4F0E80A80222F
1329 changed files with 4727104 additions and 0 deletions
253
testdata/tcl/malloctraceviewer.tcl
vendored
Normal file
253
testdata/tcl/malloctraceviewer.tcl
vendored
Normal file
|
|
@ -0,0 +1,253 @@
|
|||
|
||||
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 ""} {
|
||||
regexp {^([^:]*):([0-9]*)} $line -> file 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}]
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue