| 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 | # Creating one of these special blocks creates SVs, obviously |
| 26 | next if /(?:END|CHECK|INIT)\s*\{/; |
| 27 | next if /^[{(]?\s*(?:push|unshift|(?:\@r = )?splice|binmode|sleep)/; |
| 28 | next if /\bselect(?:\s*|\()[^()]+,/; # 4-arg select hangs |
| 29 | next if /use parent/; |
| 30 | my $q = s/[\\']/sprintf "\\%02x", ord $&/gore |
| 31 | =~ s/\0/'."\\0".'/grid; |
| 32 | $prog = <<end; |
| 33 | open oUt, ">&", STDOUT; |
| 34 | open STDOUT, ">", "/dev/null"; |
| 35 | open STDIN, "<", "/dev/null"; |
| 36 | open STDERR, ">", "/dev/null"; |
| 37 | \$unused_variable = '$q'; |
| 38 | eval \$unused_variable while \$also_unused++ < 4; |
| 39 | print oUt sv_count, "\n"; |
| 40 | eval \$unused_variable; |
| 41 | print oUt sv_count, "\n"; |
| 42 | end |
| 43 | open my $fh, "-|", $^X, "-Ilib", "-MXS::APItest=sv_count", |
| 44 | '-e', $prog or warn($!), next; |
| 45 | local $/; |
| 46 | $out = <$fh>; |
| 47 | close $fh; |
| 48 | @_ = split ' ', $out; |
| 49 | if (@_ == 2 && $_[1] > $_[0]) { print Dumper $_ } |
| 50 | } |
| 51 | } |
| 52 | |
| 53 | BEGIN { |
| 54 | @exceptions = split /^/, <<'end'; |
| 55 | 1 while 1; |
| 56 | 1 while some_condition_with_side_effects; */ |
| 57 | $a{buttons}[2*$a{default_button}] = [$a{buttons}[2*$a{default_button}]]; |
| 58 | $aliases{$code_point} = [ $aliases{$code_point} ]; |
| 59 | $aliases_maps->[$i] = [ $aliases_maps->[$i] ] |
| 60 | $allow ? $hash{$acc} = $allow : push @list, $acc; |
| 61 | /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g; |
| 62 | $^A .= new version ~$_ for "\xce", v205, "\xcc"; |
| 63 | A rare race condition that would lead to L<sleep|perlfunc/sleep> taking more |
| 64 | $args{include_dirs} = [ $args{include_dirs} ] |
| 65 | $ARRAY[++$#ARRAY] = $value; |
| 66 | @a = sort ($b, @a) |
| 67 | $a = {x => $a}; |
| 68 | $base =~ /^[cwnv]/i or push @tmpl, "$base>", "$base<"; |
| 69 | $base =~ /^[nv]/i or push @formats, "$base>", "$base<"; |
| 70 | BEGIN { unshift(@INC, "./blib") } |
| 71 | BEGIN { unshift @INC, "lib" } |
| 72 | BEGIN { unshift(@INC, LIST) } |
| 73 | binmode *STDERR, ":encoding(utf8)"; |
| 74 | binmode *STDOUT, ":encoding(utf8)"; |
| 75 | char const *file = __FILE__; |
| 76 | $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); |
| 77 | CHECK { $main::phase++ } |
| 78 | $config{$k} = [ $config{$k} ] |
| 79 | const char *file = __FILE__; |
| 80 | const char* file = __FILE__; |
| 81 | $count4 = unshift (@array, 0); |
| 82 | $count7 = unshift (@array, 3, 2, 1); |
| 83 | $data = [ $data ]; |
| 84 | do { $tainted_value = shift @ENV_values } while(!$tainted_value || ref $tainted_value); |
| 85 | do {$x[$x] = $x;} while ($x++) < 10; |
| 86 | eval {CHECK {print ":c3"}}; |
| 87 | eval {INIT {print ":i2"}}; |
| 88 | eval { $proto->can($method) } || push @nok, $method; |
| 89 | eval { push \@ISA, __FILE__ }; |
| 90 | eval 'v23: $counter++; goto v23 unless $counter == 2'; |
| 91 | eval 'v23 : $counter++; goto v23 unless $counter == 2'; |
| 92 | $formdata->{$key} = [ $formdata->{$key}, $value ]; |
| 93 | $func = $next{$func} until $pod{$func}; |
| 94 | $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd); |
| 95 | $h{ []} = 123; |
| 96 | { $h[++$i] = $_ } |
| 97 | High resolution alarm, sleep, gettimeofday, interval timers |
| 98 | if (-d "$directory/$_") { push @ARGV, "$directory/$_" } |
| 99 | $i = int($i/2) until defined $self->[$i/2]; |
| 100 | $invmap_ref->[$i] = [ $invmap_ref->[$i] ]; |
| 101 | is(push(@ary,4), 3); |
| 102 | is(push(@ary,56), 4); |
| 103 | is(unshift(@ary,12), 5); |
| 104 | $i++ while $self->{ids}{"$t$i"}++; |
| 105 | { --$level; push @out, (" " x $level) . "</ul>"; } |
| 106 | $mod_hash->{$k} = [ $mod_hash->{$k} ]; |
| 107 | $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename |
| 108 | my $deep1 = []; push @$deep1, $deep1; |
| 109 | my $deep2 = []; push @$deep2, $deep2; |
| 110 | my $nfound = select($_[0], $_[1], $_[2], $_[3]); |
| 111 | my $nfound = select($_[0], $_[1], $_[2], $gran); |
| 112 | my $n = unshift(@ary,5,6); |
| 113 | my @result = splice @temp, $self, $offset, $length, @_; |
| 114 | my @r = splice @a, 0, 1, "x", "y"; |
| 115 | $_ = {name=>$_}; |
| 116 | $n = push @a, "rec0", "rec1", "rec2"; |
| 117 | $n = push @a, "rec3", "rec4$:"; |
| 118 | $n = unshift @a, "rec0", "rec1", "rec2"; |
| 119 | $n = unshift @a, "rec3", "rec4$:"; |
| 120 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference |
| 121 | @old = splice(@h, 1, 2, qw(bananas just before)); |
| 122 | unlink <"$filename*">; |
| 123 | package XS::APItest; require XSLoader; XSLoader::load() |
| 124 | $pa = { -exitval => $pa }; |
| 125 | $pa = { -message => $pa }; |
| 126 | pop @lines while $lines[-1] eq ""; |
| 127 | pop @to while $#to and $to[$#to] == $to[$#to -1]; |
| 128 | pop(@$x); unshift(@q, $q); |
| 129 | @prgs = (@prgs, $file, split "\n########\n", <$fh>) ; |
| 130 | print "LA LA LA\n" while 1; # loops forever |
| 131 | prog => 'use Config; CHECK { $Config{awk} }', |
| 132 | $p->{share_dir} = { dist => [ $p->{share_dir} ] }; |
| 133 | $p->{share_dir} = { dist => $p->{share_dir} }; |
| 134 | -sleep |
| 135 | $resp = [$resp] |
| 136 | $r = eval q[ qr/$r(??{$x})/; ]; |
| 137 | $r = qr/$r(??{$x})/; |
| 138 | s/a|/push @bar, 1/e; |
| 139 | $self->{DIR} = [grep $_, split ":", $self->{DIR}]; |
| 140 | $share_dir->{dist} = [ $share_dir->{dist} ]; |
| 141 | s![^/+]*$!man!&&-d&&!$s{$_}++&&push@m,#_;END{print"@m"}' |
| 142 | $spec = [$spec, $_[0]]; |
| 143 | *s = ~(*s); |
| 144 | $stack[$i++] &= ~1; |
| 145 | $step = [$step]; |
| 146 | sub CHECK {print ":check"} |
| 147 | sub INIT {print ":init"} |
| 148 | system("find . -type f -print | xargs chmod 0444"); |
| 149 | the while clause. */ |
| 150 | Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers |
| 151 | *tmpl = ~*tmpl; |
| 152 | *tmps = ~*tmps; |
| 153 | until ($i) { } |
| 154 | weaken($objs[@objs] = $h{$_} = []); |
| 155 | weaken($objs[@objs] = $$h{$_} = []); |
| 156 | while (1) { my $k; } |
| 157 | while(1) { sleep(1); } |
| 158 | while($foo--) { print("In thread $thread\n"); } |
| 159 | "words" =~ /(word|word|word)(?{push @got, $1})s$/; |
| 160 | "words" =~ /(word|word|word)(?{push @got,$1})s$/i; |
| 161 | $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++; |
| 162 | $x->[scalar @$x] = 0; # avoid || 0 test inside loop |
| 163 | $z = splice @a, 3, 1, "recordZ"; |
| 164 | end |
| 165 | @exceptions{@exceptions} = (); |
| 166 | } |