Adding upstream version 3.40.1.upstream/3.40.1upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 253 insertions, 0 deletions

diff --git a/test/malloctraceviewer.tcl b/test/malloctraceviewer.tcl
new file mode 100644
index 0000000..4517fdc
--- /dev/null
+++ b/test/malloctraceviewer.tcl
@@ -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}]
+