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      # 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 rare race condition that would lead to L<sleep|perlfunc/sleep> taking more
  63 $args{include_dirs} = [ $args{include_dirs} ]
  64 $ARRAY[++$#ARRAY] = $value;
  65 @a = sort ($b, @a)
  66 $a = {x => $a};
  67 BEGIN { unshift(@INC, "./blib") }
  68 BEGIN { unshift @INC, "lib" }
  69 BEGIN { unshift(@INC, LIST) }
  70 binmode *STDERR, ":encoding(utf8)";
  71 binmode *STDOUT, ":encoding(utf8)";
  72 char const *file = __FILE__;
  73 $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
  74 CHECK { $main::phase++ }
  75 $config{$k} = [ $config{$k} ]
  76 const char *file = __FILE__;
  77 const char* file = __FILE__;
  78 $count4 = unshift (@array, 0);
  79 $count7 = unshift (@array, 3, 2, 1);
  80 $data = [ $data ];
  81 do { $tainted_value = shift @ENV_values  } while(!$tainted_value || ref $tainted_value);
  82 do {$x[$x] = $x;} while ($x++) < 10;
  83 eval {CHECK {print ":c3"}};
  84 eval {INIT {print ":i2"}};
  85 eval { $proto->can($method) } || push @nok, $method
  86 eval { push \@ISA, __FILE__ };
  87 eval 'v23: $counter++; goto v23 unless $counter == 2';
  88 eval 'v23 : $counter++; goto v23 unless $counter == 2';
  89 $formdata->{$key} = [ $formdata->{$key}, $value ];
  90 $func = $next{$func} until $pod{$func};
  91 $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
  92 $h{ []} = 123;
  93 { $h[++$i] = $_ }
  94 High resolution alarm, sleep, gettimeofday, interval timers
  95 $i = int($i/2) until defined $self->[$i/2];
  96 $invmap_ref->[$i] = [ $invmap_ref->[$i] ];
  97 is(push(@ary,4), 3);
  98 is(push(@ary,56), 4);
  99 is(unshift(@ary,12), 5);
 100 $i++ while $self->{ids}{"$t$i"}++;
 101 { --$level; push @out, ("  " x $level) . "</ul>"; }
 102 $mod_hash->{$k} = [ $mod_hash->{$k} ];
 103 $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
 104 my $deep1 = []; push @$deep1, $deep1;
 105 my $deep2 = []; push @$deep2, $deep2;
 106 my $nfound = select($_[0], $_[1], $_[2], $_[3]);
 107 my $nfound = select($_[0], $_[1], $_[2], $gran);
 108 my $n = unshift(@ary,5,6);
 109 my @result = splice @temp, $self, $offset, $length, @_;
 110 my @r = splice @a, 0, 1, "x", "y";
 111 $_ = {name=>$_};
 112 $n = push @a, "rec0", "rec1", "rec2";
 113 $n = push @a, "rec3", "rec4$:";
 114 $n = unshift @a, "rec0", "rec1", "rec2";
 115 $n = unshift @a, "rec3", "rec4$:";
 116 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
 117 @old = splice(@h, 1, 2, qw(bananas just before));
 118 unlink <"$filename*">;
 119 package XS::APItest; require XSLoader; XSLoader::load()
 120 $pa = { -exitval => $pa };
 121 $pa = { -message => $pa };
 122 pop @lines while $lines[-1] eq "";
 123 pop @to while $#to and $to[$#to] == $to[$#to -1];
 124 pop(@$x); unshift(@q, $q);
 125 @prgs = (@prgs, $file, split "\n########\n", <$fh>) ;
 126 print "LA LA LA\n" while 1;          # loops forever
 127 prog => 'use Config; CHECK { $Config{awk} }',
 128 $p->{share_dir} = { dist => [ $p->{share_dir} ] };
 129 $p->{share_dir} = { dist => $p->{share_dir} };
 130 $resp = [$resp]
 131 s/a|/push @bar, 1/e;
 132 $self->{DIR} = [grep $_, split ":", $self->{DIR}];
 133 $share_dir->{dist} = [ $share_dir->{dist} ];
 134 s![^/+]*$!man!&&-d&&!$s{$_}++&&push@m,#_;END{print"@m"}'
 135 $spec = [$spec, $_[0]];
 136 *s = ~(*s);
 137 $stack[$i++] &= ~1;
 138 $step = [$step];
 139 sub CHECK {print ":check"}
 140 sub INIT {print ":init"}
 141 system("find . -type f -print     | xargs chmod 0444");
 142 the while clause.  */
 143 Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
 144 *tmpl = ~*tmpl;
 145 *tmps = ~*tmps;
 146 until ($i) { }
 147 weaken($objs[@objs] = $h{$_} = []);
 148 weaken($objs[@objs] = $$h{$_} = []);
 149 while (1) { my $k; }
 150 while(1) { sleep(1); }
 151 while($foo--) { print("In thread $thread\n"); }
 152 "words" =~ /(word|word|word)(?{push \@got, $1})s$/;
 153 "words" =~ /(word|word|word)(?{push \@got,$1})s$/i;
 154 $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++;
 155 $x->[scalar @$x] = 0;           # avoid || 0 test inside loop
 156 $z = splice @a, 3, 1, "recordZ";
 157 end
 158  @exceptions{@exceptions} = ();
 159 }