Posted to tcl by gps at Wed Mar 11 08:00:44 GMT 2009view raw

  1.  
  2. set fd [open [lindex $argv 0] r]
  3. set data [read $fd]
  4. close $fd
  5.  
  6. array set objs {}
  7.  
  8. foreach line [split $data \n] {
  9. if {[string match "new objPtr *" $line]} {
  10. set linelist [split $line]
  11. set addr [string trim [lindex $linelist 2]]
  12. #puts "add ADDR:$addr"
  13.  
  14. if {[info exists objs($addr)]} {
  15. puts "re-newing an object that wasn't freed; $addr"
  16. puts "\tpreviously contained: $objs($addr)"
  17. }
  18.  
  19. set objs($addr) [lrange $linelist 3 end]
  20. } elseif {[string match "freeing objPtr*" $line]} {
  21. set linelist [split $line]
  22. set addr [string trim [lindex $linelist 2]]
  23.  
  24.  
  25. if {![info exists objs($addr)]} {
  26. puts "invalid freed object: $addr : $line"
  27. } else {
  28. #puts "removing ADDR:$addr"
  29. unset objs($addr)
  30. }
  31. }
  32. }
  33.  
  34. #parray objs
  35.  
  36. array set stats {}
  37.  
  38. foreach {key value} [array get objs] {
  39. lassign [split $value] _ file _ line
  40.  
  41. set skey "$file $line"
  42.  
  43. if {[info exists stats($skey)]} {
  44. incr stats($skey)
  45. } else {
  46. set stats($skey) 1
  47. }
  48. }
  49.  
  50. parray stats
  51.