Commit | Line | Data |
---|---|---|
8b3001cd FC |
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"; | |
3ad265de FC |
17 | use Data::Dumper; |
18 | $Data::Dumper::Useqq++; | |
8b3001cd | 19 | for(`find .`) { |
6aad22ca | 20 | warn $_; |
8b3001cd FC |
21 | chomp; |
22 | for(`cat \Q$_\E 2>/dev/null`) { | |
6a95d59f | 23 | next if exists $exceptions{s/^\s+//r}; |
8b3001cd | 24 | next if /rm -rf/; # Could be an example from perlsec, e.g. |
cde09e54 | 25 | next if /END\s*\{/; # Creating an END block creates SVs, obviously |
4e532ee7 | 26 | next if /^\s*(?:push|unshift|(?:\@r = )?splice)/; |
f59c2126 | 27 | next if /\bselect(?:\s*\()[^()]+,/; # 4-arg select hangs |
3ad265de FC |
28 | my $q = s/[\\']/sprintf "\\%02x", ord $&/gore |
29 | =~ s/\0/'."\\0".'/grid; | |
8b3001cd FC |
30 | $prog = <<end; |
31 | open oUt, ">&", STDOUT; | |
32 | open STDOUT, ">/dev/null"; | |
33 | open STDIN, "</dev/null"; | |
34 | open STDERR, ">/dev/null"; | |
3ad265de | 35 | \$unused_variable = '$q'; |
6814b069 | 36 | eval \$unused_variable for my \$also_unused(1..3); |
8b3001cd FC |
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; | |
3ad265de | 47 | if (@_ == 2 && $_[1] > $_[0]) { print Dumper $_ } |
8b3001cd FC |
48 | } |
49 | } | |
50 | ||
51 | BEGIN { | |
52 | @exceptions = split /^/, <<'end'; | |
4e532ee7 FC |
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)"; | |
f59c2126 | 61 | $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); |
4e532ee7 | 62 | CHECK { $main::phase++ } |
f432c75f | 63 | $config{$k} = [ $config{$k} ] |
4e532ee7 FC |
64 | const char* file = __FILE__; |
65 | $data = [ $data ]; | |
66 | do { $tainted_value = shift @ENV_values } while(!$tainted_value || ref $tainted_value); | |
8b3001cd FC |
67 | do {$x[$x] = $x;} while ($x++) < 10; |
68 | eval 'v23: $counter++; goto v23 unless $counter == 2'; | |
69 | eval 'v23 : $counter++; goto v23 unless $counter == 2'; | |
4e532ee7 FC |
70 | $formdata->{$key} = [ $formdata->{$key}, $value ]; |
71 | $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd); | |
72 | { $h[++$i] = $_ } | |
73 | $i = int($i/2) until defined $self->[$i/2]; | |
f432c75f | 74 | $invmap_ref->[$i] = [ $invmap_ref->[$i] ]; |
4e532ee7 FC |
75 | $i++ while $self->{ids}{"$t$i"}++; |
76 | $mod_hash->{$k} = [ $mod_hash->{$k} ]; | |
77 | $modlibname =~ s,[\5c\5c/][^\5c\5c/]+$,, while $c--; # Q&D basename | |
78 | my $nfound = select($_[0], $_[1], $_[2], $_[3]); | |
79 | my $nfound = select($_[0], $_[1], $_[2], $gran); | |
80 | my @result = splice @temp, $self, $offset, $length, @_; | |
81 | my @r = splice @a, 0, 1, "x", "y"; | |
82 | $_ = {name=>$_}; | |
83 | $n = push @a, "rec0", "rec1", "rec2"; | |
84 | $n = push @a, "rec3", "rec4$:"; | |
85 | $n = unshift @a, "rec0", "rec1", "rec2"; | |
86 | $n = unshift @a, "rec3", "rec4$:"; | |
fdf1a925 | 87 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference |
4e532ee7 FC |
88 | @old = splice(@h, 1, 2, qw(bananas just before)); |
89 | package XS::APItest; require XSLoader; XSLoader::load() | |
90 | $pa = { -exitval => $pa }; | |
91 | $pa = { -message => $pa }; | |
92 | pop @lines while $lines[-1] eq ""; | |
93 | pop @to while $#to and $to[$#to] == $to[$#to -1]; | |
94 | prog => 'use Config; CHECK { $Config{awk} }', | |
95 | $p->{share_dir} = { dist => [ $p->{share_dir} ] }; | |
96 | $p->{share_dir} = { dist => $p->{share_dir} }; | |
97 | { push (@Bad, $key) } | |
fdf1a925 | 98 | ( push @hard, $file ), next |
4e532ee7 FC |
99 | { push @keep, $_ } |
100 | { push (@values, $value) } | |
101 | $resp = [$resp] | |
102 | $self->{DIR} = [grep $_, split ":", $self->{DIR}]; | |
103 | $share_dir->{dist} = [ $share_dir->{dist} ]; | |
f59c2126 | 104 | sleep; |
f432c75f | 105 | sleep(300); |
4e532ee7 | 106 | sleep($waitfor - 2); # Workaround for perlbug #49073 |
fdf1a925 | 107 | s![^/+]*$!man!&&-d&&!$s{$_}++&&push@m,#_;END{print"@m"}' |
4e532ee7 | 108 | $spec = [$spec, $_[0]]; |
f432c75f | 109 | $stack[$i++] &= ~1; |
4e532ee7 FC |
110 | $step = [$step]; |
111 | Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers | |
112 | weaken($objs[@objs] = $h{$_} = []); | |
113 | weaken($objs[@objs] = $$h{$_} = []); | |
114 | while (1) { my $k; } | |
115 | while(1) { sleep(1); } | |
116 | $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++; | |
117 | $x->[scalar @$x] = 0; # avoid || 0 test inside loop | |
118 | $z = splice @a, 3, 1, "recordZ"; | |
8b3001cd FC |
119 | end |
120 | @exceptions{@exceptions} = (); | |
121 | } |