1
2package require sqlite3
3package require Tk
4
5#############################################################################
6# Code to set up scrollbars for widgets. This is generic, boring stuff.
7#
8namespace eval autoscroll {
9  proc scrollable {widget path args} {
10    ::ttk::frame $path
11    set w  [$widget ${path}.widget {*}$args]
12    set vs [::ttk::scrollbar ${path}.vs]
13    set hs [::ttk::scrollbar ${path}.hs -orient horizontal]
14    grid $w  -row 0 -column 0 -sticky nsew
15
16    grid rowconfigure    $path 0 -weight 1
17    grid columnconfigure $path 0 -weight 1
18
19    set grid [list grid $vs -row 0 -column 1 -sticky nsew]
20    $w configure -yscrollcommand [list ::autoscroll::scrollcommand $grid $vs]
21    $vs configure -command       [list $w yview]
22    set grid [list grid $hs -row 1 -column 0 -sticky nsew]
23    $w configure -xscrollcommand [list ::autoscroll::scrollcommand $grid $hs]
24    $hs configure -command       [list $w xview]
25
26    return $w
27  }
28  proc scrollcommand {grid sb args} {
29    $sb set {*}$args
30    set isRequired [expr {[lindex $args 0] != 0.0 || [lindex $args 1] != 1.0}]
31    if {$isRequired && ![winfo ismapped $sb]} {
32      {*}$grid
33    }
34    if {!$isRequired && [winfo ismapped $sb]} {
35      grid forget $sb
36    }
37  }
38  namespace export scrollable
39}
40namespace import ::autoscroll::*
41#############################################################################
42
43proc populate_text_widget {db} {
44  $::O(text) configure -state normal
45  set id [lindex [$::O(tree) selection] 0]
46  set frame [lindex $id end]
47
48  set line [$db one {SELECT line FROM frame WHERE frame = $frame}]
49  if {$line ne ""} {
50    regexp {^([^:]*):([0-9]*)} $line -> file line
51    set content [$db one "SELECT content FROM file WHERE name = '$file'"]
52    $::O(text) delete 0.0 end
53
54    set iLine 1
55    foreach L [split $content "\n"] {
56      if {$iLine == $line} {
57        $::O(text) insert end "$L\n" highlight
58      } else {
59        $::O(text) insert end "$L\n"
60      }
61      incr iLine
62    }
63    $::O(text) yview -pickplace ${line}.0
64  }
65  $::O(text) configure -state disabled
66}
67
68proc populate_index {db} {
69  $::O(text) configure -state normal
70
71  $::O(text) delete 0.0 end
72  $::O(text) insert end "\n\n"
73
74  set L [format "    % -40s%12s%12s\n" "Test Case" "Allocations" "Bytes"]
75  $::O(text) insert end $L
76  $::O(text) insert end "    [string repeat - 64]\n"
77
78  $db eval {
79    SELECT 'TOTAL' AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes
80    FROM malloc
81      UNION ALL
82    SELECT ztest AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes
83    FROM malloc
84    GROUP BY ztest
85
86    ORDER BY 3 DESC
87  } {
88    set tags [list $ztest]
89    if {$ztest eq $::O(current)} {
90      lappend tags highlight
91    }
92    set L [format "    % -40s%12s%12s\n" $ztest $calls $bytes]
93    $::O(text) insert end $L $tags
94
95    $::O(text) tag bind $ztest <1> [list populate_tree_widget $db $ztest]
96    $::O(text) tag bind $ztest <Enter> [list $::O(text) configure -cursor hand2]
97    $::O(text) tag bind $ztest <Leave> [list $::O(text) configure -cursor ""]
98  }
99
100  $::O(text) configure -state disabled
101}
102
103proc sort_tree_compare {iLeft iRight} {
104  global O
105  switch -- [expr (int($O(tree_sort)/2))] {
106    0 {
107      set left  [$O(tree) item $iLeft -text]
108      set right [$O(tree) item $iRight -text]
109      set res [string compare $left $right]
110    }
111    1 {
112      set left  [lindex [$O(tree) item $iLeft -values] 0]
113      set right [lindex [$O(tree) item $iRight -values] 0]
114      set res [expr $left - $right]
115    }
116    2 {
117      set left  [lindex [$O(tree) item $iLeft -values] 1]
118      set right [lindex [$O(tree) item $iRight -values] 1]
119      set res [expr $left - $right]
120    }
121  }
122  if {$O(tree_sort)&0x01} {
123    set res [expr -1 * $res]
124  }
125  return $res
126}
127
128proc sort_tree {iMode} {
129  global O
130  if {$O(tree_sort) == $iMode} {
131    incr O(tree_sort)
132  } else {
133    set O(tree_sort) $iMode
134  }
135  set T $O(tree)
136  set items [$T children {}]
137  set items [lsort -command sort_tree_compare $items]
138  for {set ii 0} {$ii < [llength $items]} {incr ii} {
139    $T move [lindex $items $ii] {} $ii
140  }
141}
142
143proc trim_frames {stack} {
144  while {[info exists ::O(ignore.[lindex $stack 0])]} {
145    set stack [lrange $stack 1 end]
146  }
147  return $stack
148}
149
150proc populate_tree_widget {db zTest} {
151  $::O(tree) delete [$::O(tree) children {}]
152
153  for {set ii 0} {$ii < 15} {incr ii} {
154    $db eval {
155      SELECT
156        sum(ncall) AS calls,
157        sum(nbyte) AS bytes,
158        trim_frames(lrange(lstack, 0, $ii)) AS stack
159      FROM malloc
160      WHERE (zTest = $zTest OR $zTest = 'TOTAL') AND llength(lstack)>$ii
161      GROUP BY stack
162      HAVING stack != ''
163    } {
164      set parent_id [lrange $stack 0 end-1]
165      set frame [lindex $stack end]
166      set line [$db one {SELECT line FROM frame WHERE frame = $frame}]
167      set line [lindex [split $line /] end]
168      set v [list $calls $bytes]
169
170      catch {
171        $::O(tree) insert $parent_id end -id $stack -text $line -values $v
172      }
173    }
174  }
175
176  set ::O(current) $zTest
177  populate_index $db
178}
179
180
181
182set O(tree_sort) 0
183
184::ttk::panedwindow .pan -orient horizontal
185set O(tree) [scrollable ::ttk::treeview .pan.tree]
186
187frame .pan.right
188set O(text) [scrollable text .pan.right.text]
189button .pan.right.index -command {populate_index mddb} -text "Show Index"
190pack .pan.right.index -side top -fill x
191pack .pan.right.text -fill both -expand true
192
193$O(text) tag configure highlight -background wheat
194$O(text) configure -wrap none -height 35
195
196.pan add .pan.tree
197.pan add .pan.right
198
199$O(tree) configure     -columns {calls bytes}
200$O(tree) heading #0    -text Line  -anchor w -command {sort_tree 0}
201$O(tree) heading calls -text Calls -anchor w -command {sort_tree 2}
202$O(tree) heading bytes -text Bytes -anchor w -command {sort_tree 4}
203$O(tree) column #0    -width 150
204$O(tree) column calls -width 100
205$O(tree) column bytes -width 100
206
207pack .pan -fill both -expand 1
208
209#--------------------------------------------------------------------
210# Open the database containing the malloc data. The user specifies the
211# database to use by passing the file-name on the command line.
212#
213proc open_database {} {
214  if {[info exists ::BUILTIN]} {
215    sqlite3 mddb :memory:
216    mddb eval $::BUILTIN
217    wm title . $::argv0
218  } else {
219    set zFilename [lindex $::argv 0]
220    if {$zFilename eq ""} {
221      set zFilename mallocs.sql
222    }
223    set fd [open $zFilename]
224    set zHdr [read $fd 15]
225    if {$zHdr eq "SQLite format 3"} {
226      close $fd
227      sqlite3 mddb $zFilename
228    } else {
229      seek $fd 0
230      sqlite3 mddb :memory:
231      mddb eval [read $fd]
232      close $fd
233    }
234    wm title . $zFilename
235  }
236
237  mddb function lrange -argcount 3 lrange
238  mddb function llength -argcount 1 llength
239  mddb function trim_frames -argcount 1 trim_frames
240
241  mddb eval {
242    SELECT frame FROM frame
243    WHERE line LIKE '%malloc.c:%' OR line LIKE '%mem2.c:%'
244  } {
245    set ::O(ignore.$frame) 1
246  }
247}
248
249open_database
250bind $O(tree) <<TreeviewSelect>> [list populate_text_widget mddb]
251
252populate_tree_widget mddb [mddb one {SELECT zTest FROM malloc LIMIT 1}]
253
254