AryaWu/sqlite

1 2package require sqlite33package require Tk4 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 $path11    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 nsew15  16    grid rowconfigure    $path 0 -weight 117    grid columnconfigure $path 0 -weight 118  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 $w27  }28  proc scrollcommand {grid sb args} {29    $sb set {*}$args30    set isRequired [expr {[lindex $args 0] != 0.0 || [lindex $args 1] != 1.0}]31    if {$isRequired && ![winfo ismapped $sb]} {32      {*}$grid33    }34    if {!$isRequired && [winfo ismapped $sb]} {35      grid forget $sb36    }37  }38  namespace export scrollable39}40namespace import ::autoscroll::*41#############################################################################42 43proc populate_text_widget {db} {44  $::O(text) configure -state normal45  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 line51    set content [$db one "SELECT content FROM file WHERE name = '$file'"]52    $::O(text) delete 0.0 end53 54    set iLine 155    foreach L [split $content "\n"] {56      if {$iLine == $line} {57        $::O(text) insert end "$L\n" highlight58      } else {59        $::O(text) insert end "$L\n"60      }61      incr iLine62    }63    $::O(text) yview -pickplace ${line}.064  }65  $::O(text) configure -state disabled66}67 68proc populate_index {db} {69  $::O(text) configure -state normal70  71  $::O(text) delete 0.0 end72  $::O(text) insert end "\n\n"73 74  set L [format "    % -40s%12s%12s\n" "Test Case" "Allocations" "Bytes"]75  $::O(text) insert end $L76  $::O(text) insert end "    [string repeat - 64]\n"77 78  $db eval {79    SELECT 'TOTAL' AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes80    FROM malloc 81      UNION ALL82    SELECT ztest AS ztest, sum(ncall) AS calls, sum(nbyte) AS bytes83    FROM malloc 84    GROUP BY ztest85 86    ORDER BY 3 DESC87  } {88    set tags [list $ztest]89    if {$ztest eq $::O(current)} {90      lappend tags highlight91    }92    set L [format "    % -40s%12s%12s\n" $ztest $calls $bytes]93    $::O(text) insert end $L $tags94 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 disabled101}102 103proc sort_tree_compare {iLeft iRight} {104  global O105  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 $res126}127 128proc sort_tree {iMode} {129  global O130  if {$O(tree_sort) == $iMode} {131    incr O(tree_sort)132  } else {133    set O(tree_sort) $iMode134  }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] {} $ii140  }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 $stack148}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 stack159      FROM malloc160      WHERE (zTest = $zTest OR $zTest = 'TOTAL') AND llength(lstack)>$ii161      GROUP BY stack162      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 $v172      }173    }174  }175 176  set ::O(current) $zTest177  populate_index $db178}179 180 181 182set O(tree_sort) 0183 184::ttk::panedwindow .pan -orient horizontal185set O(tree) [scrollable ::ttk::treeview .pan.tree]186 187frame .pan.right188set 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 x191pack .pan.right.text -fill both -expand true192 193$O(text) tag configure highlight -background wheat194$O(text) configure -wrap none -height 35195 196.pan add .pan.tree197.pan add .pan.right198 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 150204$O(tree) column calls -width 100205$O(tree) column bytes -width 100206 207pack .pan -fill both -expand 1208 209#--------------------------------------------------------------------210# Open the database containing the malloc data. The user specifies the211# 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 $::BUILTIN217    wm title . $::argv0218  } else {219    set zFilename [lindex $::argv 0]220    if {$zFilename eq ""} {221      set zFilename mallocs.sql222    }223    set fd [open $zFilename]224    set zHdr [read $fd 15]225    if {$zHdr eq "SQLite format 3"} {226      close $fd227      sqlite3 mddb $zFilename228    } else {229      seek $fd 0230      sqlite3 mddb :memory:231      mddb eval [read $fd]232      close $fd233    }234    wm title . $zFilename235  }236 237  mddb function lrange -argcount 3 lrange238  mddb function llength -argcount 1 llength239  mddb function trim_frames -argcount 1 trim_frames240 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) 1246  }247}248 249open_database250bind $O(tree) <<TreeviewSelect>> [list populate_text_widget mddb]251 252populate_tree_widget mddb [mddb one {SELECT zTest FROM malloc LIMIT 1}]253 254