tools/rb/find-comptr-leakers.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # ***** BEGIN LICENSE BLOCK *****
   4 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   5 #
   6 # The contents of this file are subject to the Mozilla Public License Version
   7 # 1.1 (the "License"); you may not use this file except in compliance with
   8 # the License. You may obtain a copy of the License at
   9 # http://www.mozilla.org/MPL/
  10 #
  11 # Software distributed under the License is distributed on an "AS IS" basis,
  12 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13 # for the specific language governing rights and limitations under the
  14 # License.
  15 #
  16 # The Original Code is mozilla.org Code.
  17 #
  18 # The Initial Developer of the Original Code is
  19 # L. David Baron <dbaron@dbaron.org>
  20 # Portions created by the Initial Developer are Copyright (C) 1998
  21 # the Initial Developer. All Rights Reserved.
  22 #
  23 # Contributor(s):
  24 #
  25 # Alternatively, the contents of this file may be used under the terms of
  26 # either the GNU General Public License Version 2 or later (the "GPL"), or
  27 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  28 # in which case the provisions of the GPL or the LGPL are applicable instead
  29 # of those above. If you wish to allow use of your version of this file only
  30 # under the terms of either the GPL or the LGPL, and not to allow others to
  31 # use your version of this file under the terms of the MPL, indicate your
  32 # decision by deleting the provisions above and replace them with the notice
  33 # and other provisions required by the GPL or the LGPL. If you do not delete
  34 # the provisions above, a recipient may use your version of this file under
  35 # the terms of any one of the MPL, the GPL or the LGPL.
  36 #
  37 # ***** END LICENSE BLOCK *****
  38
  39 # Script loosely based on Chris Waterson's find-leakers.pl and make-tree.pl
  40
  41 use 5.004;
  42 use strict;
  43 use Getopt::Long;
  44
  45 # GetOption will create $opt_object, so ignore the
  46 # warning that gets spit out about those vbls.
  47 GetOptions("object=s", "list", "help");
  48
  49 # use $::opt_help twice to eliminate warning...
  50 ($::opt_help) && ($::opt_help) && die qq{
  51 usage: find-comptr-leakers.pl < logfile
  52   --object <obj>                 Examine only object <obj>
  53   --list                                 Only list leaked objects
  54   --help                                 This message :-)
  55 };
  56
  57 if ($::opt_object) {
  58         warn "Examining only object $::opt_object (THIS IS BROKEN)\n";
  59 } else {
  60         warn "Examining all objects\n";
  61 }
  62
  63 my %allocs = ( );
  64 my %counter;
  65 my $id = 0;
  66
  67 my $accumulating = 0;
  68 my $savedata = 0;
  69 my $class;
  70 my $obj;
  71 my $sno;
  72 my $op;
  73 my $cnt;
  74 my $ptr;
  75 my $strace;
  76
  77 sub save_data {
  78         # save the data
  79         if ($op eq 'nsCOMPtrAddRef') {
  80                 push @{ $allocs{$sno}->{$ptr} }, [ +1, $strace ];
  81         }
  82         elsif ($op eq 'nsCOMPtrRelease') {
  83                 push @{ $allocs{$sno}->{$ptr} }, [ -1, $strace ];
  84                 my $sum = 0;
  85                 my @ptrallocs = @{ $allocs{$sno}->{$ptr} };
  86                 foreach my $alloc (@ptrallocs) {
  87                         $sum += @$alloc[0];
  88                 }
  89                 if ( $sum == 0 ) {
  90                         delete($allocs{$sno}{$ptr});
  91                 }
  92         }
  93 }
  94
  95 LINE: while (<>) {
  96         if (/^</) {
  97                 chop; # avoid \n in $ptr
  98                 my @fields = split(/ /, $_);
  99
 100                 ($class, $obj, $sno, $op, $cnt, $ptr) = @fields;
 101
 102                 $strace = "";
 103
 104                 if ($::opt_list) {
 105                         save_data();
 106                 } elsif (!($::opt_object) || ($::opt_object eq $obj)) {
 107                         $accumulating = 1;
 108                 }
 109         } elsif ( $accumulating == 1 ) {
 110                 if ( /^$/ ) {
 111                         # if line is empty
 112                         $accumulating = 0;
 113                         save_data();
 114                 } else {
 115                         $strace = $strace . $_;
 116                 }
 117         }
 118 }
 119 if ( $accumulating == 1) {
 120         save_data();
 121 }
 122
 123 foreach my $serial (keys(%allocs)) {
 124         foreach my $comptr (keys( %{$allocs{$serial}} )) {
 125                 my $sum = 0;
 126                 my @ptrallocs = @{ $allocs{$serial}->{$comptr} };
 127                 foreach my $alloc (@ptrallocs) {
 128                         $sum += @$alloc[0];
 129                 }
 130                 print "Object ", $serial, " held by ", $comptr, " is ", $sum, " out of balance.\n";
 131                 unless ($::opt_list) {
 132                         print "\n";
 133                         foreach my $alloc (@ptrallocs) {
 134                                 if (@$alloc[0] == +1) {
 135                                         print "Put into nsCOMPtr at:\n";
 136                                 } elsif (@$alloc[0] == -1) {
 137                                         print "Released from nsCOMPtr at:\n";
 138                                 }
 139                                 print @$alloc[1]; # the stack trace
 140                                 print "\n";
 141                         }
 142                         print "\n\n";
 143                 }
 144         }
 145 }
 146