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 |
} |