Commit | Line | Data |
---|---|---|
1e422769 | 1 | #!./perl -T |
2 | # | |
3 | # Taint tests by Tom Phoenix <rootbeer@teleport.com>. | |
4 | # | |
5 | # I don't claim to know all about tainting. If anyone sees | |
9607fc9c | 6 | # tests that I've missed here, please add them. But this is |
1e422769 | 7 | # better than having no tests at all, right? |
8 | # | |
9 | ||
10 | BEGIN { | |
11 | chdir 't' if -d 't'; | |
632e037a | 12 | require './test.pl'; |
d27877a4 FC |
13 | @INC = () unless is_miniperl(); |
14 | unshift @INC, '../lib'; | |
1e422769 | 15 | } |
16 | ||
17 | use strict; | |
18 | use Config; | |
19 | ||
64ff300b | 20 | plan tests => 801; |
7c36658b | 21 | |
0ecd3ba2 MG |
22 | $| = 1; |
23 | ||
c9f931b8 JH |
24 | use vars qw($ipcsysv); # did we manage to load IPC::SysV? |
25 | ||
ff504b36 | 26 | my ($old_env_path, $old_env_dcl_path, $old_env_term); |
3eeba6fb | 27 | BEGIN { |
ff504b36 JM |
28 | $old_env_path = $ENV{'PATH'}; |
29 | $old_env_dcl_path = $ENV{'DCL$PATH'}; | |
30 | $old_env_term = $ENV{'TERM'}; | |
3eeba6fb CB |
31 | if ($^O eq 'VMS' && !defined($Config{d_setenv})) { |
32 | $ENV{PATH} = $ENV{PATH}; | |
33 | $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; | |
34 | } | |
be3174d2 GS |
35 | if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ |
36 | && ($Config{d_shm} || $Config{d_msg})) { | |
c9f931b8 JH |
37 | eval { require IPC::SysV }; |
38 | unless ($@) { | |
39 | $ipcsysv++; | |
ddc3217d | 40 | IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT)); |
c9f931b8 | 41 | } |
b9d1c439 | 42 | } |
3eeba6fb CB |
43 | } |
44 | ||
09f04786 MS |
45 | my $Is_VMS = $^O eq 'VMS'; |
46 | my $Is_MSWin32 = $^O eq 'MSWin32'; | |
47 | my $Is_NetWare = $^O eq 'NetWare'; | |
48 | my $Is_Dos = $^O eq 'dos'; | |
49 | my $Is_Cygwin = $^O eq 'cygwin'; | |
8c2c7bd1 | 50 | my $Is_OpenBSD = $^O eq 'openbsd'; |
1fb83d06 | 51 | my $Is_MirBSD = $^O eq 'mirbsd'; |
08322f8f | 52 | my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.exe' : |
09f04786 | 53 | $Is_MSWin32 ? '.\perl' : |
7b903762 | 54 | $Is_NetWare ? 'perl' : |
09f04786 | 55 | './perl' ; |
c90c0ff4 | 56 | my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; |
7bac28a0 | 57 | |
1e422769 | 58 | if ($Is_VMS) { |
7bac28a0 | 59 | my (%old, $x); |
60 | for $x ('DCL$PATH', @MoreEnv) { | |
61 | ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; | |
62 | } | |
ff504b36 JM |
63 | # VMS note: PATH and TERM are automatically created by the C |
64 | # library in VMS on reference to the their keys in %ENV. | |
65 | # There is currently no way to determine if they did not exist | |
66 | # before this test was run. | |
1e422769 | 67 | eval <<EndOfCleanup; |
68 | END { | |
ff504b36 JM |
69 | \$ENV{PATH} = \$old_env_path; |
70 | warn "# Note: logical name 'PATH' may have been created\n"; | |
71 | \$ENV{'TERM'} = \$old_env_term; | |
72 | warn "# Note: logical name 'TERM' may have been created\n"; | |
562a7b0c | 73 | \@ENV{keys %old} = values %old; |
ff504b36 JM |
74 | if (defined \$old_env_dcl_path) { |
75 | \$ENV{'DCL\$PATH'} = \$old_env_dcl_path; | |
76 | } else { | |
77 | delete \$ENV{'DCL\$PATH'}; | |
78 | } | |
1e422769 | 79 | } |
80 | EndOfCleanup | |
81 | } | |
82 | ||
83 | # Sources of taint: | |
84 | # The empty tainted value, for tainting strings | |
85 | my $TAINT = substr($^X, 0, 0); | |
86 | # A tainted zero, useful for tainting numbers | |
09f04786 MS |
87 | my $TAINT0; |
88 | { | |
89 | no warnings; | |
90 | $TAINT0 = 0 + $TAINT; | |
91 | } | |
1e422769 | 92 | |
93 | # This taints each argument passed. All must be lvalues. | |
94 | # Side effect: It also stringifies them. :-( | |
95 | sub taint_these (@) { | |
96 | for (@_) { $_ .= $TAINT } | |
97 | } | |
98 | ||
99 | # How to identify taint when you see it | |
1e422769 | 100 | sub tainted ($) { |
6e7325e5 | 101 | local $@; # Don't pollute caller's value. |
81cba34d | 102 | not eval { join("",@_), kill 0; 1 }; |
1e422769 | 103 | } |
1e422769 | 104 | |
f37ea7f0 NC |
105 | sub is_tainted { |
106 | my $thing = shift; | |
107 | local $::Level = $::Level + 1; | |
81cba34d | 108 | ok(tainted($thing), @_); |
f37ea7f0 NC |
109 | } |
110 | ||
111 | sub isnt_tainted { | |
112 | my $thing = shift; | |
113 | local $::Level = $::Level + 1; | |
81cba34d | 114 | ok(!tainted($thing), @_); |
f37ea7f0 NC |
115 | } |
116 | ||
8184526b | 117 | sub violates_taint { |
ef5cbc63 NC |
118 | my ($code, $what, $desc) = @_; |
119 | $desc //= $what; | |
8184526b NC |
120 | local $::Level = $::Level + 1; |
121 | is(eval { $code->(); }, undef, $desc); | |
ef5cbc63 | 122 | like($@, qr/^Insecure dependency in $what while running with -T switch/); |
8184526b NC |
123 | } |
124 | ||
1e422769 | 125 | # We need an external program to call. |
7b903762 | 126 | my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$")); |
1e422769 | 127 | END { unlink $ECHO } |
22d7dfed NC |
128 | open my $fh, '>', $ECHO or die "Can't create $ECHO: $!"; |
129 | print $fh 'print "@ARGV\n"', "\n"; | |
130 | close $fh; | |
1e422769 | 131 | my $echo = "$Invoke_Perl $ECHO"; |
132 | ||
22d7dfed | 133 | my $TEST = 'TEST'; |
dc459aad | 134 | |
1e422769 | 135 | # First, let's make sure that Perl is checking the dangerous |
136 | # environment variables. Maybe they aren't set yet, so we'll | |
137 | # taint them ourselves. | |
138 | { | |
139 | $ENV{'DCL$PATH'} = '' if $Is_VMS; | |
140 | ||
e59c8b07 | 141 | $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : ''; |
c90c0ff4 | 142 | delete @ENV{@MoreEnv}; |
7bac28a0 | 143 | $ENV{TERM} = 'dumb'; |
144 | ||
c3197de1 | 145 | is(eval { `$echo 1` }, "1\n"); |
09f04786 MS |
146 | |
147 | SKIP: { | |
148 | skip "Environment tainting tests skipped", 4 | |
7b903762 | 149 | if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos; |
7bac28a0 | 150 | |
7bac28a0 | 151 | my @vars = ('PATH', @MoreEnv); |
152 | while (my $v = $vars[0]) { | |
153 | local $ENV{$v} = $TAINT; | |
154 | last if eval { `$echo 1` }; | |
2a53d331 | 155 | last unless $@ =~ /^Insecure \$ENV\{$v}/; |
7bac28a0 | 156 | shift @vars; |
157 | } | |
c3197de1 | 158 | is("@vars", ""); |
c90c0ff4 | 159 | |
160 | # tainted $TERM is unsafe only if it contains metachars | |
161 | local $ENV{TERM}; | |
162 | $ENV{TERM} = 'e=mc2'; | |
c3197de1 | 163 | is(eval { `$echo 1` }, "1\n"); |
c90c0ff4 | 164 | $ENV{TERM} = 'e=mc2' . $TAINT; |
c3197de1 | 165 | is(eval { `$echo 1` }, undef); |
2a53d331 | 166 | like($@, qr/^Insecure \$ENV\{TERM}/); |
5aabfad6 | 167 | } |
7bac28a0 | 168 | |
9607fc9c | 169 | my $tmp; |
2986a63f | 170 | if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) { |
48c036b1 GS |
171 | print "# all directories are writeable\n"; |
172 | } | |
173 | else { | |
9607fc9c | 174 | $tmp = (grep { defined and -d and (stat _)[2] & 2 } |
099f76bb | 175 | qw(sys$scratch /tmp /var/tmp /usr/tmp), |
9607fc9c | 176 | @ENV{qw(TMP TEMP)})[0] |
177 | or print "# can't find world-writeable directory to test PATH\n"; | |
178 | } | |
179 | ||
09f04786 MS |
180 | SKIP: { |
181 | skip "all directories are writeable", 2 unless $tmp; | |
182 | ||
7bac28a0 | 183 | local $ENV{PATH} = $tmp; |
c3197de1 | 184 | is(eval { `$echo 1` }, undef); |
22636a29 BF |
185 | # Message can be different depending on whether echo |
186 | # is a builtin or not | |
187 | like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH}/); | |
1e422769 | 188 | } |
189 | ||
09f04786 MS |
190 | SKIP: { |
191 | skip "This is not VMS", 4 unless $Is_VMS; | |
192 | ||
1e422769 | 193 | $ENV{'DCL$PATH'} = $TAINT; |
81e6f6d0 | 194 | is(eval { `$echo 1` }, undef); |
2a53d331 | 195 | like($@, qr/^Insecure \$ENV\{DCL\$PATH}/); |
09f04786 MS |
196 | SKIP: { |
197 | skip q[can't find world-writeable directory to test DCL$PATH], 2 | |
25fb98c0 | 198 | unless $tmp; |
09f04786 | 199 | |
9607fc9c | 200 | $ENV{'DCL$PATH'} = $tmp; |
81e6f6d0 | 201 | is(eval { `$echo 1` }, undef); |
2a53d331 | 202 | like($@, qr/^Insecure directory in \$ENV\{DCL\$PATH}/); |
9607fc9c | 203 | } |
1e422769 | 204 | $ENV{'DCL$PATH'} = ''; |
205 | } | |
1e422769 | 206 | } |
207 | ||
208 | # Let's see that we can taint and untaint as needed. | |
209 | { | |
210 | my $foo = $TAINT; | |
f37ea7f0 | 211 | is_tainted($foo); |
9607fc9c | 212 | |
213 | # That was a sanity check. If it failed, stop the insanity! | |
214 | die "Taint checks don't seem to be enabled" unless tainted $foo; | |
1e422769 | 215 | |
216 | $foo = "foo"; | |
f37ea7f0 | 217 | isnt_tainted($foo); |
1e422769 | 218 | |
219 | taint_these($foo); | |
f37ea7f0 | 220 | is_tainted($foo); |
1e422769 | 221 | |
222 | my @list = 1..10; | |
81cba34d | 223 | isnt_tainted($_) foreach @list; |
1e422769 | 224 | taint_these @list[1,3,5,7,9]; |
e75436bf | 225 | is_tainted($_) foreach @list[1,3,5,7,9]; |
81cba34d | 226 | isnt_tainted($_) foreach @list[0,2,4,6,8]; |
1e422769 | 227 | |
228 | ($foo) = $foo =~ /(.+)/; | |
f37ea7f0 | 229 | isnt_tainted($foo); |
1e422769 | 230 | |
c769ddc7 DM |
231 | my ($desc, $s, $res, $res2, $one); |
232 | ||
233 | $desc = "match with string tainted"; | |
234 | ||
235 | $s = 'abcd' . $TAINT; | |
236 | $res = $s =~ /(.+)/; | |
237 | $one = $1; | |
f37ea7f0 NC |
238 | is_tainted($s, "$desc: s tainted"); |
239 | isnt_tainted($res, "$desc: res not tainted"); | |
240 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
241 | is($res, 1, "$desc: res value"); |
242 | is($one, 'abcd', "$desc: \$1 value"); | |
243 | ||
244 | $desc = "match /g with string tainted"; | |
245 | ||
246 | $s = 'abcd' . $TAINT; | |
247 | $res = $s =~ /(.)/g; | |
248 | $one = $1; | |
f37ea7f0 NC |
249 | is_tainted($s, "$desc: s tainted"); |
250 | isnt_tainted($res, "$desc: res not tainted"); | |
251 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
252 | is($res, 1, "$desc: res value"); |
253 | is($one, 'a', "$desc: \$1 value"); | |
254 | ||
255 | $desc = "match with string tainted, list cxt"; | |
256 | ||
257 | $s = 'abcd' . $TAINT; | |
258 | ($res) = $s =~ /(.+)/; | |
259 | $one = $1; | |
f37ea7f0 NC |
260 | is_tainted($s, "$desc: s tainted"); |
261 | isnt_tainted($res, "$desc: res not tainted"); | |
262 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
263 | is($res, 'abcd', "$desc: res value"); |
264 | is($one, 'abcd', "$desc: \$1 value"); | |
265 | ||
266 | $desc = "match /g with string tainted, list cxt"; | |
267 | ||
268 | $s = 'abcd' . $TAINT; | |
269 | ($res, $res2) = $s =~ /(.)/g; | |
270 | $one = $1; | |
f37ea7f0 NC |
271 | is_tainted($s, "$desc: s tainted"); |
272 | isnt_tainted($res, "$desc: res not tainted"); | |
273 | isnt_tainted($res2,"$desc: res2 not tainted"); | |
274 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
275 | is($res, 'a', "$desc: res value"); |
276 | is($res2,'b', "$desc: res2 value"); | |
277 | is($one, 'd', "$desc: \$1 value"); | |
278 | ||
279 | $desc = "match with pattern tainted"; | |
280 | ||
281 | $s = 'abcd'; | |
282 | $res = $s =~ /$TAINT(.+)/; | |
283 | $one = $1; | |
f37ea7f0 NC |
284 | isnt_tainted($s, "$desc: s not tainted"); |
285 | isnt_tainted($res, "$desc: res not tainted"); | |
286 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
287 | is($res, 1, "$desc: res value"); |
288 | is($one, 'abcd', "$desc: \$1 value"); | |
289 | ||
290 | $desc = "match /g with pattern tainted"; | |
291 | ||
292 | $s = 'abcd'; | |
293 | $res = $s =~ /$TAINT(.)/g; | |
294 | $one = $1; | |
f37ea7f0 NC |
295 | isnt_tainted($s, "$desc: s not tainted"); |
296 | isnt_tainted($res, "$desc: res not tainted"); | |
297 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
298 | is($res, 1, "$desc: res value"); |
299 | is($one, 'a', "$desc: \$1 value"); | |
300 | ||
569f7fc5 JR |
301 | SKIP: { |
302 | skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale}); | |
c769ddc7 | 303 | |
569f7fc5 | 304 | $desc = "match with pattern tainted via locale"; |
c769ddc7 | 305 | |
569f7fc5 JR |
306 | $s = 'abcd'; |
307 | { | |
5f1269ab | 308 | use locale; |
569f7fc5 JR |
309 | $res = $s =~ /(\w+)/; $one = $1; |
310 | } | |
311 | isnt_tainted($s, "$desc: s not tainted"); | |
312 | isnt_tainted($res, "$desc: res not tainted"); | |
313 | is_tainted($one, "$desc: \$1 tainted"); | |
314 | is($res, 1, "$desc: res value"); | |
315 | is($one, 'abcd', "$desc: \$1 value"); | |
316 | ||
317 | $desc = "match /g with pattern tainted via locale"; | |
318 | ||
319 | $s = 'abcd'; | |
320 | { | |
5f1269ab | 321 | use locale; |
569f7fc5 JR |
322 | $res = $s =~ /(\w)/g; $one = $1; |
323 | } | |
324 | isnt_tainted($s, "$desc: s not tainted"); | |
325 | isnt_tainted($res, "$desc: res not tainted"); | |
326 | is_tainted($one, "$desc: \$1 tainted"); | |
327 | is($res, 1, "$desc: res value"); | |
328 | is($one, 'a', "$desc: \$1 value"); | |
329 | } | |
c769ddc7 DM |
330 | |
331 | $desc = "match with pattern tainted, list cxt"; | |
332 | ||
333 | $s = 'abcd'; | |
334 | ($res) = $s =~ /$TAINT(.+)/; | |
335 | $one = $1; | |
f37ea7f0 NC |
336 | isnt_tainted($s, "$desc: s not tainted"); |
337 | is_tainted($res, "$desc: res tainted"); | |
338 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
339 | is($res, 'abcd', "$desc: res value"); |
340 | is($one, 'abcd', "$desc: \$1 value"); | |
341 | ||
342 | $desc = "match /g with pattern tainted, list cxt"; | |
343 | ||
344 | $s = 'abcd'; | |
345 | ($res, $res2) = $s =~ /$TAINT(.)/g; | |
346 | $one = $1; | |
f37ea7f0 NC |
347 | isnt_tainted($s, "$desc: s not tainted"); |
348 | is_tainted($res, "$desc: res tainted"); | |
349 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
350 | is($res, 'a', "$desc: res value"); |
351 | is($res2,'b', "$desc: res2 value"); | |
352 | is($one, 'd', "$desc: \$1 value"); | |
353 | ||
569f7fc5 JR |
354 | SKIP: { |
355 | skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale}); | |
c769ddc7 | 356 | |
569f7fc5 | 357 | $desc = "match with pattern tainted via locale, list cxt"; |
c769ddc7 | 358 | |
569f7fc5 JR |
359 | $s = 'abcd'; |
360 | { | |
5f1269ab | 361 | use locale; |
569f7fc5 JR |
362 | ($res) = $s =~ /(\w+)/; $one = $1; |
363 | } | |
364 | isnt_tainted($s, "$desc: s not tainted"); | |
365 | is_tainted($res, "$desc: res tainted"); | |
366 | is_tainted($one, "$desc: \$1 tainted"); | |
367 | is($res, 'abcd', "$desc: res value"); | |
368 | is($one, 'abcd', "$desc: \$1 value"); | |
369 | ||
370 | $desc = "match /g with pattern tainted via locale, list cxt"; | |
371 | ||
372 | $s = 'abcd'; | |
373 | { | |
5f1269ab | 374 | use locale; |
569f7fc5 JR |
375 | ($res, $res2) = $s =~ /(\w)/g; $one = $1; |
376 | } | |
377 | isnt_tainted($s, "$desc: s not tainted"); | |
378 | is_tainted($res, "$desc: res tainted"); | |
379 | is_tainted($res2, "$desc: res2 tainted"); | |
380 | is_tainted($one, "$desc: \$1 tainted"); | |
381 | is($res, 'a', "$desc: res value"); | |
382 | is($res2,'b', "$desc: res2 value"); | |
383 | is($one, 'd', "$desc: \$1 value"); | |
384 | } | |
c769ddc7 DM |
385 | |
386 | $desc = "substitution with string tainted"; | |
387 | ||
388 | $s = 'abcd' . $TAINT; | |
389 | $res = $s =~ s/(.+)/xyz/; | |
390 | $one = $1; | |
f37ea7f0 NC |
391 | is_tainted($s, "$desc: s tainted"); |
392 | isnt_tainted($res, "$desc: res not tainted"); | |
393 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
394 | is($s, 'xyz', "$desc: s value"); |
395 | is($res, 1, "$desc: res value"); | |
396 | is($one, 'abcd', "$desc: \$1 value"); | |
397 | ||
398 | $desc = "substitution /g with string tainted"; | |
399 | ||
400 | $s = 'abcd' . $TAINT; | |
401 | $res = $s =~ s/(.)/x/g; | |
402 | $one = $1; | |
f37ea7f0 NC |
403 | is_tainted($s, "$desc: s tainted"); |
404 | is_tainted($res, "$desc: res tainted"); | |
405 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
406 | is($s, 'xxxx', "$desc: s value"); |
407 | is($res, 4, "$desc: res value"); | |
408 | is($one, 'd', "$desc: \$1 value"); | |
409 | ||
410 | $desc = "substitution /r with string tainted"; | |
411 | ||
412 | $s = 'abcd' . $TAINT; | |
413 | $res = $s =~ s/(.+)/xyz/r; | |
414 | $one = $1; | |
f37ea7f0 NC |
415 | is_tainted($s, "$desc: s tainted"); |
416 | is_tainted($res, "$desc: res tainted"); | |
417 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
418 | is($s, 'abcd', "$desc: s value"); |
419 | is($res, 'xyz', "$desc: res value"); | |
420 | is($one, 'abcd', "$desc: \$1 value"); | |
421 | ||
20be6587 DM |
422 | $desc = "substitution /e with string tainted"; |
423 | ||
424 | $s = 'abcd' . $TAINT; | |
425 | $one = ''; | |
426 | $res = $s =~ s{(.+)}{ | |
427 | $one = $one . "x"; # make sure code not tainted | |
f37ea7f0 | 428 | isnt_tainted($one, "$desc: code not tainted within /e"); |
20be6587 | 429 | $one = $1; |
f37ea7f0 | 430 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); |
20be6587 DM |
431 | "xyz"; |
432 | }e; | |
433 | $one = $1; | |
f37ea7f0 NC |
434 | is_tainted($s, "$desc: s tainted"); |
435 | isnt_tainted($res, "$desc: res not tainted"); | |
436 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
20be6587 DM |
437 | is($s, 'xyz', "$desc: s value"); |
438 | is($res, 1, "$desc: res value"); | |
439 | is($one, 'abcd', "$desc: \$1 value"); | |
440 | ||
c769ddc7 DM |
441 | $desc = "substitution with pattern tainted"; |
442 | ||
443 | $s = 'abcd'; | |
444 | $res = $s =~ s/$TAINT(.+)/xyz/; | |
445 | $one = $1; | |
f37ea7f0 NC |
446 | is_tainted($s, "$desc: s tainted"); |
447 | isnt_tainted($res, "$desc: res not tainted"); | |
448 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
449 | is($s, 'xyz', "$desc: s value"); |
450 | is($res, 1, "$desc: res value"); | |
451 | is($one, 'abcd', "$desc: \$1 value"); | |
452 | ||
453 | $desc = "substitution /g with pattern tainted"; | |
454 | ||
455 | $s = 'abcd'; | |
456 | $res = $s =~ s/$TAINT(.)/x/g; | |
457 | $one = $1; | |
f37ea7f0 NC |
458 | is_tainted($s, "$desc: s tainted"); |
459 | is_tainted($res, "$desc: res tainted"); | |
460 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
461 | is($s, 'xxxx', "$desc: s value"); |
462 | is($res, 4, "$desc: res value"); | |
463 | is($one, 'd', "$desc: \$1 value"); | |
464 | ||
20be6587 DM |
465 | $desc = "substitution /ge with pattern tainted"; |
466 | ||
467 | $s = 'abc'; | |
468 | { | |
469 | my $i = 0; | |
470 | my $j; | |
471 | $res = $s =~ s{(.)$TAINT}{ | |
472 | $j = $i; # make sure code not tainted | |
473 | $one = $1; | |
f37ea7f0 | 474 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
475 | $i++; |
476 | if ($i == 1) { | |
f37ea7f0 | 477 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
478 | } |
479 | else { | |
f37ea7f0 | 480 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 481 | } |
f37ea7f0 | 482 | is_tainted($one, "$desc: \$1 tainted loop $i"); |
20be6587 DM |
483 | $i.$TAINT; |
484 | }ge; | |
485 | $one = $1; | |
486 | } | |
f37ea7f0 NC |
487 | is_tainted($s, "$desc: s tainted"); |
488 | is_tainted($res, "$desc: res tainted"); | |
489 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
490 | is($s, '123', "$desc: s value"); |
491 | is($res, 3, "$desc: res value"); | |
492 | is($one, 'c', "$desc: \$1 value"); | |
493 | ||
c769ddc7 DM |
494 | $desc = "substitution /r with pattern tainted"; |
495 | ||
496 | $s = 'abcd'; | |
497 | $res = $s =~ s/$TAINT(.+)/xyz/r; | |
498 | $one = $1; | |
f37ea7f0 NC |
499 | isnt_tainted($s, "$desc: s not tainted"); |
500 | is_tainted($res, "$desc: res tainted"); | |
501 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
502 | is($s, 'abcd', "$desc: s value"); |
503 | is($res, 'xyz', "$desc: res value"); | |
504 | is($one, 'abcd', "$desc: \$1 value"); | |
505 | ||
569f7fc5 JR |
506 | SKIP: { |
507 | skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale}); | |
c769ddc7 | 508 | |
569f7fc5 | 509 | $desc = "substitution with pattern tainted via locale"; |
c769ddc7 | 510 | |
569f7fc5 JR |
511 | $s = 'abcd'; |
512 | { | |
5f1269ab | 513 | use locale; |
569f7fc5 JR |
514 | $res = $s =~ s/(\w+)/xyz/; $one = $1; |
515 | } | |
516 | is_tainted($s, "$desc: s tainted"); | |
517 | isnt_tainted($res, "$desc: res not tainted"); | |
518 | is_tainted($one, "$desc: \$1 tainted"); | |
519 | is($s, 'xyz', "$desc: s value"); | |
520 | is($res, 1, "$desc: res value"); | |
521 | is($one, 'abcd', "$desc: \$1 value"); | |
522 | ||
523 | $desc = "substitution /g with pattern tainted via locale"; | |
524 | ||
525 | $s = 'abcd'; | |
526 | { | |
5f1269ab | 527 | use locale; |
569f7fc5 JR |
528 | $res = $s =~ s/(\w)/x/g; $one = $1; |
529 | } | |
530 | is_tainted($s, "$desc: s tainted"); | |
531 | is_tainted($res, "$desc: res tainted"); | |
532 | is_tainted($one, "$desc: \$1 tainted"); | |
533 | is($s, 'xxxx', "$desc: s value"); | |
534 | is($res, 4, "$desc: res value"); | |
535 | is($one, 'd', "$desc: \$1 value"); | |
536 | ||
537 | $desc = "substitution /r with pattern tainted via locale"; | |
538 | ||
539 | $s = 'abcd'; | |
540 | { | |
5f1269ab | 541 | use locale; |
569f7fc5 JR |
542 | $res = $s =~ s/(\w+)/xyz/r; $one = $1; |
543 | } | |
544 | isnt_tainted($s, "$desc: s not tainted"); | |
545 | is_tainted($res, "$desc: res tainted"); | |
546 | is_tainted($one, "$desc: \$1 tainted"); | |
547 | is($s, 'abcd', "$desc: s value"); | |
548 | is($res, 'xyz', "$desc: res value"); | |
549 | is($one, 'abcd', "$desc: \$1 value"); | |
550 | } | |
c769ddc7 DM |
551 | |
552 | $desc = "substitution with replacement tainted"; | |
553 | ||
554 | $s = 'abcd'; | |
555 | $res = $s =~ s/(.+)/xyz$TAINT/; | |
556 | $one = $1; | |
f37ea7f0 NC |
557 | is_tainted($s, "$desc: s tainted"); |
558 | isnt_tainted($res, "$desc: res not tainted"); | |
559 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
560 | is($s, 'xyz', "$desc: s value"); |
561 | is($res, 1, "$desc: res value"); | |
562 | is($one, 'abcd', "$desc: \$1 value"); | |
563 | ||
564 | $desc = "substitution /g with replacement tainted"; | |
565 | ||
566 | $s = 'abcd'; | |
567 | $res = $s =~ s/(.)/x$TAINT/g; | |
568 | $one = $1; | |
f37ea7f0 NC |
569 | is_tainted($s, "$desc: s tainted"); |
570 | isnt_tainted($res, "$desc: res not tainted"); | |
571 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
572 | is($s, 'xxxx', "$desc: s value"); |
573 | is($res, 4, "$desc: res value"); | |
574 | is($one, 'd', "$desc: \$1 value"); | |
575 | ||
20be6587 DM |
576 | $desc = "substitution /ge with replacement tainted"; |
577 | ||
578 | $s = 'abc'; | |
579 | { | |
580 | my $i = 0; | |
581 | my $j; | |
582 | $res = $s =~ s{(.)}{ | |
583 | $j = $i; # make sure code not tainted | |
584 | $one = $1; | |
f37ea7f0 | 585 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
586 | $i++; |
587 | if ($i == 1) { | |
f37ea7f0 | 588 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
589 | } |
590 | else { | |
f37ea7f0 | 591 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 592 | } |
f37ea7f0 | 593 | isnt_tainted($one, "$desc: \$1 not tainted within /e"); |
20be6587 DM |
594 | $i.$TAINT; |
595 | }ge; | |
596 | $one = $1; | |
597 | } | |
f37ea7f0 | 598 | is_tainted($s, "$desc: s tainted"); |
52c47e16 | 599 | isnt_tainted($res, "$desc: res tainted"); |
f37ea7f0 | 600 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
601 | is($s, '123', "$desc: s value"); |
602 | is($res, 3, "$desc: res value"); | |
603 | is($one, 'c', "$desc: \$1 value"); | |
604 | ||
c769ddc7 DM |
605 | $desc = "substitution /r with replacement tainted"; |
606 | ||
607 | $s = 'abcd'; | |
608 | $res = $s =~ s/(.+)/xyz$TAINT/r; | |
609 | $one = $1; | |
f37ea7f0 NC |
610 | isnt_tainted($s, "$desc: s not tainted"); |
611 | is_tainted($res, "$desc: res tainted"); | |
612 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
613 | is($s, 'abcd', "$desc: s value"); |
614 | is($res, 'xyz', "$desc: res value"); | |
615 | is($one, 'abcd', "$desc: \$1 value"); | |
1e422769 | 616 | |
b3eb6a9b | 617 | { |
c769ddc7 DM |
618 | # now do them all again with "use re 'taint" |
619 | ||
620 | use re 'taint'; | |
621 | ||
622 | $desc = "use re 'taint': match with string tainted"; | |
623 | ||
624 | $s = 'abcd' . $TAINT; | |
625 | $res = $s =~ /(.+)/; | |
626 | $one = $1; | |
f37ea7f0 NC |
627 | is_tainted($s, "$desc: s tainted"); |
628 | isnt_tainted($res, "$desc: res not tainted"); | |
629 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
630 | is($res, 1, "$desc: res value"); |
631 | is($one, 'abcd', "$desc: \$1 value"); | |
632 | ||
633 | $desc = "use re 'taint': match /g with string tainted"; | |
634 | ||
635 | $s = 'abcd' . $TAINT; | |
636 | $res = $s =~ /(.)/g; | |
637 | $one = $1; | |
f37ea7f0 NC |
638 | is_tainted($s, "$desc: s tainted"); |
639 | isnt_tainted($res, "$desc: res not tainted"); | |
640 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
641 | is($res, 1, "$desc: res value"); |
642 | is($one, 'a', "$desc: \$1 value"); | |
643 | ||
644 | $desc = "use re 'taint': match with string tainted, list cxt"; | |
645 | ||
646 | $s = 'abcd' . $TAINT; | |
647 | ($res) = $s =~ /(.+)/; | |
648 | $one = $1; | |
f37ea7f0 NC |
649 | is_tainted($s, "$desc: s tainted"); |
650 | is_tainted($res, "$desc: res tainted"); | |
651 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
652 | is($res, 'abcd', "$desc: res value"); |
653 | is($one, 'abcd', "$desc: \$1 value"); | |
654 | ||
655 | $desc = "use re 'taint': match /g with string tainted, list cxt"; | |
656 | ||
657 | $s = 'abcd' . $TAINT; | |
658 | ($res, $res2) = $s =~ /(.)/g; | |
659 | $one = $1; | |
f37ea7f0 NC |
660 | is_tainted($s, "$desc: s tainted"); |
661 | is_tainted($res, "$desc: res tainted"); | |
662 | is_tainted($res2, "$desc: res2 tainted"); | |
663 | is_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
664 | is($res, 'a', "$desc: res value"); |
665 | is($res2,'b', "$desc: res2 value"); | |
666 | is($one, 'd', "$desc: \$1 value"); | |
667 | ||
668 | $desc = "use re 'taint': match with pattern tainted"; | |
669 | ||
670 | $s = 'abcd'; | |
671 | $res = $s =~ /$TAINT(.+)/; | |
672 | $one = $1; | |
f37ea7f0 NC |
673 | isnt_tainted($s, "$desc: s not tainted"); |
674 | isnt_tainted($res, "$desc: res not tainted"); | |
675 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
676 | is($res, 1, "$desc: res value"); |
677 | is($one, 'abcd', "$desc: \$1 value"); | |
678 | ||
679 | $desc = "use re 'taint': match /g with pattern tainted"; | |
680 | ||
681 | $s = 'abcd'; | |
682 | $res = $s =~ /$TAINT(.)/g; | |
683 | $one = $1; | |
f37ea7f0 NC |
684 | isnt_tainted($s, "$desc: s not tainted"); |
685 | isnt_tainted($res, "$desc: res not tainted"); | |
686 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
687 | is($res, 1, "$desc: res value"); |
688 | is($one, 'a', "$desc: \$1 value"); | |
689 | ||
569f7fc5 JR |
690 | SKIP: { |
691 | skip 'No locale testing without d_setlocale', 10 if(!$Config{d_setlocale}); | |
c769ddc7 | 692 | |
569f7fc5 | 693 | $desc = "use re 'taint': match with pattern tainted via locale"; |
c769ddc7 | 694 | |
569f7fc5 JR |
695 | $s = 'abcd'; |
696 | { | |
5f1269ab | 697 | use locale; |
569f7fc5 JR |
698 | $res = $s =~ /(\w+)/; $one = $1; |
699 | } | |
700 | isnt_tainted($s, "$desc: s not tainted"); | |
701 | isnt_tainted($res, "$desc: res not tainted"); | |
702 | is_tainted($one, "$desc: \$1 tainted"); | |
703 | is($res, 1, "$desc: res value"); | |
704 | is($one, 'abcd', "$desc: \$1 value"); | |
705 | ||
706 | $desc = "use re 'taint': match /g with pattern tainted via locale"; | |
707 | ||
708 | $s = 'abcd'; | |
709 | { | |
5f1269ab | 710 | use locale; |
569f7fc5 JR |
711 | $res = $s =~ /(\w)/g; $one = $1; |
712 | } | |
713 | isnt_tainted($s, "$desc: s not tainted"); | |
714 | isnt_tainted($res, "$desc: res not tainted"); | |
715 | is_tainted($one, "$desc: \$1 tainted"); | |
716 | is($res, 1, "$desc: res value"); | |
717 | is($one, 'a', "$desc: \$1 value"); | |
718 | } | |
c769ddc7 DM |
719 | |
720 | $desc = "use re 'taint': match with pattern tainted, list cxt"; | |
721 | ||
722 | $s = 'abcd'; | |
723 | ($res) = $s =~ /$TAINT(.+)/; | |
724 | $one = $1; | |
f37ea7f0 NC |
725 | isnt_tainted($s, "$desc: s not tainted"); |
726 | is_tainted($res, "$desc: res tainted"); | |
727 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
728 | is($res, 'abcd', "$desc: res value"); |
729 | is($one, 'abcd', "$desc: \$1 value"); | |
730 | ||
731 | $desc = "use re 'taint': match /g with pattern tainted, list cxt"; | |
732 | ||
733 | $s = 'abcd'; | |
734 | ($res, $res2) = $s =~ /$TAINT(.)/g; | |
735 | $one = $1; | |
f37ea7f0 NC |
736 | isnt_tainted($s, "$desc: s not tainted"); |
737 | is_tainted($res, "$desc: res tainted"); | |
738 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
739 | is($res, 'a', "$desc: res value"); |
740 | is($res2,'b', "$desc: res2 value"); | |
741 | is($one, 'd', "$desc: \$1 value"); | |
742 | ||
569f7fc5 JR |
743 | SKIP: { |
744 | skip 'No locale testing without d_setlocale', 12 if(!$Config{d_setlocale}); | |
c769ddc7 | 745 | |
569f7fc5 | 746 | $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; |
c769ddc7 | 747 | |
569f7fc5 JR |
748 | $s = 'abcd'; |
749 | { | |
5f1269ab | 750 | use locale; |
569f7fc5 JR |
751 | ($res) = $s =~ /(\w+)/; $one = $1; |
752 | } | |
753 | isnt_tainted($s, "$desc: s not tainted"); | |
754 | is_tainted($res, "$desc: res tainted"); | |
755 | is_tainted($one, "$desc: \$1 tainted"); | |
756 | is($res, 'abcd', "$desc: res value"); | |
757 | is($one, 'abcd', "$desc: \$1 value"); | |
758 | ||
759 | $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; | |
760 | ||
761 | $s = 'abcd'; | |
762 | { | |
5f1269ab | 763 | use locale; |
569f7fc5 JR |
764 | ($res, $res2) = $s =~ /(\w)/g; $one = $1; |
765 | } | |
766 | isnt_tainted($s, "$desc: s not tainted"); | |
767 | is_tainted($res, "$desc: res tainted"); | |
768 | is_tainted($res2, "$desc: res2 tainted"); | |
769 | is_tainted($one, "$desc: \$1 tainted"); | |
770 | is($res, 'a', "$desc: res value"); | |
771 | is($res2,'b', "$desc: res2 value"); | |
772 | is($one, 'd', "$desc: \$1 value"); | |
773 | } | |
c769ddc7 DM |
774 | |
775 | $desc = "use re 'taint': substitution with string tainted"; | |
776 | ||
777 | $s = 'abcd' . $TAINT; | |
778 | $res = $s =~ s/(.+)/xyz/; | |
779 | $one = $1; | |
f37ea7f0 NC |
780 | is_tainted($s, "$desc: s tainted"); |
781 | isnt_tainted($res, "$desc: res not tainted"); | |
782 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
783 | is($s, 'xyz', "$desc: s value"); |
784 | is($res, 1, "$desc: res value"); | |
785 | is($one, 'abcd', "$desc: \$1 value"); | |
786 | ||
787 | $desc = "use re 'taint': substitution /g with string tainted"; | |
788 | ||
789 | $s = 'abcd' . $TAINT; | |
790 | $res = $s =~ s/(.)/x/g; | |
791 | $one = $1; | |
f37ea7f0 NC |
792 | is_tainted($s, "$desc: s tainted"); |
793 | is_tainted($res, "$desc: res tainted"); | |
794 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
795 | is($s, 'xxxx', "$desc: s value"); |
796 | is($res, 4, "$desc: res value"); | |
797 | is($one, 'd', "$desc: \$1 value"); | |
798 | ||
799 | $desc = "use re 'taint': substitution /r with string tainted"; | |
800 | ||
801 | $s = 'abcd' . $TAINT; | |
802 | $res = $s =~ s/(.+)/xyz/r; | |
803 | $one = $1; | |
f37ea7f0 NC |
804 | is_tainted($s, "$desc: s tainted"); |
805 | is_tainted($res, "$desc: res tainted"); | |
806 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
807 | is($s, 'abcd', "$desc: s value"); |
808 | is($res, 'xyz', "$desc: res value"); | |
809 | is($one, 'abcd', "$desc: \$1 value"); | |
810 | ||
20be6587 DM |
811 | $desc = "use re 'taint': substitution /e with string tainted"; |
812 | ||
813 | $s = 'abcd' . $TAINT; | |
814 | $one = ''; | |
815 | $res = $s =~ s{(.+)}{ | |
816 | $one = $one . "x"; # make sure code not tainted | |
f37ea7f0 | 817 | isnt_tainted($one, "$desc: code not tainted within /e"); |
20be6587 | 818 | $one = $1; |
f37ea7f0 | 819 | is_tainted($one, "$desc: $1 tainted within /e"); |
20be6587 DM |
820 | "xyz"; |
821 | }e; | |
822 | $one = $1; | |
f37ea7f0 NC |
823 | is_tainted($s, "$desc: s tainted"); |
824 | isnt_tainted($res, "$desc: res not tainted"); | |
825 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
826 | is($s, 'xyz', "$desc: s value"); |
827 | is($res, 1, "$desc: res value"); | |
828 | is($one, 'abcd', "$desc: \$1 value"); | |
829 | ||
c769ddc7 DM |
830 | $desc = "use re 'taint': substitution with pattern tainted"; |
831 | ||
832 | $s = 'abcd'; | |
833 | $res = $s =~ s/$TAINT(.+)/xyz/; | |
834 | $one = $1; | |
f37ea7f0 NC |
835 | is_tainted($s, "$desc: s tainted"); |
836 | isnt_tainted($res, "$desc: res not tainted"); | |
837 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
838 | is($s, 'xyz', "$desc: s value"); |
839 | is($res, 1, "$desc: res value"); | |
840 | is($one, 'abcd', "$desc: \$1 value"); | |
841 | ||
842 | $desc = "use re 'taint': substitution /g with pattern tainted"; | |
843 | ||
844 | $s = 'abcd'; | |
845 | $res = $s =~ s/$TAINT(.)/x/g; | |
846 | $one = $1; | |
f37ea7f0 NC |
847 | is_tainted($s, "$desc: s tainted"); |
848 | is_tainted($res, "$desc: res tainted"); | |
849 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
850 | is($s, 'xxxx', "$desc: s value"); |
851 | is($res, 4, "$desc: res value"); | |
852 | is($one, 'd', "$desc: \$1 value"); | |
853 | ||
20be6587 DM |
854 | $desc = "use re 'taint': substitution /ge with pattern tainted"; |
855 | ||
856 | $s = 'abc'; | |
857 | { | |
858 | my $i = 0; | |
859 | my $j; | |
860 | $res = $s =~ s{(.)$TAINT}{ | |
861 | $j = $i; # make sure code not tainted | |
862 | $one = $1; | |
f37ea7f0 | 863 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
864 | $i++; |
865 | if ($i == 1) { | |
f37ea7f0 | 866 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
867 | } |
868 | else { | |
f37ea7f0 | 869 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 870 | } |
f37ea7f0 | 871 | is_tainted($one, "$desc: \$1 tainted loop $i"); |
20be6587 DM |
872 | $i.$TAINT; |
873 | }ge; | |
874 | $one = $1; | |
875 | } | |
f37ea7f0 NC |
876 | is_tainted($s, "$desc: s tainted"); |
877 | is_tainted($res, "$desc: res tainted"); | |
878 | is_tainted($one, "$desc: \$1 tainted"); | |
20be6587 DM |
879 | is($s, '123', "$desc: s value"); |
880 | is($res, 3, "$desc: res value"); | |
881 | is($one, 'c', "$desc: \$1 value"); | |
882 | ||
883 | ||
c769ddc7 DM |
884 | $desc = "use re 'taint': substitution /r with pattern tainted"; |
885 | ||
886 | $s = 'abcd'; | |
887 | $res = $s =~ s/$TAINT(.+)/xyz/r; | |
888 | $one = $1; | |
f37ea7f0 NC |
889 | isnt_tainted($s, "$desc: s not tainted"); |
890 | is_tainted($res, "$desc: res tainted"); | |
891 | is_tainted($one, "$desc: \$1 tainted"); | |
c769ddc7 DM |
892 | is($s, 'abcd', "$desc: s value"); |
893 | is($res, 'xyz', "$desc: res value"); | |
894 | is($one, 'abcd', "$desc: \$1 value"); | |
895 | ||
569f7fc5 JR |
896 | SKIP: { |
897 | skip 'No locale testing without d_setlocale', 18 if(!$Config{d_setlocale}); | |
c769ddc7 | 898 | |
569f7fc5 | 899 | $desc = "use re 'taint': substitution with pattern tainted via locale"; |
c769ddc7 | 900 | |
569f7fc5 JR |
901 | $s = 'abcd'; |
902 | { | |
5f1269ab | 903 | use locale; |
569f7fc5 JR |
904 | $res = $s =~ s/(\w+)/xyz/; $one = $1; |
905 | } | |
906 | is_tainted($s, "$desc: s tainted"); | |
907 | isnt_tainted($res, "$desc: res not tainted"); | |
908 | is_tainted($one, "$desc: \$1 tainted"); | |
909 | is($s, 'xyz', "$desc: s value"); | |
910 | is($res, 1, "$desc: res value"); | |
911 | is($one, 'abcd', "$desc: \$1 value"); | |
912 | ||
913 | $desc = "use re 'taint': substitution /g with pattern tainted via locale"; | |
914 | ||
915 | $s = 'abcd'; | |
916 | { | |
5f1269ab | 917 | use locale; |
569f7fc5 JR |
918 | $res = $s =~ s/(\w)/x/g; $one = $1; |
919 | } | |
920 | is_tainted($s, "$desc: s tainted"); | |
921 | is_tainted($res, "$desc: res tainted"); | |
922 | is_tainted($one, "$desc: \$1 tainted"); | |
923 | is($s, 'xxxx', "$desc: s value"); | |
924 | is($res, 4, "$desc: res value"); | |
925 | is($one, 'd', "$desc: \$1 value"); | |
926 | ||
927 | $desc = "use re 'taint': substitution /r with pattern tainted via locale"; | |
928 | ||
929 | $s = 'abcd'; | |
930 | { | |
5f1269ab | 931 | use locale; |
569f7fc5 JR |
932 | $res = $s =~ s/(\w+)/xyz/r; $one = $1; |
933 | } | |
934 | isnt_tainted($s, "$desc: s not tainted"); | |
935 | is_tainted($res, "$desc: res tainted"); | |
936 | is_tainted($one, "$desc: \$1 tainted"); | |
937 | is($s, 'abcd', "$desc: s value"); | |
938 | is($res, 'xyz', "$desc: res value"); | |
939 | is($one, 'abcd', "$desc: \$1 value"); | |
940 | } | |
c769ddc7 DM |
941 | |
942 | $desc = "use re 'taint': substitution with replacement tainted"; | |
943 | ||
944 | $s = 'abcd'; | |
945 | $res = $s =~ s/(.+)/xyz$TAINT/; | |
946 | $one = $1; | |
f37ea7f0 NC |
947 | is_tainted($s, "$desc: s tainted"); |
948 | isnt_tainted($res, "$desc: res not tainted"); | |
949 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
950 | is($s, 'xyz', "$desc: s value"); |
951 | is($res, 1, "$desc: res value"); | |
952 | is($one, 'abcd', "$desc: \$1 value"); | |
953 | ||
954 | $desc = "use re 'taint': substitution /g with replacement tainted"; | |
955 | ||
956 | $s = 'abcd'; | |
957 | $res = $s =~ s/(.)/x$TAINT/g; | |
958 | $one = $1; | |
f37ea7f0 NC |
959 | is_tainted($s, "$desc: s tainted"); |
960 | isnt_tainted($res, "$desc: res not tainted"); | |
961 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
962 | is($s, 'xxxx', "$desc: s value"); |
963 | is($res, 4, "$desc: res value"); | |
964 | is($one, 'd', "$desc: \$1 value"); | |
965 | ||
20be6587 DM |
966 | $desc = "use re 'taint': substitution /ge with replacement tainted"; |
967 | ||
968 | $s = 'abc'; | |
969 | { | |
970 | my $i = 0; | |
971 | my $j; | |
972 | $res = $s =~ s{(.)}{ | |
973 | $j = $i; # make sure code not tainted | |
974 | $one = $1; | |
f37ea7f0 | 975 | isnt_tainted($j, "$desc: code not tainted within /e"); |
20be6587 DM |
976 | $i++; |
977 | if ($i == 1) { | |
f37ea7f0 | 978 | isnt_tainted($s, "$desc: s not tainted loop 1"); |
20be6587 DM |
979 | } |
980 | else { | |
f37ea7f0 | 981 | is_tainted($s, "$desc: s tainted loop $i"); |
20be6587 | 982 | } |
f37ea7f0 | 983 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
984 | $i.$TAINT; |
985 | }ge; | |
986 | $one = $1; | |
987 | } | |
f37ea7f0 | 988 | is_tainted($s, "$desc: s tainted"); |
52c47e16 | 989 | isnt_tainted($res, "$desc: res tainted"); |
f37ea7f0 | 990 | isnt_tainted($one, "$desc: \$1 not tainted"); |
20be6587 DM |
991 | is($s, '123', "$desc: s value"); |
992 | is($res, 3, "$desc: res value"); | |
993 | is($one, 'c', "$desc: \$1 value"); | |
994 | ||
c769ddc7 DM |
995 | $desc = "use re 'taint': substitution /r with replacement tainted"; |
996 | ||
997 | $s = 'abcd'; | |
998 | $res = $s =~ s/(.+)/xyz$TAINT/r; | |
999 | $one = $1; | |
f37ea7f0 NC |
1000 | isnt_tainted($s, "$desc: s not tainted"); |
1001 | is_tainted($res, "$desc: res tainted"); | |
1002 | isnt_tainted($one, "$desc: \$1 not tainted"); | |
c769ddc7 DM |
1003 | is($s, 'abcd', "$desc: s value"); |
1004 | is($res, 'xyz', "$desc: res value"); | |
1005 | is($one, 'abcd', "$desc: \$1 value"); | |
1738e041 DM |
1006 | |
1007 | # [perl #121854] match taintedness became sticky | |
1008 | # when one match has a taintess result, subseqent matches | |
1009 | # using the same pattern shouldn't necessarily be tainted | |
1010 | ||
1011 | { | |
1012 | my $f = sub { $_[0] =~ /(.*)/ or die; $1 }; | |
1013 | $res = $f->($TAINT); | |
1014 | is_tainted($res, "121854: res tainted"); | |
1015 | $res = $f->("abc"); | |
1016 | isnt_tainted($res, "121854: res not tainted"); | |
1017 | } | |
b3eb6a9b GS |
1018 | } |
1019 | ||
1020 | $foo = $1 if 'bar' =~ /(.+)$TAINT/; | |
f37ea7f0 | 1021 | is_tainted($foo); |
c3197de1 | 1022 | is($foo, 'bar'); |
48c036b1 | 1023 | |
1e422769 | 1024 | my $pi = 4 * atan2(1,1) + $TAINT0; |
f37ea7f0 | 1025 | is_tainted($pi); |
1e422769 | 1026 | |
1027 | ($pi) = $pi =~ /(\d+\.\d+)/; | |
f37ea7f0 | 1028 | isnt_tainted($pi); |
c3197de1 | 1029 | is(sprintf("%.5f", $pi), '3.14159'); |
1e422769 | 1030 | } |
1031 | ||
1032 | # How about command-line arguments? The problem is that we don't | |
1033 | # always get some, so we'll run another process with some. | |
dc459aad | 1034 | SKIP: { |
1ab9acc5 | 1035 | my $arg = tempfile(); |
22d7dfed NC |
1036 | open $fh, '>', $arg or die "Can't create $arg: $!"; |
1037 | print $fh q{ | |
1e422769 | 1038 | eval { join('', @ARGV), kill 0 }; |
1039 | exit 0 if $@ =~ /^Insecure dependency/; | |
1040 | print "# Oops: \$@ was [$@]\n"; | |
1041 | exit 1; | |
1042 | }; | |
22d7dfed | 1043 | close $fh or die "Can't close $arg: $!"; |
1e422769 | 1044 | print `$Invoke_Perl "-T" $arg and some suspect arguments`; |
c3197de1 | 1045 | is($?, 0, "Exited with status $?"); |
1e422769 | 1046 | unlink $arg; |
1047 | } | |
1048 | ||
1049 | # Reading from a file should be tainted | |
1050 | { | |
22d7dfed | 1051 | ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!"); |
1e422769 | 1052 | |
1053 | my $block; | |
22d7dfed NC |
1054 | sysread($fh, $block, 100); |
1055 | my $line = <$fh>; | |
1056 | close $fh; | |
f37ea7f0 NC |
1057 | is_tainted($block); |
1058 | is_tainted($line); | |
1e422769 | 1059 | } |
1060 | ||
1e422769 | 1061 | # Output of commands should be tainted |
1062 | { | |
1063 | my $foo = `$echo abc`; | |
f37ea7f0 | 1064 | is_tainted($foo); |
1e422769 | 1065 | } |
1066 | ||
1067 | # Certain system variables should be tainted | |
1068 | { | |
e75436bf NC |
1069 | is_tainted($^X); |
1070 | is_tainted($0); | |
1e422769 | 1071 | } |
1072 | ||
1073 | # Results of matching should all be untainted | |
1074 | { | |
1075 | my $foo = "abcdefghi" . $TAINT; | |
f37ea7f0 | 1076 | is_tainted($foo); |
1e422769 | 1077 | |
1078 | $foo =~ /def/; | |
81cba34d NC |
1079 | isnt_tainted($`); |
1080 | isnt_tainted($&); | |
1081 | isnt_tainted($'); | |
1e422769 | 1082 | |
1083 | $foo =~ /(...)(...)(...)/; | |
81cba34d NC |
1084 | isnt_tainted($1); |
1085 | isnt_tainted($2); | |
1086 | isnt_tainted($3); | |
1087 | isnt_tainted($+); | |
1e422769 | 1088 | |
1089 | my @bar = $foo =~ /(...)(...)(...)/; | |
81cba34d | 1090 | isnt_tainted($_) foreach @bar; |
1e422769 | 1091 | |
f37ea7f0 | 1092 | is_tainted($foo); # $foo should still be tainted! |
c3197de1 | 1093 | is($foo, "abcdefghi"); |
1e422769 | 1094 | } |
1095 | ||
1096 | # Operations which affect files can't use tainted data. | |
1097 | { | |
8184526b | 1098 | violates_taint(sub { chmod 0, $TAINT }, 'chmod'); |
1e422769 | 1099 | |
e2b4a08c NC |
1100 | SKIP: { |
1101 | skip "truncate() is not available", 2 unless $Config{d_truncate}; | |
1102 | ||
8184526b | 1103 | violates_taint(sub { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate'); |
e2b4a08c | 1104 | } |
1e422769 | 1105 | |
8184526b NC |
1106 | violates_taint(sub { rename '', $TAINT }, 'rename'); |
1107 | violates_taint(sub { unlink $TAINT }, 'unlink'); | |
1108 | violates_taint(sub { utime $TAINT }, 'utime'); | |
48c036b1 | 1109 | |
09f04786 MS |
1110 | SKIP: { |
1111 | skip "chown() is not available", 2 unless $Config{d_chown}; | |
1e422769 | 1112 | |
8184526b | 1113 | violates_taint(sub { chown -1, -1, $TAINT }, 'chown'); |
1e422769 | 1114 | } |
1115 | ||
09f04786 MS |
1116 | SKIP: { |
1117 | skip "link() is not available", 2 unless $Config{d_link}; | |
1118 | ||
8184526b | 1119 | violates_taint(sub { link $TAINT, '' }, 'link'); |
1e422769 | 1120 | } |
09f04786 MS |
1121 | |
1122 | SKIP: { | |
1123 | skip "symlink() is not available", 2 unless $Config{d_symlink}; | |
1124 | ||
8184526b | 1125 | violates_taint(sub { symlink $TAINT, '' }, 'symlink'); |
1e422769 | 1126 | } |
1127 | } | |
1128 | ||
1129 | # Operations which affect directories can't use tainted data. | |
1130 | { | |
8184526b NC |
1131 | violates_taint(sub { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir'); |
1132 | violates_taint(sub { rmdir $TAINT }, 'rmdir'); | |
1133 | violates_taint(sub { chdir "foo".$TAINT }, 'chdir'); | |
48c036b1 | 1134 | |
09f04786 MS |
1135 | SKIP: { |
1136 | skip "chroot() is not available", 2 unless $Config{d_chroot}; | |
1137 | ||
8184526b | 1138 | violates_taint(sub { chroot $TAINT }, 'chroot'); |
1e422769 | 1139 | } |
1140 | } | |
1141 | ||
1142 | # Some operations using files can't use tainted data. | |
1143 | { | |
1144 | my $foo = "imaginary library" . $TAINT; | |
8184526b | 1145 | violates_taint(sub { require $foo }, 'require'); |
1e422769 | 1146 | |
1c25d394 | 1147 | my $filename = tempfile(); # NB: $filename isn't tainted! |
1e422769 | 1148 | $foo = $filename . $TAINT; |
1149 | unlink $filename; # in any case | |
1150 | ||
c3197de1 | 1151 | is(eval { open FOO, $foo }, undef, 'open for read'); |
8184526b | 1152 | is($@, ''); # NB: This should be allowed |
22d7dfed NC |
1153 | is(eval { open my $fh, , '<', $foo }, undef, 'open for read'); |
1154 | is($@, ''); # NB: This should be allowed | |
9d116dd7 JH |
1155 | |
1156 | # Try first new style but allow also old style. | |
327ccce1 YST |
1157 | # We do not want the whole taint.t to fail |
1158 | # just because Errno possibly failing. | |
c3197de1 | 1159 | ok(eval('$!{ENOENT}') || |
61ae2fbf | 1160 | $! == 2 || # File not found |
c3197de1 | 1161 | ($Is_Dos && $! == 22)); |
1e422769 | 1162 | |
ef5cbc63 | 1163 | violates_taint(sub { open FOO, "> $foo" }, 'open', 'open for write'); |
22d7dfed | 1164 | violates_taint(sub { open my $fh, '>', $foo }, 'open', 'open for write'); |
1e422769 | 1165 | } |
1166 | ||
1167 | # Commands to the system can't use tainted data | |
1168 | { | |
1169 | my $foo = $TAINT; | |
1170 | ||
09f04786 | 1171 | SKIP: { |
22d7dfed | 1172 | skip "open('|') is not available", 8 if $^O eq 'amigaos'; |
09f04786 | 1173 | |
22d7dfed NC |
1174 | violates_taint(sub { open FOO, "| x$foo" }, 'piped open', 'popen to'); |
1175 | violates_taint(sub { open FOO, "x$foo |" }, 'piped open', 'popen from'); | |
1176 | violates_taint(sub { open my $fh, '|-', "x$foo" }, 'piped open', 'popen to'); | |
1177 | violates_taint(sub { open my $fh, '-|', "x$foo" }, 'piped open', 'popen from'); | |
48c036b1 | 1178 | } |
1e422769 | 1179 | |
8184526b NC |
1180 | violates_taint(sub { exec $TAINT }, 'exec'); |
1181 | violates_taint(sub { system $TAINT }, 'system'); | |
48c036b1 | 1182 | |
1e422769 | 1183 | $foo = "*"; |
1184 | taint_these $foo; | |
1185 | ||
ef5cbc63 | 1186 | violates_taint(sub { `$echo 1$foo` }, '``', 'backticks'); |
1e422769 | 1187 | |
09f04786 MS |
1188 | SKIP: { |
1189 | # wildcard expansion doesn't invoke shell on VMS, so is safe | |
1190 | skip "This is not VMS", 2 unless $Is_VMS; | |
1191 | ||
c3197de1 NC |
1192 | isnt(join('', eval { glob $foo } ), '', 'globbing'); |
1193 | is($@, ''); | |
1e422769 | 1194 | } |
1195 | } | |
1196 | ||
1197 | # Operations which affect processes can't use tainted data. | |
1198 | { | |
8184526b | 1199 | violates_taint(sub { kill 0, $TAINT }, 'kill'); |
1e422769 | 1200 | |
09f04786 MS |
1201 | SKIP: { |
1202 | skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; | |
1e422769 | 1203 | |
8184526b | 1204 | violates_taint(sub { setpgrp 0, $TAINT0 }, 'setpgrp'); |
1e422769 | 1205 | } |
09f04786 MS |
1206 | |
1207 | SKIP: { | |
1208 | skip "setpriority() is not available", 2 unless $Config{d_setprior}; | |
1209 | ||
8184526b | 1210 | violates_taint(sub { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority'); |
1e422769 | 1211 | } |
1212 | } | |
1213 | ||
1214 | # Some miscellaneous operations can't use tainted data. | |
1215 | { | |
09f04786 MS |
1216 | SKIP: { |
1217 | skip "syscall() is not available", 2 unless $Config{d_syscall}; | |
1218 | ||
8184526b | 1219 | violates_taint(sub { syscall $TAINT }, 'syscall'); |
1e422769 | 1220 | } |
1221 | ||
1222 | { | |
1223 | my $foo = "x" x 979; | |
1224 | taint_these $foo; | |
1225 | local *FOO; | |
1c25d394 | 1226 | my $temp = tempfile(); |
c3197de1 | 1227 | ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!"); |
8184526b | 1228 | violates_taint(sub { ioctl FOO, $TAINT0, $foo }, 'ioctl'); |
1e422769 | 1229 | |
22d7dfed NC |
1230 | my $temp2 = tempfile(); |
1231 | ok(open my $fh, '>', $temp2) or diag("Couldn't open $temp2 for write: $!"); | |
1232 | violates_taint(sub { ioctl $fh, $TAINT0, $foo }, 'ioctl'); | |
1233 | ||
09f04786 | 1234 | SKIP: { |
22d7dfed | 1235 | skip "fcntl() is not available", 4 unless $Config{d_fcntl}; |
09f04786 | 1236 | |
8184526b | 1237 | violates_taint(sub { fcntl FOO, $TAINT0, $foo }, 'fcntl'); |
22d7dfed | 1238 | violates_taint(sub { fcntl $fh, $TAINT0, $foo }, 'fcntl'); |
1e422769 | 1239 | } |
1240 | ||
1241 | close FOO; | |
1242 | } | |
1243 | } | |
1244 | ||
9607fc9c | 1245 | # Some tests involving references |
1e422769 | 1246 | { |
1247 | my $foo = 'abc' . $TAINT; | |
1248 | my $fooref = \$foo; | |
f37ea7f0 NC |
1249 | isnt_tainted($fooref); |
1250 | is_tainted($$fooref); | |
1251 | is_tainted($foo); | |
1e422769 | 1252 | } |
54310121 | 1253 | |
1254 | # Some tests involving assignment | |
1255 | { | |
1256 | my $foo = $TAINT0; | |
1257 | my $bar = $foo; | |
e75436bf NC |
1258 | is_tainted($foo); |
1259 | is_tainted($bar); | |
f37ea7f0 NC |
1260 | is_tainted($foo = $bar); |
1261 | is_tainted($bar = $bar); | |
1262 | is_tainted($bar += $bar); | |
1263 | is_tainted($bar -= $bar); | |
1264 | is_tainted($bar *= $bar); | |
1265 | is_tainted($bar++); | |
1266 | is_tainted($bar /= $bar); | |
1267 | is_tainted($bar += 0); | |
1268 | is_tainted($bar -= 2); | |
1269 | is_tainted($bar *= -1); | |
1270 | is_tainted($bar /= 1); | |
1271 | is_tainted($bar--); | |
c3197de1 | 1272 | is($bar, 0); |
54310121 | 1273 | } |
a1f49e72 CS |
1274 | |
1275 | # Test assignment and return of lists | |
1276 | { | |
1277 | my @foo = ("A", "tainted" . $TAINT, "B"); | |
f37ea7f0 NC |
1278 | isnt_tainted($foo[0]); |
1279 | is_tainted( $foo[1]); | |
1280 | isnt_tainted($foo[2]); | |
a1f49e72 | 1281 | my @bar = @foo; |
f37ea7f0 NC |
1282 | isnt_tainted($bar[0]); |
1283 | is_tainted( $bar[1]); | |
1284 | isnt_tainted($bar[2]); | |
a1f49e72 | 1285 | my @baz = eval { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1286 | isnt_tainted($baz[0]); |
1287 | is_tainted( $baz[1]); | |
1288 | isnt_tainted($baz[2]); | |
a1f49e72 | 1289 | my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; |
f37ea7f0 NC |
1290 | isnt_tainted($plugh[0]); |
1291 | is_tainted( $plugh[1]); | |
1292 | isnt_tainted($plugh[2]); | |
a1f49e72 | 1293 | my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1294 | isnt_tainted(((&$nautilus)[0])); |
1295 | is_tainted( ((&$nautilus)[1])); | |
1296 | isnt_tainted(((&$nautilus)[2])); | |
a1f49e72 | 1297 | my @xyzzy = &$nautilus; |
f37ea7f0 NC |
1298 | isnt_tainted($xyzzy[0]); |
1299 | is_tainted( $xyzzy[1]); | |
1300 | isnt_tainted($xyzzy[2]); | |
a1f49e72 | 1301 | my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; |
f37ea7f0 NC |
1302 | isnt_tainted(((&$red_october)[0])); |
1303 | is_tainted( ((&$red_october)[1])); | |
1304 | isnt_tainted(((&$red_october)[2])); | |
a1f49e72 | 1305 | my @corge = &$red_october; |
f37ea7f0 NC |
1306 | isnt_tainted($corge[0]); |
1307 | is_tainted( $corge[1]); | |
1308 | isnt_tainted($corge[2]); | |
a1f49e72 | 1309 | } |
fb73857a | 1310 | |
1311 | # Test for system/library calls returning string data of dubious origin. | |
1312 | { | |
1313 | # No reliable %Config check for getpw* | |
09f04786 | 1314 | SKIP: { |
f37ea7f0 | 1315 | skip "getpwent() is not available", 9 unless |
09f04786 MS |
1316 | eval { setpwent(); getpwent() }; |
1317 | ||
fb73857a | 1318 | setpwent(); |
1319 | my @getpwent = getpwent(); | |
1320 | die "getpwent: $!\n" unless (@getpwent); | |
f37ea7f0 NC |
1321 | isnt_tainted($getpwent[0]); |
1322 | is_tainted($getpwent[1]); | |
1323 | isnt_tainted($getpwent[2]); | |
1324 | isnt_tainted($getpwent[3]); | |
1325 | isnt_tainted($getpwent[4]); | |
1326 | isnt_tainted($getpwent[5]); | |
1327 | is_tainted($getpwent[6], 'ge?cos'); | |
1328 | isnt_tainted($getpwent[7]); | |
1329 | is_tainted($getpwent[8], 'shell'); | |
fb73857a | 1330 | endpwent(); |
fb73857a | 1331 | } |
1332 | ||
09f04786 MS |
1333 | SKIP: { |
1334 | # pretty hard to imagine not | |
1335 | skip "readdir() is not available", 1 unless $Config{d_readdir}; | |
1336 | ||
22d7dfed NC |
1337 | opendir my $dh, "op" or die "opendir: $!\n"; |
1338 | my $readdir = readdir $dh; | |
f37ea7f0 | 1339 | is_tainted($readdir); |
22d7dfed | 1340 | closedir $dh; |
fb73857a | 1341 | } |
1342 | ||
09f04786 MS |
1343 | SKIP: { |
1344 | skip "readlink() or symlink() is not available" unless | |
1345 | $Config{d_readlink} && $Config{d_symlink}; | |
1346 | ||
fb73857a | 1347 | my $symlink = "sl$$"; |
1348 | unlink($symlink); | |
dc459aad JH |
1349 | my $sl = "/something/naughty"; |
1350 | # it has to be a real path on Mac OS | |
dc459aad | 1351 | symlink($sl, $symlink) or die "symlink: $!\n"; |
fb73857a | 1352 | my $readlink = readlink($symlink); |
f37ea7f0 | 1353 | is_tainted($readlink); |
fb73857a | 1354 | unlink($symlink); |
fb73857a | 1355 | } |
1356 | } | |
1357 | ||
1358 | # test bitwise ops (regression bug) | |
1359 | { | |
1360 | my $why = "y"; | |
1361 | my $j = "x" | $why; | |
f37ea7f0 | 1362 | isnt_tainted($j); |
fb73857a | 1363 | $why = $TAINT."y"; |
1364 | $j = "x" | $why; | |
f37ea7f0 | 1365 | is_tainted( $j); |
fb73857a | 1366 | } |
1367 | ||
48c036b1 GS |
1368 | # test target of substitution (regression bug) |
1369 | { | |
1370 | my $why = $TAINT."y"; | |
1371 | $why =~ s/y/z/; | |
f37ea7f0 | 1372 | is_tainted( $why); |
48c036b1 GS |
1373 | |
1374 | my $z = "[z]"; | |
1375 | $why =~ s/$z/zee/; | |
f37ea7f0 | 1376 | is_tainted( $why); |
48c036b1 GS |
1377 | |
1378 | $why =~ s/e/'-'.$$/ge; | |
f37ea7f0 | 1379 | is_tainted( $why); |
48c036b1 | 1380 | } |
d929ce6f | 1381 | |
09f04786 MS |
1382 | |
1383 | SKIP: { | |
1384 | skip "no IPC::SysV", 2 unless $ipcsysv; | |
1385 | ||
1386 | # test shmread | |
1387 | SKIP: { | |
1388 | skip "shm*() not available", 1 unless $Config{d_shm}; | |
1389 | ||
1390 | no strict 'subs'; | |
1391 | my $sent = "foobar"; | |
1392 | my $rcvd; | |
1393 | my $size = 2000; | |
3383030d TC |
1394 | my $id; |
1395 | eval { | |
1396 | local $SIG{SYS} = sub { die "SIGSYS caught\n" }; | |
1397 | $id = shmget(IPC_PRIVATE, $size, S_IRWXU); | |
1398 | 1; | |
1399 | } or do { chomp(my $msg = $@); skip "shmget: $msg", 1; }; | |
09f04786 MS |
1400 | |
1401 | if (defined $id) { | |
1402 | if (shmwrite($id, $sent, 0, 60)) { | |
1403 | if (shmread($id, $rcvd, 0, 60)) { | |
1404 | substr($rcvd, index($rcvd, "\0")) = ''; | |
1405 | } else { | |
1406 | warn "# shmread failed: $!\n"; | |
1407 | } | |
1408 | } else { | |
1409 | warn "# shmwrite failed: $!\n"; | |
1410 | } | |
1411 | shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; | |
1412 | } else { | |
1413 | warn "# shmget failed: $!\n"; | |
1414 | } | |
1415 | ||
1416 | skip "SysV shared memory operation failed", 1 unless | |
1417 | $rcvd eq $sent; | |
1418 | ||
3383030d | 1419 | is_tainted($rcvd, "shmread"); |
c9f931b8 | 1420 | } |
c2e66d9e | 1421 | |
d929ce6f | 1422 | |
09f04786 MS |
1423 | # test msgrcv |
1424 | SKIP: { | |
1425 | skip "msg*() not available", 1 unless $Config{d_msg}; | |
41d6edb2 | 1426 | |
b9d1c439 | 1427 | no strict 'subs'; |
3383030d TC |
1428 | my $id; |
1429 | eval { | |
1430 | local $SIG{SYS} = sub { die "SIGSYS caught\n" }; | |
1431 | $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); | |
1432 | 1; | |
1433 | } or do { chomp(my $msg = $@); skip "msgget: $msg", 1; }; | |
41d6edb2 JH |
1434 | |
1435 | my $sent = "message"; | |
1436 | my $type_sent = 1234; | |
1437 | my $rcvd; | |
1438 | my $type_rcvd; | |
1439 | ||
1440 | if (defined $id) { | |
ddc3217d JH |
1441 | if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { |
1442 | if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { | |
41d6edb2 JH |
1443 | ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); |
1444 | } else { | |
ddc3217d | 1445 | warn "# msgrcv failed: $!\n"; |
41d6edb2 JH |
1446 | } |
1447 | } else { | |
ddc3217d | 1448 | warn "# msgsnd failed: $!\n"; |
41d6edb2 | 1449 | } |
c2e66d9e | 1450 | msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; |
41d6edb2 JH |
1451 | } else { |
1452 | warn "# msgget failed\n"; | |
1453 | } | |
1454 | ||
09f04786 MS |
1455 | SKIP: { |
1456 | skip "SysV message queue operation failed", 1 | |
1457 | unless $rcvd eq $sent && $type_sent == $type_rcvd; | |
1458 | ||
3383030d | 1459 | is_tainted($rcvd, "msgrcv"); |
41d6edb2 | 1460 | } |
41d6edb2 JH |
1461 | } |
1462 | } | |
1463 | ||
3887d568 AP |
1464 | { |
1465 | # bug id 20001004.006 | |
1466 | ||
22d7dfed | 1467 | open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; |
3887d568 | 1468 | local $/; |
22d7dfed NC |
1469 | my $a = <$fh>; |
1470 | my $b = <$fh>; | |
09f04786 | 1471 | |
f37ea7f0 NC |
1472 | is_tainted($a); |
1473 | is_tainted($b); | |
1474 | is($b, undef); | |
3887d568 | 1475 | } |
27c9684d AP |
1476 | |
1477 | { | |
1478 | # bug id 20001004.007 | |
1479 | ||
22d7dfed NC |
1480 | open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; |
1481 | my $a = <$fh>; | |
27c9684d AP |
1482 | |
1483 | my $c = { a => 42, | |
1484 | b => $a }; | |
09f04786 | 1485 | |
f37ea7f0 NC |
1486 | isnt_tainted($c->{a}); |
1487 | is_tainted($c->{b}); | |
09f04786 | 1488 | |
27c9684d AP |
1489 | |
1490 | my $d = { a => $a, | |
1491 | b => 42 }; | |
f37ea7f0 NC |
1492 | is_tainted($d->{a}); |
1493 | isnt_tainted($d->{b}); | |
09f04786 | 1494 | |
27c9684d AP |
1495 | |
1496 | my $e = { a => 42, | |
1497 | b => { c => $a, d => 42 } }; | |
f37ea7f0 NC |
1498 | isnt_tainted($e->{a}); |
1499 | isnt_tainted($e->{b}); | |
1500 | is_tainted($e->{b}->{c}); | |
1501 | isnt_tainted($e->{b}->{d}); | |
27c9684d AP |
1502 | } |
1503 | ||
b94c04ac JH |
1504 | { |
1505 | # bug id 20010519.003 | |
1506 | ||
248c32c0 JH |
1507 | BEGIN { |
1508 | use vars qw($has_fcntl); | |
1509 | eval { require Fcntl; import Fcntl; }; | |
1510 | unless ($@) { | |
1511 | $has_fcntl = 1; | |
1512 | } | |
1513 | } | |
b94c04ac | 1514 | |
09f04786 | 1515 | SKIP: { |
51e97f47 | 1516 | skip "no Fcntl", 36 unless $has_fcntl; |
09f04786 | 1517 | |
281a340f NC |
1518 | my $foo = tempfile(); |
1519 | my $evil = $foo . $TAINT; | |
248c32c0 | 1520 | |
4e74b85b NC |
1521 | is(eval { sysopen(my $ro, $evil, &O_RDONLY) }, undef); |
1522 | is($@, ''); | |
1523 | ||
1524 | violates_taint(sub { sysopen(my $wo, $evil, &O_WRONLY) }, 'sysopen'); | |
1525 | violates_taint(sub { sysopen(my $rw, $evil, &O_RDWR) }, 'sysopen'); | |
1526 | violates_taint(sub { sysopen(my $ap, $evil, &O_APPEND) }, 'sysopen'); | |
1527 | violates_taint(sub { sysopen(my $cr, $evil, &O_CREAT) }, 'sysopen'); | |
1528 | violates_taint(sub { sysopen(my $tr, $evil, &O_TRUNC) }, 'sysopen'); | |
1529 | ||
1530 | is(eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }, undef); | |
1531 | is($@, ''); | |
1532 | ||
1533 | violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }, 'sysopen'); | |
1534 | violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }, 'sysopen'); | |
1535 | violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }, 'sysopen'); | |
1536 | violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }, 'sysopen'); | |
1537 | violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }, 'sysopen'); | |
1538 | is(eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }, undef); | |
1539 | is($@, ''); | |
1540 | ||
1541 | violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }, 'sysopen'); | |
1542 | violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }, 'sysopen'); | |
1543 | violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }, 'sysopen'); | |
1544 | violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }, 'sysopen'); | |
1545 | violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }, 'sysopen'); | |
248c32c0 | 1546 | } |
b94c04ac JH |
1547 | } |
1548 | ||
65811bc3 JH |
1549 | { |
1550 | # bug 20010526.004 | |
1551 | ||
1552 | use warnings; | |
1553 | ||
09f04786 | 1554 | my $saw_warning = 0; |
c3197de1 | 1555 | local $SIG{__WARN__} = sub { ++$saw_warning }; |
65811bc3 JH |
1556 | |
1557 | sub fmi { | |
1558 | my $divnum = shift()/1; | |
1559 | sprintf("%1.1f\n", $divnum); | |
1560 | } | |
1561 | ||
1562 | fmi(21 . $TAINT); | |
1563 | fmi(37); | |
1564 | fmi(248); | |
1565 | ||
c3197de1 | 1566 | is($saw_warning, 0); |
65811bc3 JH |
1567 | } |
1568 | ||
9e1b5a4e A |
1569 | |
1570 | { | |
1571 | # Bug ID 20010730.010 | |
1572 | ||
1573 | my $i = 0; | |
1574 | ||
1575 | sub Tie::TIESCALAR { | |
1576 | my $class = shift; | |
1577 | my $arg = shift; | |
1578 | ||
1579 | bless \$arg => $class; | |
1580 | } | |
1581 | ||
1582 | sub Tie::FETCH { | |
1583 | $i ++; | |
1584 | ${$_ [0]} | |
1585 | } | |
1586 | ||
1587 | ||
1588 | package main; | |
1589 | ||
1590 | my $bar = "The Big Bright Green Pleasure Machine"; | |
1591 | taint_these $bar; | |
1592 | tie my ($foo), Tie => $bar; | |
1593 | ||
1594 | my $baz = $foo; | |
1595 | ||
09f04786 | 1596 | ok $i == 1; |
9e1b5a4e A |
1597 | } |
1598 | ||
8852b6d2 JH |
1599 | { |
1600 | # Check that all environment variables are tainted. | |
1601 | my @untainted; | |
1602 | while (my ($k, $v) = each %ENV) { | |
1603 | if (!tainted($v) && | |
eb25aaf6 HS |
1604 | # These we have explicitly untainted or set earlier. |
1605 | $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) { | |
8852b6d2 JH |
1606 | push @untainted, "# '$k' = '$v'\n"; |
1607 | } | |
1608 | } | |
c3197de1 | 1609 | is("@untainted", ""); |
8852b6d2 | 1610 | } |
9e1b5a4e A |
1611 | |
1612 | ||
433f4d03 | 1613 | is(${^TAINT}, 1, '$^TAINT is on'); |
7c36658b MS |
1614 | |
1615 | eval { ${^TAINT} = 0 }; | |
433f4d03 NC |
1616 | is(${^TAINT}, 1, '$^TAINT is not assignable'); |
1617 | like($@, qr/^Modification of a read-only value attempted/, | |
1618 | 'Assigning to ${^TAINT} fails'); | |
7c36658b | 1619 | |
e08e52cf AMS |
1620 | { |
1621 | # bug 20011111.105 | |
1622 | ||
1623 | my $re1 = qr/x$TAINT/; | |
f37ea7f0 | 1624 | is_tainted($re1); |
e08e52cf AMS |
1625 | |
1626 | my $re2 = qr/^$re1\z/; | |
f37ea7f0 | 1627 | is_tainted($re2); |
e08e52cf AMS |
1628 | |
1629 | my $re3 = "$re2"; | |
f37ea7f0 | 1630 | is_tainted($re3); |
e08e52cf | 1631 | } |
52a55424 | 1632 | |
09f04786 MS |
1633 | SKIP: { |
1634 | skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; | |
1635 | ||
52a55424 RG |
1636 | # bug 20010221.005 |
1637 | local $ENV{PATH} .= $TAINT; | |
1638 | eval { system { "echo" } "/arg0", "arg1" }; | |
c3197de1 | 1639 | like($@, qr/^Insecure \$ENV/); |
52a55424 | 1640 | } |
09f04786 MS |
1641 | |
1642 | TODO: { | |
1643 | todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 | |
1644 | if $Is_VMS; | |
1645 | ||
1646 | # bug 20020208.005 plus some single arg exec/system extras | |
8184526b NC |
1647 | violates_taint(sub { exec $TAINT, $TAINT }, 'exec'); |
1648 | violates_taint(sub { exec $TAINT $TAINT }, 'exec'); | |
1649 | violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec'); | |
1650 | violates_taint(sub { exec $TAINT 'notaint' }, 'exec'); | |
1651 | violates_taint(sub { exec {'notaint'} $TAINT }, 'exec'); | |
1652 | ||
1653 | violates_taint(sub { system $TAINT, $TAINT }, 'system'); | |
1654 | violates_taint(sub { system $TAINT $TAINT }, 'system'); | |
1655 | violates_taint(sub { system $TAINT $TAINT, $TAINT }, 'system'); | |
1656 | violates_taint(sub { system $TAINT 'notaint' }, 'system'); | |
1657 | violates_taint(sub { system {'notaint'} $TAINT }, 'system'); | |
09f04786 MS |
1658 | |
1659 | eval { | |
1660 | no warnings; | |
1661 | system("lskdfj does not exist","with","args"); | |
1662 | }; | |
c3197de1 | 1663 | is($@, ""); |
09f04786 | 1664 | |
7b903762 RGS |
1665 | eval { |
1666 | no warnings; | |
1667 | exec("lskdfj does not exist","with","args"); | |
1668 | }; | |
c3197de1 | 1669 | is($@, ""); |
6c8794e1 JH |
1670 | |
1671 | # If you add tests here update also the above skip block for VMS. | |
bbd7eb8a | 1672 | } |
a8c7c11a HS |
1673 | |
1674 | { | |
1675 | # [ID 20020704.001] taint propagation failure | |
1676 | use re 'taint'; | |
1677 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1678 | is_tainted(my $foo = $1); |
a8c7c11a | 1679 | } |
7b756e0a RGS |
1680 | |
1681 | { | |
c038024b RGS |
1682 | # [perl #24291] this used to dump core |
1683 | our %nonmagicalenv = ( PATH => "util" ); | |
7b756e0a RGS |
1684 | local *ENV = \%nonmagicalenv; |
1685 | eval { system("lskdfj"); }; | |
c3197de1 | 1686 | like($@, qr/^%ENV is aliased to another variable while running with -T switch/); |
c038024b | 1687 | local *ENV = *nonmagicalenv; |
7b756e0a | 1688 | eval { system("lskdfj"); }; |
c3197de1 | 1689 | like($@, qr/^%ENV is aliased to %nonmagicalenv while running with -T switch/); |
7b756e0a | 1690 | } |
0b4182de RD |
1691 | { |
1692 | # [perl #24248] | |
1693 | $TAINT =~ /(.*)/; | |
f37ea7f0 | 1694 | isnt_tainted($1); |
0b4182de | 1695 | my $notaint = $1; |
f37ea7f0 | 1696 | isnt_tainted($notaint); |
0b4182de RD |
1697 | |
1698 | my $l; | |
1699 | $notaint =~ /($notaint)/; | |
1700 | $l = $1; | |
f37ea7f0 NC |
1701 | isnt_tainted($1); |
1702 | isnt_tainted($l); | |
0b4182de RD |
1703 | $notaint =~ /($TAINT)/; |
1704 | $l = $1; | |
f37ea7f0 NC |
1705 | is_tainted($1); |
1706 | is_tainted($l); | |
0b4182de RD |
1707 | |
1708 | $TAINT =~ /($notaint)/; | |
1709 | $l = $1; | |
f37ea7f0 NC |
1710 | isnt_tainted($1); |
1711 | isnt_tainted($l); | |
0b4182de RD |
1712 | $TAINT =~ /($TAINT)/; |
1713 | $l = $1; | |
f37ea7f0 NC |
1714 | is_tainted($1); |
1715 | is_tainted($l); | |
0b4182de RD |
1716 | |
1717 | my $r; | |
1718 | ($r = $TAINT) =~ /($notaint)/; | |
f37ea7f0 | 1719 | isnt_tainted($1); |
0b4182de | 1720 | ($r = $TAINT) =~ /($TAINT)/; |
f37ea7f0 | 1721 | is_tainted($1); |
3511154c | 1722 | |
7fb31b92 DM |
1723 | { |
1724 | use re 'eval'; # this shouldn't make any difference | |
1725 | ($r = $TAINT) =~ /($notaint)/; | |
1726 | isnt_tainted($1); | |
1727 | ($r = $TAINT) =~ /($TAINT)/; | |
1728 | is_tainted($1); | |
1729 | } | |
1730 | ||
3511154c DM |
1731 | # [perl #24674] |
1732 | # accessing $^O shoudn't taint it as a side-effect; | |
1733 | # assigning tainted data to it is now an error | |
1734 | ||
f37ea7f0 | 1735 | isnt_tainted($^O); |
3511154c | 1736 | if (!$^X) { } elsif ($^O eq 'bar') { } |
f37ea7f0 | 1737 | isnt_tainted($^O); |
4b24804c | 1738 | local $^O; # We're going to clobber something test infrastructure depends on. |
3511154c | 1739 | eval '$^O = $^X'; |
c3197de1 | 1740 | like($@, qr/Insecure dependency in/); |
0b4182de | 1741 | } |
23634c10 AL |
1742 | |
1743 | EFFECTIVELY_CONSTANTS: { | |
1744 | my $tainted_number = 12 + $TAINT0; | |
f37ea7f0 | 1745 | is_tainted( $tainted_number ); |
23634c10 AL |
1746 | |
1747 | # Even though it's always 0, it's still tainted | |
1748 | my $tainted_product = $tainted_number * 0; | |
f37ea7f0 | 1749 | is_tainted( $tainted_product ); |
c3197de1 | 1750 | is($tainted_product, 0); |
23634c10 AL |
1751 | } |
1752 | ||
1753 | TERNARY_CONDITIONALS: { | |
1754 | my $tainted_true = $TAINT . "blah blah blah"; | |
1755 | my $tainted_false = $TAINT0; | |
f37ea7f0 NC |
1756 | is_tainted( $tainted_true ); |
1757 | is_tainted( $tainted_false ); | |
23634c10 AL |
1758 | |
1759 | my $result = $tainted_true ? "True" : "False"; | |
c3197de1 | 1760 | is($result, "True"); |
f37ea7f0 | 1761 | isnt_tainted( $result ); |
23634c10 AL |
1762 | |
1763 | $result = $tainted_false ? "True" : "False"; | |
c3197de1 | 1764 | is($result, "False"); |
f37ea7f0 | 1765 | isnt_tainted( $result ); |
23634c10 AL |
1766 | |
1767 | my $untainted_whatever = "The Fabulous Johnny Cash"; | |
1768 | my $tainted_whatever = "Soft Cell" . $TAINT; | |
1769 | ||
1770 | $result = $tainted_true ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1771 | is($result, "Soft Cell"); |
f37ea7f0 | 1772 | is_tainted( $result ); |
23634c10 AL |
1773 | |
1774 | $result = $tainted_false ? $tainted_whatever : $untainted_whatever; | |
c3197de1 | 1775 | is($result, "The Fabulous Johnny Cash"); |
f37ea7f0 | 1776 | isnt_tainted( $result ); |
23634c10 | 1777 | } |
65814f21 MS |
1778 | |
1779 | { | |
1780 | # rt.perl.org 5900 $1 remains tainted if... | |
1781 | # 1) The regular expression contains a scalar variable AND | |
1782 | # 2) The regular expression appears in an elsif clause | |
1783 | ||
1784 | my $foo = "abcdefghi" . $TAINT; | |
1785 | ||
1786 | my $valid_chars = 'a-z'; | |
1787 | if ( $foo eq '' ) { | |
1788 | } | |
1789 | elsif ( $foo =~ /([$valid_chars]+)/o ) { | |
81cba34d NC |
1790 | isnt_tainted($1); |
1791 | isnt($1, undef); | |
65814f21 MS |
1792 | } |
1793 | ||
1794 | if ( $foo eq '' ) { | |
1795 | } | |
1796 | elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { | |
81cba34d NC |
1797 | isnt_tainted($bar[0]); |
1798 | is(scalar @bar, 1); | |
65814f21 MS |
1799 | } |
1800 | } | |
0a9c116b DM |
1801 | |
1802 | # at scope exit, a restored localised value should have its old | |
1803 | # taint status, not the taint status of the current statement | |
1804 | ||
1805 | { | |
1806 | our $x99 = $^X; | |
f37ea7f0 | 1807 | is_tainted($x99); |
0a9c116b DM |
1808 | |
1809 | $x99 = ''; | |
f37ea7f0 | 1810 | isnt_tainted($x99); |
0a9c116b DM |
1811 | |
1812 | my $c = do { local $x99; $^X }; | |
f37ea7f0 | 1813 | isnt_tainted($x99); |
0a9c116b DM |
1814 | } |
1815 | { | |
1816 | our $x99 = $^X; | |
f37ea7f0 | 1817 | is_tainted($x99); |
0a9c116b DM |
1818 | |
1819 | my $c = do { local $x99; '' }; | |
f37ea7f0 | 1820 | is_tainted($x99); |
0a9c116b DM |
1821 | } |
1822 | ||
27cc343c DM |
1823 | # an mg_get of a tainted value during localization shouldn't taint the |
1824 | # statement | |
1825 | ||
1826 | { | |
1827 | eval { local $0, eval '1' }; | |
c3197de1 | 1828 | is($@, ''); |
27cc343c | 1829 | } |
e26a4975 DM |
1830 | |
1831 | # [perl #8262] //g loops infinitely on tainted data | |
1832 | ||
1833 | { | |
1834 | my @a; | |
fd69380d DM |
1835 | $a[0] = $^X . '-'; |
1836 | $a[0]=~ m/(.)/g; | |
1837 | cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)"; | |
1838 | ||
1839 | my $i = 1; | |
1840 | $a[$i] = $^X . '-'; | |
1841 | $a[$i]=~ m/(.)/g; | |
1842 | cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)"; | |
1843 | ||
1844 | my %h; | |
1845 | $h{a} = $^X . '-'; | |
1846 | $h{a}=~ m/(.)/g; | |
1847 | cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)"; | |
e26a4975 | 1848 | } |
0aa395f8 NC |
1849 | |
1850 | SKIP: | |
1851 | { | |
1852 | my $got_dualvar; | |
1853 | eval 'use Scalar::Util "dualvar"; $got_dualvar++'; | |
1854 | skip "No Scalar::Util::dualvar" unless $got_dualvar; | |
1855 | my $a = Scalar::Util::dualvar(3, $^X); | |
1856 | my $b = $a + 5; | |
1857 | is ($b, 8, "Arithmetic on tainted dualvars works"); | |
1858 | } | |
f27977c3 MH |
1859 | |
1860 | # opening '|-' should not trigger $ENV{PATH} check | |
1861 | ||
1862 | { | |
1863 | SKIP: { | |
1864 | skip "fork() is not available", 3 unless $Config{'d_fork'}; | |
1fb83d06 SS |
1865 | skip "opening |- is not stable on threaded Open/MirBSD with taint", 3 |
1866 | if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD; | |
f27977c3 MH |
1867 | |
1868 | $ENV{'PATH'} = $TAINT; | |
1869 | local $SIG{'PIPE'} = 'IGNORE'; | |
1870 | eval { | |
1871 | my $pid = open my $pipe, '|-'; | |
1872 | if (!defined $pid) { | |
1873 | die "open failed: $!"; | |
1874 | } | |
1875 | if (!$pid) { | |
1876 | kill 'KILL', $$; # child suicide | |
1877 | } | |
1878 | close $pipe; | |
1879 | }; | |
c3197de1 NC |
1880 | unlike($@, qr/Insecure \$ENV/, 'fork triggers %ENV check'); |
1881 | is($@, '', 'pipe/fork/open/close failed'); | |
f27977c3 MH |
1882 | eval { |
1883 | open my $pipe, "|$Invoke_Perl -e 1"; | |
1884 | close $pipe; | |
1885 | }; | |
c3197de1 | 1886 | like($@, qr/Insecure \$ENV/, 'popen neglects %ENV check'); |
f27977c3 MH |
1887 | } |
1888 | } | |
5d121f7f RD |
1889 | |
1890 | { | |
1891 | package AUTOLOAD_TAINT; | |
1892 | sub AUTOLOAD { | |
1893 | our $AUTOLOAD; | |
1894 | return if $AUTOLOAD =~ /DESTROY/; | |
1895 | if ($AUTOLOAD =~ /untainted/) { | |
f37ea7f0 | 1896 | main::isnt_tainted($AUTOLOAD, '$AUTOLOAD can be untainted'); |
d40bf27b | 1897 | my $copy = $AUTOLOAD; |
f37ea7f0 | 1898 | main::isnt_tainted($copy, '$AUTOLOAD can be untainted'); |
5d121f7f | 1899 | } else { |
f37ea7f0 | 1900 | main::is_tainted($AUTOLOAD, '$AUTOLOAD can be tainted'); |
d40bf27b | 1901 | my $copy = $AUTOLOAD; |
f37ea7f0 | 1902 | main::is_tainted($copy, '$AUTOLOAD can be tainted'); |
5d121f7f RD |
1903 | } |
1904 | } | |
1905 | ||
1906 | package main; | |
1907 | my $o = bless [], 'AUTOLOAD_TAINT'; | |
d40bf27b | 1908 | $o->untainted; |
5d121f7f RD |
1909 | $o->$TAINT; |
1910 | $o->untainted; | |
1911 | } | |
1912 | ||
20ee07fb RGS |
1913 | { |
1914 | # tests for tainted format in s?printf | |
e06d98fb DM |
1915 | my $fmt = $TAINT . "# %s\n"; |
1916 | violates_taint(sub { printf($fmt, "foo") }, 'printf', | |
4e74b85b | 1917 | q/printf doesn't like tainted formats/); |
e06d98fb DM |
1918 | violates_taint(sub { printf($TAINT . "# %s\n", "foo") }, 'printf', |
1919 | q/printf doesn't like tainted format expressions/); | |
20ee07fb | 1920 | eval { printf("# %s\n", $TAINT . "foo") }; |
433f4d03 | 1921 | is($@, '', q/printf accepts other tainted args/); |
e06d98fb | 1922 | violates_taint(sub { sprintf($fmt, "foo") }, 'sprintf', |
4e74b85b | 1923 | q/sprintf doesn't like tainted formats/); |
e06d98fb DM |
1924 | violates_taint(sub { sprintf($TAINT . "# %s\n", "foo") }, 'sprintf', |
1925 | q/sprintf doesn't like tainted format expressions/); | |
20ee07fb | 1926 | eval { sprintf("# %s\n", $TAINT . "foo") }; |
433f4d03 | 1927 | is($@, '', q/sprintf accepts other tainted args/); |
20ee07fb | 1928 | } |
085bde85 NC |
1929 | |
1930 | { | |
1931 | # 40708 | |
1932 | my $n = 7e9; | |
1933 | 8e9 - $n; | |
1934 | ||
1935 | my $val = $n; | |
1936 | is ($val, '7000000000', 'Assignment to untainted variable'); | |
1937 | $val = $TAINT; | |
1938 | $val = $n; | |
1939 | is ($val, '7000000000', 'Assignment to tainted variable'); | |
1940 | } | |
5e500fc8 NC |
1941 | |
1942 | { | |
5e500fc8 NC |
1943 | my $val = 0; |
1944 | my $tainted = '1' . $TAINT; | |
1945 | eval '$val = eval $tainted;'; | |
1946 | is ($val, 0, "eval doesn't like tainted strings"); | |
1947 | like ($@, qr/^Insecure dependency in eval/); | |
1948 | ||
abb7fb96 | 1949 | # Rather nice code to get a tainted undef by from Rick Delaney |
22d7dfed NC |
1950 | open my $fh, "test.pl" or die $!; |
1951 | seek $fh, 0, 2 or die $!; | |
1952 | $tainted = <$fh>; | |
5e500fc8 NC |
1953 | |
1954 | eval 'eval $tainted'; | |
1955 | like ($@, qr/^Insecure dependency in eval/); | |
1956 | } | |
beeaa6fd | 1957 | |
d3706118 NC |
1958 | foreach my $ord (78, 163, 256) { |
1959 | # 47195 | |
1960 | my $line = 'A1' . $TAINT . chr $ord; | |
1961 | chop $line; | |
1962 | is($line, 'A1'); | |
1963 | $line =~ /(A\S*)/; | |
f37ea7f0 | 1964 | isnt_tainted($1, "\\S match with chr $ord"); |
d3706118 NC |
1965 | } |
1966 | ||
ec93b65f | 1967 | { |
7139292d JR |
1968 | SKIP: { |
1969 | skip 'No crypt function, skipping crypt tests', 4 if(!$Config{d_crypt}); | |
1970 | # 59998 | |
1971 | sub cr { my $x = crypt($_[0], $_[1]); $x } | |
1972 | sub co { my $x = ~$_[0]; $x } | |
1973 | my ($a, $b); | |
1974 | $a = cr('hello', 'foo' . $TAINT); | |
1975 | $b = cr('hello', 'foo'); | |
1976 | is_tainted($a, "tainted crypt"); | |
1977 | isnt_tainted($b, "untainted crypt"); | |
1978 | $a = co('foo' . $TAINT); | |
1979 | $b = co('foo'); | |
1980 | is_tainted($a, "tainted complement"); | |
1981 | isnt_tainted($b, "untainted complement"); | |
1982 | } | |
ec93b65f CS |
1983 | } |
1984 | ||
302c0c93 NC |
1985 | { |
1986 | my @data = qw(bonk zam zlonk qunckkk); | |
1987 | # Clearly some sort of usenet bang-path | |
1988 | my $string = $TAINT . join "!", @data; | |
1989 | ||
f37ea7f0 | 1990 | is_tainted($string, "tainted data"); |
302c0c93 NC |
1991 | |
1992 | my @got = split /!|,/, $string; | |
1993 | ||
1994 | # each @got would be useful here, but I want the test for earlier perls | |
1995 | for my $i (0 .. $#data) { | |
f37ea7f0 | 1996 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
1997 | is($got[$i], $data[$i], "correct content $i"); |
1998 | } | |
1999 | ||
f37ea7f0 | 2000 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
2001 | |
2002 | my @got = split /[!,]/, $string; | |
2003 | ||
2004 | # each @got would be useful here, but I want the test for earlier perls | |
2005 | for my $i (0 .. $#data) { | |
f37ea7f0 | 2006 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
2007 | is($got[$i], $data[$i], "correct content $i"); |
2008 | } | |
2009 | ||
f37ea7f0 | 2010 | is_tainted($string, "still tainted data"); |
302c0c93 NC |
2011 | |
2012 | my @got = split /!/, $string; | |
2013 | ||
2014 | # each @got would be useful here, but I want the test for earlier perls | |
2015 | for my $i (0 .. $#data) { | |
f37ea7f0 | 2016 | is_tainted($got[$i], "tainted result $i"); |
302c0c93 NC |
2017 | is($got[$i], $data[$i], "correct content $i"); |
2018 | } | |
2019 | } | |
2020 | ||
3c4fb04a RB |
2021 | # Bug RT #52552 - broken by change at git commit id f337b08 |
2022 | { | |
2023 | my $x = $TAINT. q{print "Hello world\n"}; | |
2024 | my $y = pack "a*", $x; | |
f37ea7f0 | 2025 | is_tainted($y, "pack a* preserves tainting"); |
3c4fb04a RB |
2026 | |
2027 | my $z = pack "A*", q{print "Hello world\n"}.$TAINT; | |
f37ea7f0 | 2028 | is_tainted($z, "pack A* preserves tainting"); |
3c4fb04a RB |
2029 | |
2030 | my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; | |
f37ea7f0 | 2031 | is_tainted($zz, "pack a*a* preserves tainting"); |
3c4fb04a RB |
2032 | } |
2033 | ||
0097b436 DM |
2034 | # Bug RT #61976 tainted $! would show numeric rather than string value |
2035 | ||
2036 | { | |
2037 | my $tainted_path = substr($^X,0,0) . "/no/such/file"; | |
2038 | my $err; | |
2039 | # $! is used in a tainted expression, so gets tainted | |
2040 | open my $fh, $tainted_path or $err= "$!"; | |
2041 | unlike($err, qr/^\d+$/, 'tainted $!'); | |
2042 | } | |
2043 | ||
b112cff9 DM |
2044 | { |
2045 | # #6758: tainted values become untainted in tied hashes | |
2046 | # (also applies to other value magic such as pos) | |
2047 | ||
2048 | ||
2049 | package P6758; | |
2050 | ||
2051 | sub TIEHASH { bless {} } | |
2052 | sub TIEARRAY { bless {} } | |
2053 | ||
2054 | my $i = 0; | |
2055 | ||
2056 | sub STORE { | |
f37ea7f0 NC |
2057 | main::is_tainted($_[1], "tied arg1 tainted"); |
2058 | main::is_tainted($_[2], "tied arg2 tainted"); | |
b112cff9 DM |
2059 | $i++; |
2060 | } | |
2061 | ||
2062 | package main; | |
2063 | ||
2064 | my ($k,$v) = qw(1111 val); | |
2065 | taint_these($k,$v); | |
2066 | tie my @array, 'P6758'; | |
2067 | tie my %hash , 'P6758'; | |
2068 | $array[$k] = $v; | |
2069 | $hash{$k} = $v; | |
2070 | ok $i == 2, "tied STORE called correct number of times"; | |
2071 | } | |
2072 | ||
3e6bd4bf DM |
2073 | # Bug RT #45167 the return value of sprintf sometimes wasn't tainted |
2074 | # when the args were tainted. This only occured on the first use of | |
2075 | # sprintf; after that, its TARG has taint magic attached, so setmagic | |
2076 | # at the end works. That's why there are multiple sprintf's below, rather | |
93f09d7b | 2077 | # than just one wrapped in an inner loop. Also, any plaintext between |
3e6bd4bf DM |
2078 | # fprmat entires would correctly cause tainting to get set. so test with |
2079 | # "%s%s" rather than eg "%s %s". | |
2080 | ||
2081 | { | |
2082 | for my $var1 ($TAINT, "123") { | |
2083 | for my $var2 ($TAINT0, "456") { | |
8e29defb NC |
2084 | is( tainted(sprintf '%s', $var1, $var2), tainted($var1), |
2085 | "sprintf '%s', '$var1', '$var2'" ); | |
2086 | is( tainted(sprintf ' %s', $var1, $var2), tainted($var1), | |
2087 | "sprintf ' %s', '$var1', '$var2'" ); | |
2088 | is( tainted(sprintf '%s%s', $var1, $var2), | |
2089 | tainted($var1) || tainted($var2), | |
2090 | "sprintf '%s%s', '$var1', '$var2'" ); | |
3e6bd4bf DM |
2091 | } |
2092 | } | |
2093 | } | |
2094 | ||
2095 | ||
447ee134 DM |
2096 | # Bug RT #67962: old tainted $1 gets treated as tainted |
2097 | # in next untainted # match | |
2098 | ||
2099 | { | |
2100 | use re 'taint'; | |
2101 | "abc".$TAINT =~ /(.*)/; # make $1 tainted | |
f37ea7f0 | 2102 | is_tainted($1, '$1 should be tainted'); |
447ee134 DM |
2103 | |
2104 | my $untainted = "abcdef"; | |
f37ea7f0 | 2105 | isnt_tainted($untainted, '$untainted should be untainted'); |
447ee134 | 2106 | $untainted =~ s/(abc)/$1/; |
f37ea7f0 | 2107 | isnt_tainted($untainted, '$untainted should still be untainted'); |
447ee134 | 2108 | $untainted =~ s/(abc)/x$1/; |
f37ea7f0 | 2109 | isnt_tainted($untainted, '$untainted should yet still be untainted'); |
447ee134 DM |
2110 | } |
2111 | ||
7e6078c6 | 2112 | { |
d4456f89 JD |
2113 | # On Windows we can't spawn a fresh Perl interpreter unless at |
2114 | # least the Windows system directory (usually C:\Windows\System32) | |
2115 | # is still on the PATH. There is however no way to determine the | |
2116 | # actual path on the current system without loading the Win32 | |
2117 | # module, so we just restore the original $ENV{PATH} here. | |
2118 | local $ENV{PATH} = $ENV{PATH}; | |
2119 | $ENV{PATH} = $old_env_path if $Is_MSWin32; | |
2120 | ||
7e6078c6 NT |
2121 | fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] }, |
2122 | $TAINT = substr($^X, 0, 0); | |
00cb33d6 FC |
2123 | formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt'); |
2124 | print "ok"; | |
7e6078c6 NT |
2125 | end |
2126 | "formline survives a tainted dynamic picture"); | |
2127 | } | |
0097b436 | 2128 | |
125b9982 | 2129 | { |
f37ea7f0 | 2130 | isnt_tainted($^A, "format accumulator not tainted yet"); |
99e6ea26 | 2131 | formline('@ | @*', 'hallo' . $TAINT, 'welt'); |
f37ea7f0 | 2132 | is_tainted($^A, "tainted formline argument makes a tainted accumulator"); |
99e6ea26 | 2133 | $^A = ""; |
f37ea7f0 | 2134 | isnt_tainted($^A, "accumulator can be explicitly untainted"); |
99e6ea26 | 2135 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2136 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2137 | $^A = "" . $TAINT; |
f37ea7f0 | 2138 | is_tainted($^A, "accumulator can be explicitly tainted"); |
99e6ea26 | 2139 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2140 | is_tainted($^A, "accumulator still tainted"); |
99e6ea26 | 2141 | $^A = ""; |
f37ea7f0 | 2142 | isnt_tainted($^A, "accumulator untainted again"); |
99e6ea26 | 2143 | formline('@' .('<'*5) . ' | @*', 'hallo', 'welt'); |
f37ea7f0 | 2144 | isnt_tainted($^A, "accumulator still untainted"); |
99e6ea26 | 2145 | formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); |
f2da823f | 2146 | is_tainted($^A, "the accumulator should be tainted already"); |
f37ea7f0 | 2147 | is_tainted($^A, "tainted formline picture makes a tainted accumulator"); |
99e6ea26 NT |
2148 | } |
2149 | ||
929fffa4 KW |
2150 | { # Bug #80610 |
2151 | "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi; | |
2152 | my $a = $1; | |
2153 | my $b = $2; | |
f37ea7f0 NC |
2154 | isnt_tainted($a, "regex optimization of single char /[]/i doesn't taint"); |
2155 | isnt_tainted($b, "regex optimization of single char /[]/i doesn't taint"); | |
929fffa4 KW |
2156 | } |
2157 | ||
8985fe98 DM |
2158 | { |
2159 | # RT 81230: tainted value during FETCH created extra ref to tied obj | |
2160 | ||
2161 | package P81230; | |
2162 | use warnings; | |
2163 | ||
2164 | my %h; | |
2165 | ||
2166 | sub TIEHASH { | |
2167 | my $x = $^X; # tainted | |
2168 | bless \$x; | |
2169 | } | |
2170 | sub FETCH { my $x = $_[0]; $$x . "" } | |
2171 | ||
2172 | tie %h, 'P81230'; | |
2173 | ||
2174 | my $w = ""; | |
2175 | local $SIG{__WARN__} = sub { $w .= "@_" }; | |
2176 | ||
2177 | untie %h if $h{"k"}; | |
2178 | ||
2179 | ::is($w, "", "RT 81230"); | |
2180 | } | |
2181 | ||
5a909b52 GG |
2182 | { |
2183 | # Compiling a subroutine inside a tainted expression does not make the | |
2184 | # constant folded values tainted. | |
2185 | my $x = sub { "x" . "y" }; | |
2186 | my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression | |
2187 | my $z = $x->(); | |
f37ea7f0 | 2188 | isnt_tainted($z, "Constants folded value not tainted"); |
5a909b52 | 2189 | } |
8985fe98 | 2190 | |
9274aefd DM |
2191 | { |
2192 | # now that regexes are first class SVs, make sure that they themselves | |
2193 | # as well as references to them are tainted | |
2194 | ||
2195 | my $rr = qr/(.)$TAINT/; | |
2196 | my $r = $$rr; # bare REGEX | |
2197 | my $s ="abc"; | |
2198 | ok($s =~ s/$r/x/, "match bare regex"); | |
f37ea7f0 | 2199 | is_tainted($s, "match bare regex taint"); |
9274aefd DM |
2200 | is($s, 'xbc', "match bare regex taint value"); |
2201 | } | |
2202 | ||
0e9be77f DM |
2203 | { |
2204 | # [perl #82616] security Issues with user-defined \p{} properties | |
2205 | # A using a tainted user-defined property should croak | |
2206 | ||
2207 | sub IsA { sprintf "%02x", ord("A") } | |
2208 | ||
2209 | my $prop = "IsA"; | |
2210 | ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case"); | |
2211 | $prop = "IsA$TAINT"; | |
2212 | eval { "A" =~ /\p{$prop}/}; | |
2a53d331 | 2213 | like($@, qr/Insecure user-defined property \\p\{main::IsA}/, |
0e9be77f DM |
2214 | "user-defined property: tainted case"); |
2215 | } | |
2216 | ||
539689e7 FC |
2217 | { |
2218 | # [perl #87336] lc/uc(first) failing to taint the returned string | |
2219 | my $source = "foo$TAINT"; | |
2220 | my $dest = lc $source; | |
2221 | is_tainted $dest, "lc(tainted) taints its return value"; | |
2222 | $dest = lcfirst $source; | |
2223 | is_tainted $dest, "lcfirst(tainted) taints its return value"; | |
2224 | $dest = uc $source; | |
2225 | is_tainted $dest, "uc(tainted) taints its return value"; | |
2226 | $dest = ucfirst $source; | |
2227 | is_tainted $dest, "ucfirst(tainted) taints its return value"; | |
2228 | } | |
2229 | ||
fa22d357 VP |
2230 | { |
2231 | # Taintedness of values returned from given() | |
2232 | use feature 'switch'; | |
0f539b13 | 2233 | no warnings 'experimental::smartmatch'; |
fa22d357 VP |
2234 | |
2235 | my @descriptions = ('when', 'given end', 'default'); | |
2236 | ||
2237 | for (qw<x y z>) { | |
2238 | my $letter = "$_$TAINT"; | |
2239 | ||
2240 | my $desc = "tainted value returned from " . shift(@descriptions); | |
2241 | ||
2242 | my $res = do { | |
2243 | given ($_) { | |
2244 | when ('x') { $letter } | |
2245 | when ('y') { goto leavegiven } | |
2246 | default { $letter } | |
2247 | leavegiven: $letter | |
2248 | } | |
2249 | }; | |
2250 | is $res, $letter, "$desc is correct"; | |
2251 | is_tainted $res, "$desc stays tainted"; | |
2252 | } | |
2253 | } | |
2254 | ||
0d1104b4 NT |
2255 | |
2256 | # tainted constants and index() | |
2257 | # RT 64804; http://bugs.debian.org/291450 | |
2258 | { | |
2259 | ok(tainted $old_env_path, "initial taintedness"); | |
2260 | BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; } | |
2261 | ok(tainted C, "constant is tainted properly"); | |
2262 | ok(!tainted "", "tainting not broken yet"); | |
2263 | index(undef, C); | |
0d1104b4 NT |
2264 | ok(!tainted "", "tainting still works after index() of the constant"); |
2265 | } | |
2266 | ||
be88a5c3 FC |
2267 | # Tainted values with smartmatch |
2268 | # [perl #93590] S_do_smartmatch stealing its own string buffers | |
0f539b13 BF |
2269 | { |
2270 | no warnings 'experimental::smartmatch'; | |
be88a5c3 FC |
2271 | ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]'; |
2272 | ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]'; | |
0f539b13 | 2273 | } |
0d1104b4 | 2274 | |
5a0c33f0 FC |
2275 | # Tainted values and ref() |
2276 | for(1,2) { | |
2277 | my $x = bless \"M$TAINT", ref(bless[], "main"); | |
2278 | } | |
2279 | pass("no death when TARG of ref is tainted"); | |
2280 | ||
19db9fb7 Z |
2281 | # $$ should not be tainted by being read in a tainted expression. |
2282 | { | |
2283 | isnt_tainted $$, "PID not tainted initially"; | |
2284 | my $x = $ENV{PATH}.$$; | |
2285 | isnt_tainted $$, "PID not tainted when read in tainted expression"; | |
2286 | } | |
2287 | ||
569f7fc5 JR |
2288 | SKIP: { |
2289 | skip 'No locale testing without d_setlocale', 4 if(!$Config{d_setlocale}); | |
2290 | ||
838f2281 | 2291 | use feature 'fc'; |
5f1269ab | 2292 | use locale; |
838f2281 BF |
2293 | my ($latin1, $utf8) = ("\xDF") x 2; |
2294 | utf8::downgrade($latin1); | |
2295 | utf8::upgrade($utf8); | |
2296 | ||
2297 | is_tainted fc($latin1), "under locale, lc(latin1) taints the result"; | |
2298 | is_tainted fc($utf8), "under locale, lc(utf8) taints the result"; | |
2299 | ||
2300 | is_tainted "\F$latin1", "under locale, \\Flatin1 taints the result"; | |
2301 | is_tainted "\F$utf8", "under locale, \\Futf8 taints the result"; | |
2302 | } | |
0d1104b4 | 2303 | |
af89892e | 2304 | { # 111654 |
af89892e TC |
2305 | eval { |
2306 | eval { die "Test\n".substr($ENV{PATH}, 0, 0); }; | |
2307 | die; | |
2308 | }; | |
2309 | like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated"); | |
2310 | } | |
2311 | ||
d24ca0c5 DM |
2312 | # tainted run-time (?{}) should die |
2313 | ||
2314 | { | |
2315 | my $code = '(?{})' . $TAINT; | |
2316 | use re 'eval'; | |
2317 | eval { "a" =~ /$code/ }; | |
2318 | like($@, qr/Eval-group in insecure regular expression/, "tainted (?{})"); | |
2319 | } | |
2320 | ||
fdfdd8f7 FC |
2321 | # reset() and tainted undef (?!) |
2322 | $::x = "foo"; | |
2323 | $_ = "$TAINT".reset "x"; | |
2324 | is eval { eval $::x.1 }, 1, 'reset does not taint undef'; | |
2325 | ||
64ff300b FC |
2326 | # [perl #122669] |
2327 | is runperl( | |
2328 | switches => [ '-T' ], | |
2329 | prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; print 122669, qq-\n-', | |
2330 | stderr => 1, | |
2331 | ), "122669\n", | |
2332 | 'tainted constant as logop condition should not prevent "use"'; | |
2333 | ||
beeaa6fd NC |
2334 | # This may bomb out with the alarm signal so keep it last |
2335 | SKIP: { | |
2336 | skip "No alarm()" unless $Config{d_alarm}; | |
2337 | # Test from RT #41831] | |
2338 | # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) | |
2339 | ||
2340 | my $DATA = <<'END' . $TAINT; | |
2341 | line1 is here | |
2342 | line2 is here | |
2343 | line3 is here | |
2344 | line4 is here | |
2345 | ||
2346 | END | |
2347 | ||
2348 | #study $DATA; | |
2349 | ||
2350 | ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as | |
2351 | ## perl is stuck in a regexp infinite loop! | |
2352 | ||
2353 | alarm(10); | |
2354 | ||
2355 | if ($DATA =~ /^line2.*line4/m) { | |
2356 | fail("Should not be a match") | |
2357 | } else { | |
2358 | pass("Match on tainted multiline data should fail promptly"); | |
2359 | } | |
2360 | ||
2361 | alarm(0); | |
2362 | } | |
2363 | __END__ | |
2364 | # Keep the previous test last |