1 files changed, 145 insertions, 19 deletions
diff --git a/ext/pdo_sqlite/sqlite/tool/memleak3.tcl b/ext/pdo_sqlite/sqlite/tool/memleak3.tcl
index 69bc4ae88e..2e3f43bc13 100644
--- a/ext/pdo_sqlite/sqlite/tool/memleak3.tcl
+++ b/ext/pdo_sqlite/sqlite/tool/memleak3.tcl
@@ -13,7 +13,8 @@ exec `which tclsh` $0 "$@"
 set doco "
 This script is a tool to help track down memory leaks in the sqlite
 library. The library must be compiled with the preprocessor symbol
-SQLITE_DEBUG set to at least 2. It must be set to 3 to enable stack traces.
+SQLITE_MEMDEBUG set to at least 2. It must be set to 3 to enable stack 
+traces.
 
 To use, run the leaky application and save the standard error output.
 Then, execute this program with the first argument the name of the
@@ -24,29 +25,88 @@ If all goes well a summary of unfreed allocations is printed out. If the
 GNU C library is in use and SQLITE_DEBUG is 3 or greater a stack trace is
 printed out for each unmatched allocation.
 
+If the \"-r <n>\" option is passed, then the program stops and prints out
+the state of the heap immediately after the <n>th call to malloc() or
+realloc().
+
 Example:
 
 $ ./testfixture ../sqlite/test/select1.test 2> memtrace.out
-$ tclsh $argv0 ./testfixture memtrace.out
+$ tclsh $argv0 ?-r <malloc-number>? ./testfixture memtrace.out
 "
 
-# If stack traces are enabled, the 'addr2line' program is called to
-# translate a binary stack address into a human-readable form.
-set addr2line addr2line
 
-if { [llength $argv]!=2 } {
-  puts "Usage: $argv0 <binary file> <mem trace file>"
+proc usage {} {
+  set prg [file tail $::argv0]
+  puts "Usage: $prg ?-r <malloc-number>? <binary file> <mem trace file>"
   puts ""
-  puts [string trim $doco]
+  puts [string trim $::doco]
   exit -1
 }
 
+proc shift {listvar} {
+  upvar $listvar l
+  set ret [lindex $l 0]
+  set l [lrange $l 1 end]
+  return $ret
+}
+
+# Argument handling. The following vars are set:
+#
+# $exe       - the name of the executable (i.e. "testfixture" or "./sqlite3")
+# $memfile   - the name of the file containing the trace output.
+# $report_at - The malloc number to stop and report at. Or -1 to read 
+#              all of $memfile.
+#
+set report_at -1
+while {[llength $argv]>2} {
+  set arg [shift argv]
+  switch -- $arg {
+    "-r" {
+      set report_at [shift argv]
+    }
+    default {
+      usage
+    }
+  }
+}
+if {[llength $argv]!=2} usage
+set exe [lindex $argv 0]
+set memfile [lindex $argv 1]
+
+# If stack traces are enabled, the 'addr2line' program is called to
+# translate a binary stack address into a human-readable form.
+set addr2line addr2line
+
+# When the SQLITE_MEMDEBUG is set as described above, SQLite prints
+# out a line for each malloc(), realloc() or free() call that the
+# library makes. If SQLITE_MEMDEBUG is 3, then a stack trace is printed
+# out before each malloc() and realloc() line.
+#
+# This program parses each line the SQLite library outputs and updates
+# the following global Tcl variables to reflect the "current" state of
+# the heap used by SQLite.
+#
+set nBytes 0               ;# Total number of bytes currently allocated.
+set nMalloc 0              ;# Total number of malloc()/realloc() calls.
+set nPeak 0                ;# Peak of nBytes.
+set iPeak 0                ;# nMalloc when nPeak was set.
+#
+# More detailed state information is stored in the $memmap array. 
+# Each key in the memmap array is the address of a chunk of memory
+# currently allocated from the heap. The value is a list of the 
+# following form
+# 
+#     {<number-of-bytes> <malloc id> <stack trace>}
+#
+array unset memmap
 
 proc process_input {input_file array_name} {
   upvar $array_name mem 
   set input [open $input_file]
 
   set MALLOC {([[:digit:]]+) malloc ([[:digit:]]+) bytes at 0x([[:xdigit:]]+)}
+  # set STACK {^[[:digit:]]+: STACK: (.*)$}
   set STACK {^STACK: (.*)$}
   set FREE {[[:digit:]]+ free ([[:digit:]]+) bytes at 0x([[:xdigit:]]+)}
   set REALLOC {([[:digit:]]+) realloc ([[:digit:]]+) to ([[:digit:]]+)}
@@ -66,6 +126,17 @@ proc process_input {input_file array_name} {
       set mem($addr) [list $bytes "malloc $mallocid" $stack]
       set stack ""
 
+      # Increase the current heap usage
+      incr ::nBytes $bytes
+
+      # Increase the number of malloc() calls
+      incr ::nMalloc
+
+      if {$::nBytes > $::nPeak} {
+        set ::nPeak $::nBytes
+        set ::iPeak $::nMalloc
+      }
+
     } elseif { [regexp $FREE $line dummy bytes addr] } {
       # If this is a 'free' line, remove the entry from the mem array. If the 
       # entry does not exist, or is the wrong number of bytes, announce a
@@ -76,31 +147,86 @@ proc process_input {input_file array_name} {
       }
       unset mem($addr) 
 
+      # Decrease the current heap usage
+      incr ::nBytes [expr -1 * $bytes]
+
     } elseif { [regexp $REALLOC $line dummy mallocid ob b oa a] } {
-      # If it is a realloc line, remove the old mem entry and add a new one.
+      # "free" the old allocation in the internal model:
+      incr ::nBytes [expr -1 * $ob]
       unset mem($oa);
+
+      # "malloc" the new allocation
       set mem($a) [list $b "realloc $mallocid" $stack]
+      incr ::nBytes $b
       set stack ""
+
+      # Increase the number of malloc() calls
+      incr ::nMalloc
+
+      if {$::nBytes > $::nPeak} {
+        set ::nPeak $::nBytes
+        set ::iPeak $::nMalloc
+      }
+
     } else {
       # puts "REJECT: $line"
     }
+
+    if {$::nMalloc==$::report_at} report
   }
 
   close $input
 }
 
-process_input [lindex $argv 1] mem
-set exe [lindex $argv 0]
-
-foreach key [array names mem] {
-  set bytes [lindex $mem($key) 0]
-  set mallocid [lindex $mem($key) 1]
-  set stack [lindex $mem($key) 2]
-  puts "Leaked $bytes bytes at 0x$key: $mallocid"
-  foreach frame [lrange $stack 1 10] {
-    foreach {f l} [split [exec $addr2line -f --exe=$exe $frame] \n] {}
+proc printstack {stack} {
+  set fcount 10
+  if {[llength $stack]<10} {
+    set fcount [llength $stack]
+  }
+  foreach frame [lrange $stack 1 $fcount] {
+    foreach {f l} [split [exec $::addr2line -f --exe=$::exe $frame] \n] {}
     puts [format "%-30s %s" $f $l]
   }
   if {[llength $stack]>0 } {puts ""}
 }
 
+proc report {} {
+
+  foreach key [array names ::memmap] {
+    set stack [lindex $::memmap($key) 2]
+    set bytes [lindex $::memmap($key) 0]
+    lappend summarymap($stack) $bytes
+  }
+
+  foreach stack [array names summarymap] {
+    set allocs $summarymap($stack)
+    set sum 0
+    foreach a $allocs {
+      incr sum $a
+    }
+    lappend sorted [list $sum $stack]
+  }
+
+  set sorted [lsort -integer -index 0 $sorted]
+  foreach s $sorted {
+    set sum [lindex $s 0]
+    set stack [lindex $s 1]
+    set allocs $summarymap($stack)
+    puts "$sum bytes in [llength $allocs] chunks ($allocs)"
+    printstack $stack
+  }
+
+  # Print out summary statistics
+  puts "Total allocations            : $::nMalloc"
+  puts "Total outstanding allocations: [array size ::memmap]" 
+  puts "Current heap usage           : $::nBytes bytes"
+  puts "Peak heap usage              : $::nPeak bytes (malloc #$::iPeak)"
+
+  exit
+}
+
+process_input $memfile memmap
+report
+
+
+