tools/rb/find-comptr-leakers.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # This Source Code Form is subject to the terms of the Mozilla Public
   4 # License, v. 2.0. If a copy of the MPL was not distributed with this
   5 # file, You can obtain one at http://mozilla.org/MPL/2.0/.
   6
   7 # Script loosely based on Chris Waterson's find-leakers.pl and make-tree.pl
   8
   9 use 5.004;
  10 use strict;
  11 use Getopt::Long;
  12
  13 # GetOption will create $opt_object, so ignore the
  14 # warning that gets spit out about those vbls.
  15 GetOptions("object=s", "list", "help");
  16
  17 # use $::opt_help twice to eliminate warning...
  18 ($::opt_help) && ($::opt_help) && die qq{
  19 usage: find-comptr-leakers.pl < logfile
  20   --object <obj>                 Examine only object <obj>
  21   --list                                 Only list leaked objects
  22   --help                                 This message :-)
  23 };
  24
  25 if ($::opt_object) {
  26         warn "Examining only object $::opt_object (THIS IS BROKEN)\n";
  27 } else {
  28         warn "Examining all objects\n";
  29 }
  30
  31 my %allocs = ( );
  32 my %counter;
  33 my $id = 0;
  34
  35 my $accumulating = 0;
  36 my $savedata = 0;
  37 my $class;
  38 my $obj;
  39 my $sno;
  40 my $op;
  41 my $cnt;
  42 my $ptr;
  43 my $strace;
  44
  45 sub save_data {
  46         # save the data
  47         if ($op eq 'nsCOMPtrAddRef') {
  48                 push @{ $allocs{$sno}->{$ptr} }, [ +1, $strace ];
  49         }
  50         elsif ($op eq 'nsCOMPtrRelease') {
  51                 push @{ $allocs{$sno}->{$ptr} }, [ -1, $strace ];
  52                 my $sum = 0;
  53                 my @ptrallocs = @{ $allocs{$sno}->{$ptr} };
  54                 foreach my $alloc (@ptrallocs) {
  55                         $sum += @$alloc[0];
  56                 }
  57                 if ( $sum == 0 ) {
  58                         delete($allocs{$sno}{$ptr});
  59                 }
  60         }
  61 }
  62
  63 LINE: while (<>) {
  64         if (/^</) {
  65                 chop; # avoid \n in $ptr
  66                 my @fields = split(/ /, $_);
  67
  68                 ($class, $obj, $sno, $op, $cnt, $ptr) = @fields;
  69
  70                 $strace = "";
  71
  72                 if ($::opt_list) {
  73                         save_data();
  74                 } elsif (!($::opt_object) || ($::opt_object eq $obj)) {
  75                         $accumulating = 1;
  76                 }
  77         } elsif ( $accumulating == 1 ) {
  78                 if ( /^$/ ) {
  79                         # if line is empty
  80                         $accumulating = 0;
  81                         save_data();
  82                 } else {
  83                         $strace = $strace . $_;
  84                 }
  85         }
  86 }
  87 if ( $accumulating == 1) {
  88         save_data();
  89 }
  90
  91 foreach my $serial (keys(%allocs)) {
  92         foreach my $comptr (keys( %{$allocs{$serial}} )) {
  93                 my $sum = 0;
  94                 my @ptrallocs = @{ $allocs{$serial}->{$comptr} };
  95                 foreach my $alloc (@ptrallocs) {
  96                         $sum += @$alloc[0];
  97                 }
  98                 print "Object ", $serial, " held by ", $comptr, " is ", $sum, " out of balance.\n";
  99                 unless ($::opt_list) {
 100                         print "\n";
 101                         foreach my $alloc (@ptrallocs) {
 102                                 if (@$alloc[0] == +1) {
 103                                         print "Put into nsCOMPtr at:\n";
 104                                 } elsif (@$alloc[0] == -1) {
 105                                         print "Released from nsCOMPtr at:\n";
 106                                 }
 107                                 print @$alloc[1]; # the stack trace
 108                                 print "\n";
 109                         }
 110                         print "\n\n";
 111                 }
 112         }
 113 }
 114