The Tor Browser / file comparison
comparison: tools/rb/find-comptr-leakers.pl
tools/rb/find-comptr-leakers.pl
- branch
- TOR_BUG_9701
- changeset 8
- 97036ab72558
equal
deleted
inserted
replaced
| -1:000000000000 | 0:6b609496a716 |
|---|---|
| 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 |
