fix typo in comment
[perl.git] / Porting / leakfinder.pl
1
2 # WARNING! This script can be dangerous.  It executes every line in every
3 # file in the build directory and its subdirectories, so it could do some
4 # harm if the line contains `rm *` or something similar.
5 #
6 # Run this as ./perl -Ilib Porting/leakfinder.pl after building perl.
7 #
8 # This is a quick non-portable hack that evaluates pieces of code in an
9 # eval twice and sees whether the number of SVs goes up.  Any lines that
10 # leak are printed to STDOUT.
11 #
12 # push and unshift will give false positives.  Some lines (listed at the
13 # bottom) are explicitly skipped.  Some patterns (at the beginning of the
14 # inner for loop) are also skipped.
15
16 use XS::APItest "sv_count";
17 use Data::Dumper;
18 $Data::Dumper::Useqq++;
19 for(`find .`) {
20  warn $_;
21  chomp;
22  for(`cat \Q$_\E 2>/dev/null`) {
23     next if exists $exceptions{s/^\s+//r};
24     next if /rm -rf/; # Could be an example from perlsec, e.g.
25     next if /END\s*\{/; # Creating an END block creates SVs, obviously
26     next if /^\s*(?:push|unshift|(?:\@r = )?splice)/;
27     next if /\bselect(?:\s*\()[^()]+,/; # 4-arg select hangs
28     my $q = s/[\\']/sprintf "\\%02x", ord $&/gore
29          =~ s/\0/'."\\0".'/grid;
30     $prog = <<end;   
31             open oUt, ">&", STDOUT;
32             open STDOUT, ">/dev/null";
33             open STDIN, "</dev/null";
34             open STDERR, ">/dev/null";
35             \$unused_variable = '$q';
36             eval \$unused_variable;
37             print oUt sv_count, "\n";
38             eval \$unused_variable;
39             print oUt sv_count, "\n";
40 end
41     open my $fh, "-|", $^X, "-Ilib", "-MXS::APItest=sv_count",
42                  '-e', $prog or warn($!), next;
43     local $/;
44     $out = <$fh>;
45     close $fh;
46     @_ = split ' ', $out;
47     if (@_ == 2 && $_[1] > $_[0]) { print Dumper $_ }
48  }
49 }
50
51 BEGIN {
52  @exceptions = split /^/, <<'end';
53 $allow ? $hash{$acc} = $allow : push @list, $acc;
54 $args{include_dirs} = [ $args{include_dirs} ] 
55 $ARRAY[++$#ARRAY] = $value;
56 $a = {x => $a};
57 BEGIN { unshift(@INC, "./blib") }
58 BEGIN { unshift(\@INC, LIST) }
59 binmode *STDERR, ":encoding(utf8)";
60 binmode *STDOUT, ":encoding(utf8)";
61 $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
62 CHECK { $main::phase++ }
63 const char* file = __FILE__;
64 $data = [ $data ];
65 do { $tainted_value = shift @ENV_values  } while(!$tainted_value || ref $tainted_value);
66 do {$x[$x] = $x;} while ($x++) < 10;
67 eval 'v23: $counter++; goto v23 unless $counter == 2';
68 eval 'v23 : $counter++; goto v23 unless $counter == 2';
69 $formdata->{$key} = [ $formdata->{$key}, $value ];
70 $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
71 { $h[++$i] = $_ }
72 $i = int($i/2) until defined $self->[$i/2];
73 $i++ while $self->{ids}{"$t$i"}++;
74 $mod_hash->{$k} = [ $mod_hash->{$k} ];
75 $modlibname =~ s,[\5c\5c/][^\5c\5c/]+$,, while $c--;    # Q&D basename
76 my $nfound = select($_[0], $_[1], $_[2], $_[3]);
77 my $nfound = select($_[0], $_[1], $_[2], $gran);
78 my @result = splice @temp, $self, $offset, $length, @_;
79 my @r = splice @a, 0, 1, "x", "y";
80 $_ = {name=>$_};
81 $n = push @a, "rec0", "rec1", "rec2";
82 $n = push @a, "rec3", "rec4$:";
83 $n = unshift @a, "rec0", "rec1", "rec2";
84 $n = unshift @a, "rec3", "rec4$:";
85 @old = splice(@h, 1, 2, qw(bananas just before));
86 package XS::APItest; require XSLoader; XSLoader::load()
87 $pa = { -exitval => $pa };
88 $pa = { -message => $pa };
89 pop @lines while $lines[-1] eq "";
90 pop @to while $#to and $to[$#to] == $to[$#to -1];
91 prog => 'use Config; CHECK { $Config{awk} }',
92 $p->{share_dir} = { dist => [ $p->{share_dir} ] };
93 $p->{share_dir} = { dist => $p->{share_dir} };
94 { push (@Bad, $key) }
95 { push @keep, $_ }
96 { push (@values, $value) }
97 $resp = [$resp]
98 $self->{DIR} = [grep $_, split ":", $self->{DIR}];
99 $share_dir->{dist} = [ $share_dir->{dist} ];
100 sleep;
101 sleep($waitfor - 2);    # Workaround for perlbug #49073
102 $spec = [$spec, $_[0]];
103 $step = [$step];
104 Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
105 weaken($objs[@objs] = $h{$_} = []);
106 weaken($objs[@objs] = $$h{$_} = []);
107 while (1) { my $k; }
108 while(1) { sleep(1); }
109 $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
110 $x->[scalar @$x] = 0;           # avoid || 0 test inside loop
111 $z = splice @a, 3, 1, "recordZ";
112 end
113  @exceptions{@exceptions} = ();
114 }