3 # Taint tests by Tom Phoenix <rootbeer@teleport.com>.
5 # I don't claim to know all about tainting. If anyone sees
6 # tests that I've missed here, please add them. But this is
7 # better than having no tests at all, right?
17 use File::Spec::Functions;
19 BEGIN { require './test.pl'; }
24 use vars qw($ipcsysv); # did we manage to load IPC::SysV?
26 my ($old_env_path, $old_env_dcl_path, $old_env_term);
28 $old_env_path = $ENV{'PATH'};
29 $old_env_dcl_path = $ENV{'DCL$PATH'};
30 $old_env_term = $ENV{'TERM'};
31 if ($^O eq 'VMS' && !defined($Config{d_setenv})) {
32 $ENV{PATH} = $ENV{PATH};
33 $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy';
35 if ($Config{'extensions'} =~ /\bIPC\/SysV\b/
36 && ($Config{d_shm} || $Config{d_msg})) {
37 eval { require IPC::SysV };
40 IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT));
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';
50 my $Is_OpenBSD = $^O eq 'openbsd';
51 my $Is_MirBSD = $^O eq 'mirbsd';
52 my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.exe' :
53 $Is_MSWin32 ? '.\perl' :
54 $Is_NetWare ? 'perl' :
56 my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/;
60 for $x ('DCL$PATH', @MoreEnv) {
61 ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x};
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.
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";
73 \@ENV{keys %old} = values %old;
74 if (defined \$old_env_dcl_path) {
75 \$ENV{'DCL\$PATH'} = \$old_env_dcl_path;
77 delete \$ENV{'DCL\$PATH'};
84 # The empty tainted value, for tainting strings
85 my $TAINT = substr($^X, 0, 0);
86 # A tainted zero, useful for tainting numbers
93 # This taints each argument passed. All must be lvalues.
94 # Side effect: It also stringifies them. :-(
96 for (@_) { $_ .= $TAINT }
99 # How to identify taint when you see it
100 sub any_tainted (@) {
101 not eval { join("",@_), kill 0; 1 };
106 sub all_tainted (@) {
107 for (@_) { return 0 unless tainted $_ }
115 my $curr_test = curr_test();
118 print "ok $curr_test\n";
120 print "not ok $curr_test\n";
121 printf "# Failed test at line %d\n", (caller)[2];
122 for (split m/^/m, $diag) {
127 or substr($diag, -1) eq "\n";
136 # We need an external program to call.
137 my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$"));
139 open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
140 print PROG 'print "@ARGV\n"', "\n";
142 my $echo = "$Invoke_Perl $ECHO";
144 my $TEST = catfile(curdir(), 'TEST');
146 # First, let's make sure that Perl is checking the dangerous
147 # environment variables. Maybe they aren't set yet, so we'll
148 # taint them ourselves.
150 $ENV{'DCL$PATH'} = '' if $Is_VMS;
152 if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') {
154 foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
155 if (-f "$dir/cc3250mt.dll") {
156 $bcc_dir = $dir and last;
159 if (defined $bcc_dir) {
161 File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or
162 die "$0: failed to copy cc3250mt.dll: $!\n";
164 END { unlink "cc3250mt.dll" }
168 $ENV{PATH} = ($Is_Cygwin) ? '/usr/bin' : '';
169 delete @ENV{@MoreEnv};
172 test eval { `$echo 1` } eq "1\n";
175 skip "Environment tainting tests skipped", 4
176 if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos;
178 my @vars = ('PATH', @MoreEnv);
179 while (my $v = $vars[0]) {
180 local $ENV{$v} = $TAINT;
181 last if eval { `$echo 1` };
182 last unless $@ =~ /^Insecure \$ENV{$v}/;
185 test !@vars, "@vars";
187 # tainted $TERM is unsafe only if it contains metachars
189 $ENV{TERM} = 'e=mc2';
190 test eval { `$echo 1` } eq "1\n";
191 $ENV{TERM} = 'e=mc2' . $TAINT;
192 test !eval { `$echo 1` };
193 test $@ =~ /^Insecure \$ENV{TERM}/, $@;
197 if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) {
198 print "# all directories are writeable\n";
201 $tmp = (grep { defined and -d and (stat _)[2] & 2 }
202 qw(sys$scratch /tmp /var/tmp /usr/tmp),
203 @ENV{qw(TMP TEMP)})[0]
204 or print "# can't find world-writeable directory to test PATH\n";
208 skip "all directories are writeable", 2 unless $tmp;
210 local $ENV{PATH} = $tmp;
211 test !eval { `$echo 1` };
212 test $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
216 skip "This is not VMS", 4 unless $Is_VMS;
218 $ENV{'DCL$PATH'} = $TAINT;
219 test eval { `$echo 1` } eq '';
220 test $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
222 skip q[can't find world-writeable directory to test DCL$PATH], 2
225 $ENV{'DCL$PATH'} = $tmp;
226 test eval { `$echo 1` } eq '';
227 test $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@;
229 $ENV{'DCL$PATH'} = '';
233 # Let's see that we can taint and untaint as needed.
238 # That was a sanity check. If it failed, stop the insanity!
239 die "Taint checks don't seem to be enabled" unless tainted $foo;
242 test not tainted $foo;
248 test not any_tainted @list;
249 taint_these @list[1,3,5,7,9];
250 test any_tainted @list;
251 test all_tainted @list[1,3,5,7,9];
252 test not any_tainted @list[0,2,4,6,8];
254 ($foo) = $foo =~ /(.+)/;
255 test not tainted $foo;
257 my ($desc, $s, $res, $res2, $one);
259 $desc = "match with string tainted";
261 $s = 'abcd' . $TAINT;
264 ok( tainted($s), "$desc: s tainted");
265 ok(!tainted($res), "$desc: res not tainted");
266 ok(!tainted($one), "$desc: \$1 not tainted");
267 is($res, 1, "$desc: res value");
268 is($one, 'abcd', "$desc: \$1 value");
270 $desc = "match /g with string tainted";
272 $s = 'abcd' . $TAINT;
275 ok( tainted($s), "$desc: s tainted");
276 ok(!tainted($res), "$desc: res not tainted");
277 ok(!tainted($one), "$desc: \$1 not tainted");
278 is($res, 1, "$desc: res value");
279 is($one, 'a', "$desc: \$1 value");
281 $desc = "match with string tainted, list cxt";
283 $s = 'abcd' . $TAINT;
284 ($res) = $s =~ /(.+)/;
286 ok( tainted($s), "$desc: s tainted");
287 ok(!tainted($res), "$desc: res not tainted");
288 ok(!tainted($one), "$desc: \$1 not tainted");
289 is($res, 'abcd', "$desc: res value");
290 is($one, 'abcd', "$desc: \$1 value");
292 $desc = "match /g with string tainted, list cxt";
294 $s = 'abcd' . $TAINT;
295 ($res, $res2) = $s =~ /(.)/g;
297 ok( tainted($s), "$desc: s tainted");
298 ok(!tainted($res), "$desc: res not tainted");
299 ok(!tainted($res2),"$desc: res2 not tainted");
300 ok(!tainted($one), "$desc: \$1 not tainted");
301 is($res, 'a', "$desc: res value");
302 is($res2,'b', "$desc: res2 value");
303 is($one, 'd', "$desc: \$1 value");
305 $desc = "match with pattern tainted";
308 $res = $s =~ /$TAINT(.+)/;
310 ok(!tainted($s), "$desc: s not tainted");
311 ok(!tainted($res), "$desc: res not tainted");
312 ok( tainted($one), "$desc: \$1 tainted");
313 is($res, 1, "$desc: res value");
314 is($one, 'abcd', "$desc: \$1 value");
316 $desc = "match /g with pattern tainted";
319 $res = $s =~ /$TAINT(.)/g;
321 ok(!tainted($s), "$desc: s not tainted");
322 ok(!tainted($res), "$desc: res not tainted");
323 ok( tainted($one), "$desc: \$1 tainted");
324 is($res, 1, "$desc: res value");
325 is($one, 'a', "$desc: \$1 value");
327 $desc = "match with pattern tainted via locale";
330 { use locale; $res = $s =~ /(\w+)/; $one = $1; }
331 ok(!tainted($s), "$desc: s not tainted");
332 ok(!tainted($res), "$desc: res not tainted");
333 ok( tainted($one), "$desc: \$1 tainted");
334 is($res, 1, "$desc: res value");
335 is($one, 'abcd', "$desc: \$1 value");
337 $desc = "match /g with pattern tainted via locale";
340 { use locale; $res = $s =~ /(\w)/g; $one = $1; }
341 ok(!tainted($s), "$desc: s not tainted");
342 ok(!tainted($res), "$desc: res not tainted");
343 ok( tainted($one), "$desc: \$1 tainted");
344 is($res, 1, "$desc: res value");
345 is($one, 'a', "$desc: \$1 value");
347 $desc = "match with pattern tainted, list cxt";
350 ($res) = $s =~ /$TAINT(.+)/;
352 ok(!tainted($s), "$desc: s not tainted");
353 ok( tainted($res), "$desc: res tainted");
354 ok( tainted($one), "$desc: \$1 tainted");
355 is($res, 'abcd', "$desc: res value");
356 is($one, 'abcd', "$desc: \$1 value");
358 $desc = "match /g with pattern tainted, list cxt";
361 ($res, $res2) = $s =~ /$TAINT(.)/g;
363 ok(!tainted($s), "$desc: s not tainted");
364 ok( tainted($res), "$desc: res tainted");
365 ok( tainted($one), "$desc: \$1 tainted");
366 is($res, 'a', "$desc: res value");
367 is($res2,'b', "$desc: res2 value");
368 is($one, 'd', "$desc: \$1 value");
370 $desc = "match with pattern tainted via locale, list cxt";
373 { use locale; ($res) = $s =~ /(\w+)/; $one = $1; }
374 ok(!tainted($s), "$desc: s not tainted");
375 ok( tainted($res), "$desc: res tainted");
376 ok( tainted($one), "$desc: \$1 tainted");
377 is($res, 'abcd', "$desc: res value");
378 is($one, 'abcd', "$desc: \$1 value");
380 $desc = "match /g with pattern tainted via locale, list cxt";
383 { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; }
384 ok(!tainted($s), "$desc: s not tainted");
385 ok( tainted($res), "$desc: res tainted");
386 ok( tainted($res2),"$desc: res2 tainted");
387 ok( tainted($one), "$desc: \$1 tainted");
388 is($res, 'a', "$desc: res value");
389 is($res2,'b', "$desc: res2 value");
390 is($one, 'd', "$desc: \$1 value");
392 $desc = "substitution with string tainted";
394 $s = 'abcd' . $TAINT;
395 $res = $s =~ s/(.+)/xyz/;
397 ok( tainted($s), "$desc: s tainted");
398 ok(!tainted($res), "$desc: res not tainted");
399 ok(!tainted($one), "$desc: \$1 not tainted");
400 is($s, 'xyz', "$desc: s value");
401 is($res, 1, "$desc: res value");
402 is($one, 'abcd', "$desc: \$1 value");
404 $desc = "substitution /g with string tainted";
406 $s = 'abcd' . $TAINT;
407 $res = $s =~ s/(.)/x/g;
409 ok( tainted($s), "$desc: s tainted");
410 ok( tainted($res), "$desc: res tainted");
411 ok(!tainted($one), "$desc: \$1 not tainted");
412 is($s, 'xxxx', "$desc: s value");
413 is($res, 4, "$desc: res value");
414 is($one, 'd', "$desc: \$1 value");
416 $desc = "substitution /r with string tainted";
418 $s = 'abcd' . $TAINT;
419 $res = $s =~ s/(.+)/xyz/r;
421 ok( tainted($s), "$desc: s tainted");
422 ok( tainted($res), "$desc: res tainted");
423 ok(!tainted($one), "$desc: \$1 not tainted");
424 is($s, 'abcd', "$desc: s value");
425 is($res, 'xyz', "$desc: res value");
426 is($one, 'abcd', "$desc: \$1 value");
428 $desc = "substitution /e with string tainted";
430 $s = 'abcd' . $TAINT;
432 $res = $s =~ s{(.+)}{
433 $one = $one . "x"; # make sure code not tainted
434 ok(!tainted($one), "$desc: code not tainted within /e");
436 ok(!tainted($one), "$desc: \$1 not tainted within /e");
440 ok( tainted($s), "$desc: s tainted");
441 ok(!tainted($res), "$desc: res not tainted");
442 ok(!tainted($one), "$desc: \$1 not tainted");
443 is($s, 'xyz', "$desc: s value");
444 is($res, 1, "$desc: res value");
445 is($one, 'abcd', "$desc: \$1 value");
447 $desc = "substitution with pattern tainted";
450 $res = $s =~ s/$TAINT(.+)/xyz/;
452 ok( tainted($s), "$desc: s tainted");
453 ok(!tainted($res), "$desc: res not tainted");
454 ok( tainted($one), "$desc: \$1 tainted");
455 is($s, 'xyz', "$desc: s value");
456 is($res, 1, "$desc: res value");
457 is($one, 'abcd', "$desc: \$1 value");
459 $desc = "substitution /g with pattern tainted";
462 $res = $s =~ s/$TAINT(.)/x/g;
464 ok( tainted($s), "$desc: s tainted");
465 ok( tainted($res), "$desc: res tainted");
466 ok( tainted($one), "$desc: \$1 tainted");
467 is($s, 'xxxx', "$desc: s value");
468 is($res, 4, "$desc: res value");
469 is($one, 'd', "$desc: \$1 value");
471 $desc = "substitution /ge with pattern tainted";
477 $res = $s =~ s{(.)$TAINT}{
478 $j = $i; # make sure code not tainted
480 ok(!tainted($j), "$desc: code not tainted within /e");
483 ok(!tainted($s), "$desc: s not tainted loop 1");
486 ok( tainted($s), "$desc: s tainted loop $i");
488 ok( tainted($one), "$desc: \$1 tainted loop $i");
493 ok( tainted($s), "$desc: s tainted");
494 ok( tainted($res), "$desc: res tainted");
495 ok( tainted($one), "$desc: \$1 tainted");
496 is($s, '123', "$desc: s value");
497 is($res, 3, "$desc: res value");
498 is($one, 'c', "$desc: \$1 value");
500 $desc = "substitution /r with pattern tainted";
503 $res = $s =~ s/$TAINT(.+)/xyz/r;
505 ok(!tainted($s), "$desc: s not tainted");
506 ok( tainted($res), "$desc: res tainted");
507 ok( tainted($one), "$desc: \$1 tainted");
508 is($s, 'abcd', "$desc: s value");
509 is($res, 'xyz', "$desc: res value");
510 is($one, 'abcd', "$desc: \$1 value");
512 $desc = "substitution with pattern tainted via locale";
515 { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; }
516 ok( tainted($s), "$desc: s tainted");
517 ok(!tainted($res), "$desc: res not tainted");
518 ok( 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");
523 $desc = "substitution /g with pattern tainted via locale";
526 { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; }
527 ok( tainted($s), "$desc: s tainted");
528 ok( tainted($res), "$desc: res tainted");
529 ok( tainted($one), "$desc: \$1 tainted");
530 is($s, 'xxxx', "$desc: s value");
531 is($res, 4, "$desc: res value");
532 is($one, 'd', "$desc: \$1 value");
534 $desc = "substitution /r with pattern tainted via locale";
537 { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
538 ok(!tainted($s), "$desc: s not tainted");
539 ok( tainted($res), "$desc: res tainted");
540 ok( tainted($one), "$desc: \$1 tainted");
541 is($s, 'abcd', "$desc: s value");
542 is($res, 'xyz', "$desc: res value");
543 is($one, 'abcd', "$desc: \$1 value");
545 $desc = "substitution with replacement tainted";
548 $res = $s =~ s/(.+)/xyz$TAINT/;
550 ok( tainted($s), "$desc: s tainted");
551 ok(!tainted($res), "$desc: res not tainted");
552 ok(!tainted($one), "$desc: \$1 not tainted");
553 is($s, 'xyz', "$desc: s value");
554 is($res, 1, "$desc: res value");
555 is($one, 'abcd', "$desc: \$1 value");
557 $desc = "substitution /g with replacement tainted";
560 $res = $s =~ s/(.)/x$TAINT/g;
562 ok( tainted($s), "$desc: s tainted");
563 ok(!tainted($res), "$desc: res not tainted");
564 ok(!tainted($one), "$desc: \$1 not tainted");
565 is($s, 'xxxx', "$desc: s value");
566 is($res, 4, "$desc: res value");
567 is($one, 'd', "$desc: \$1 value");
569 $desc = "substitution /ge with replacement tainted";
576 $j = $i; # make sure code not tainted
578 ok(!tainted($j), "$desc: code not tainted within /e");
581 ok(!tainted($s), "$desc: s not tainted loop 1");
584 ok( tainted($s), "$desc: s tainted loop $i");
586 ok(!tainted($one), "$desc: \$1 not tainted within /e");
591 ok( tainted($s), "$desc: s tainted");
592 ok( tainted($res), "$desc: res tainted");
593 ok(!tainted($one), "$desc: \$1 not tainted");
594 is($s, '123', "$desc: s value");
595 is($res, 3, "$desc: res value");
596 is($one, 'c', "$desc: \$1 value");
598 $desc = "substitution /r with replacement tainted";
601 $res = $s =~ s/(.+)/xyz$TAINT/r;
603 ok(!tainted($s), "$desc: s not tainted");
604 ok( tainted($res), "$desc: res tainted");
605 ok(!tainted($one), "$desc: \$1 not tainted");
606 is($s, 'abcd', "$desc: s value");
607 is($res, 'xyz', "$desc: res value");
608 is($one, 'abcd', "$desc: \$1 value");
611 # now do them all again with "use re 'taint"
615 $desc = "use re 'taint': match with string tainted";
617 $s = 'abcd' . $TAINT;
620 ok( tainted($s), "$desc: s tainted");
621 ok(!tainted($res), "$desc: res not tainted");
622 ok( tainted($one), "$desc: \$1 tainted");
623 is($res, 1, "$desc: res value");
624 is($one, 'abcd', "$desc: \$1 value");
626 $desc = "use re 'taint': match /g with string tainted";
628 $s = 'abcd' . $TAINT;
631 ok( tainted($s), "$desc: s tainted");
632 ok(!tainted($res), "$desc: res not tainted");
633 ok( tainted($one), "$desc: \$1 tainted");
634 is($res, 1, "$desc: res value");
635 is($one, 'a', "$desc: \$1 value");
637 $desc = "use re 'taint': match with string tainted, list cxt";
639 $s = 'abcd' . $TAINT;
640 ($res) = $s =~ /(.+)/;
642 ok( tainted($s), "$desc: s tainted");
643 ok( tainted($res), "$desc: res tainted");
644 ok( tainted($one), "$desc: \$1 tainted");
645 is($res, 'abcd', "$desc: res value");
646 is($one, 'abcd', "$desc: \$1 value");
648 $desc = "use re 'taint': match /g with string tainted, list cxt";
650 $s = 'abcd' . $TAINT;
651 ($res, $res2) = $s =~ /(.)/g;
653 ok( tainted($s), "$desc: s tainted");
654 ok( tainted($res), "$desc: res tainted");
655 ok( tainted($res2),"$desc: res2 tainted");
656 ok( tainted($one), "$desc: \$1 not tainted");
657 is($res, 'a', "$desc: res value");
658 is($res2,'b', "$desc: res2 value");
659 is($one, 'd', "$desc: \$1 value");
661 $desc = "use re 'taint': match with pattern tainted";
664 $res = $s =~ /$TAINT(.+)/;
666 ok(!tainted($s), "$desc: s not tainted");
667 ok(!tainted($res), "$desc: res not tainted");
668 ok( tainted($one), "$desc: \$1 tainted");
669 is($res, 1, "$desc: res value");
670 is($one, 'abcd', "$desc: \$1 value");
672 $desc = "use re 'taint': match /g with pattern tainted";
675 $res = $s =~ /$TAINT(.)/g;
677 ok(!tainted($s), "$desc: s not tainted");
678 ok(!tainted($res), "$desc: res not tainted");
679 ok( tainted($one), "$desc: \$1 tainted");
680 is($res, 1, "$desc: res value");
681 is($one, 'a', "$desc: \$1 value");
683 $desc = "use re 'taint': match with pattern tainted via locale";
686 { use locale; $res = $s =~ /(\w+)/; $one = $1; }
687 ok(!tainted($s), "$desc: s not tainted");
688 ok(!tainted($res), "$desc: res not tainted");
689 ok( tainted($one), "$desc: \$1 tainted");
690 is($res, 1, "$desc: res value");
691 is($one, 'abcd', "$desc: \$1 value");
693 $desc = "use re 'taint': match /g with pattern tainted via locale";
696 { use locale; $res = $s =~ /(\w)/g; $one = $1; }
697 ok(!tainted($s), "$desc: s not tainted");
698 ok(!tainted($res), "$desc: res not tainted");
699 ok( tainted($one), "$desc: \$1 tainted");
700 is($res, 1, "$desc: res value");
701 is($one, 'a', "$desc: \$1 value");
703 $desc = "use re 'taint': match with pattern tainted, list cxt";
706 ($res) = $s =~ /$TAINT(.+)/;
708 ok(!tainted($s), "$desc: s not tainted");
709 ok( tainted($res), "$desc: res tainted");
710 ok( tainted($one), "$desc: \$1 tainted");
711 is($res, 'abcd', "$desc: res value");
712 is($one, 'abcd', "$desc: \$1 value");
714 $desc = "use re 'taint': match /g with pattern tainted, list cxt";
717 ($res, $res2) = $s =~ /$TAINT(.)/g;
719 ok(!tainted($s), "$desc: s not tainted");
720 ok( tainted($res), "$desc: res tainted");
721 ok( tainted($one), "$desc: \$1 tainted");
722 is($res, 'a', "$desc: res value");
723 is($res2,'b', "$desc: res2 value");
724 is($one, 'd', "$desc: \$1 value");
726 $desc = "use re 'taint': match with pattern tainted via locale, list cxt";
729 { use locale; ($res) = $s =~ /(\w+)/; $one = $1; }
730 ok(!tainted($s), "$desc: s not tainted");
731 ok( tainted($res), "$desc: res tainted");
732 ok( tainted($one), "$desc: \$1 tainted");
733 is($res, 'abcd', "$desc: res value");
734 is($one, 'abcd', "$desc: \$1 value");
736 $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt";
739 { use locale; ($res, $res2) = $s =~ /(\w)/g; $one = $1; }
740 ok(!tainted($s), "$desc: s not tainted");
741 ok( tainted($res), "$desc: res tainted");
742 ok( tainted($res2),"$desc: res2 tainted");
743 ok( tainted($one), "$desc: \$1 tainted");
744 is($res, 'a', "$desc: res value");
745 is($res2,'b', "$desc: res2 value");
746 is($one, 'd', "$desc: \$1 value");
748 $desc = "use re 'taint': substitution with string tainted";
750 $s = 'abcd' . $TAINT;
751 $res = $s =~ s/(.+)/xyz/;
753 ok( tainted($s), "$desc: s tainted");
754 ok(!tainted($res), "$desc: res not tainted");
755 ok( tainted($one), "$desc: \$1 tainted");
756 is($s, 'xyz', "$desc: s value");
757 is($res, 1, "$desc: res value");
758 is($one, 'abcd', "$desc: \$1 value");
760 $desc = "use re 'taint': substitution /g with string tainted";
762 $s = 'abcd' . $TAINT;
763 $res = $s =~ s/(.)/x/g;
765 ok( tainted($s), "$desc: s tainted");
766 ok( tainted($res), "$desc: res tainted");
767 ok( tainted($one), "$desc: \$1 tainted");
768 is($s, 'xxxx', "$desc: s value");
769 is($res, 4, "$desc: res value");
770 is($one, 'd', "$desc: \$1 value");
772 $desc = "use re 'taint': substitution /r with string tainted";
774 $s = 'abcd' . $TAINT;
775 $res = $s =~ s/(.+)/xyz/r;
777 ok( tainted($s), "$desc: s tainted");
778 ok( tainted($res), "$desc: res tainted");
779 ok( tainted($one), "$desc: \$1 tainted");
780 is($s, 'abcd', "$desc: s value");
781 is($res, 'xyz', "$desc: res value");
782 is($one, 'abcd', "$desc: \$1 value");
784 $desc = "use re 'taint': substitution /e with string tainted";
786 $s = 'abcd' . $TAINT;
788 $res = $s =~ s{(.+)}{
789 $one = $one . "x"; # make sure code not tainted
790 ok(!tainted($one), "$desc: code not tainted within /e");
792 ok(tainted($one), "$desc: $1 tainted within /e");
796 ok( tainted($s), "$desc: s tainted");
797 ok(!tainted($res), "$desc: res not tainted");
798 ok( tainted($one), "$desc: \$1 tainted");
799 is($s, 'xyz', "$desc: s value");
800 is($res, 1, "$desc: res value");
801 is($one, 'abcd', "$desc: \$1 value");
803 $desc = "use re 'taint': substitution with pattern tainted";
806 $res = $s =~ s/$TAINT(.+)/xyz/;
808 ok( tainted($s), "$desc: s tainted");
809 ok(!tainted($res), "$desc: res not tainted");
810 ok( tainted($one), "$desc: \$1 tainted");
811 is($s, 'xyz', "$desc: s value");
812 is($res, 1, "$desc: res value");
813 is($one, 'abcd', "$desc: \$1 value");
815 $desc = "use re 'taint': substitution /g with pattern tainted";
818 $res = $s =~ s/$TAINT(.)/x/g;
820 ok( tainted($s), "$desc: s tainted");
821 ok( tainted($res), "$desc: res tainted");
822 ok( tainted($one), "$desc: \$1 tainted");
823 is($s, 'xxxx', "$desc: s value");
824 is($res, 4, "$desc: res value");
825 is($one, 'd', "$desc: \$1 value");
827 $desc = "use re 'taint': substitution /ge with pattern tainted";
833 $res = $s =~ s{(.)$TAINT}{
834 $j = $i; # make sure code not tainted
836 ok(!tainted($j), "$desc: code not tainted within /e");
839 ok(!tainted($s), "$desc: s not tainted loop 1");
842 ok( tainted($s), "$desc: s tainted loop $i");
844 ok( tainted($one), "$desc: \$1 tainted loop $i");
849 ok( tainted($s), "$desc: s tainted");
850 ok( tainted($res), "$desc: res tainted");
851 ok( tainted($one), "$desc: \$1 tainted");
852 is($s, '123', "$desc: s value");
853 is($res, 3, "$desc: res value");
854 is($one, 'c', "$desc: \$1 value");
857 $desc = "use re 'taint': substitution /r with pattern tainted";
860 $res = $s =~ s/$TAINT(.+)/xyz/r;
862 ok(!tainted($s), "$desc: s not tainted");
863 ok( tainted($res), "$desc: res tainted");
864 ok( tainted($one), "$desc: \$1 tainted");
865 is($s, 'abcd', "$desc: s value");
866 is($res, 'xyz', "$desc: res value");
867 is($one, 'abcd', "$desc: \$1 value");
869 $desc = "use re 'taint': substitution with pattern tainted via locale";
872 { use locale; $res = $s =~ s/(\w+)/xyz/; $one = $1; }
873 ok( tainted($s), "$desc: s tainted");
874 ok(!tainted($res), "$desc: res not tainted");
875 ok( tainted($one), "$desc: \$1 tainted");
876 is($s, 'xyz', "$desc: s value");
877 is($res, 1, "$desc: res value");
878 is($one, 'abcd', "$desc: \$1 value");
880 $desc = "use re 'taint': substitution /g with pattern tainted via locale";
883 { use locale; $res = $s =~ s/(\w)/x/g; $one = $1; }
884 ok( tainted($s), "$desc: s tainted");
885 ok( tainted($res), "$desc: res tainted");
886 ok( tainted($one), "$desc: \$1 tainted");
887 is($s, 'xxxx', "$desc: s value");
888 is($res, 4, "$desc: res value");
889 is($one, 'd', "$desc: \$1 value");
891 $desc = "use re 'taint': substitution /r with pattern tainted via locale";
894 { use locale; $res = $s =~ s/(\w+)/xyz/r; $one = $1; }
895 ok(!tainted($s), "$desc: s not tainted");
896 ok( tainted($res), "$desc: res tainted");
897 ok( tainted($one), "$desc: \$1 tainted");
898 is($s, 'abcd', "$desc: s value");
899 is($res, 'xyz', "$desc: res value");
900 is($one, 'abcd', "$desc: \$1 value");
902 $desc = "use re 'taint': substitution with replacement tainted";
905 $res = $s =~ s/(.+)/xyz$TAINT/;
907 ok( tainted($s), "$desc: s tainted");
908 ok(!tainted($res), "$desc: res not tainted");
909 ok(!tainted($one), "$desc: \$1 not tainted");
910 is($s, 'xyz', "$desc: s value");
911 is($res, 1, "$desc: res value");
912 is($one, 'abcd', "$desc: \$1 value");
914 $desc = "use re 'taint': substitution /g with replacement tainted";
917 $res = $s =~ s/(.)/x$TAINT/g;
919 ok( tainted($s), "$desc: s tainted");
920 ok(!tainted($res), "$desc: res not tainted");
921 ok(!tainted($one), "$desc: \$1 not tainted");
922 is($s, 'xxxx', "$desc: s value");
923 is($res, 4, "$desc: res value");
924 is($one, 'd', "$desc: \$1 value");
926 $desc = "use re 'taint': substitution /ge with replacement tainted";
933 $j = $i; # make sure code not tainted
935 ok(!tainted($j), "$desc: code not tainted within /e");
938 ok(!tainted($s), "$desc: s not tainted loop 1");
941 ok( tainted($s), "$desc: s tainted loop $i");
943 ok(!tainted($one), "$desc: \$1 not tainted");
948 ok( tainted($s), "$desc: s tainted");
949 ok( tainted($res), "$desc: res tainted");
950 ok(!tainted($one), "$desc: \$1 not tainted");
951 is($s, '123', "$desc: s value");
952 is($res, 3, "$desc: res value");
953 is($one, 'c', "$desc: \$1 value");
955 $desc = "use re 'taint': substitution /r with replacement tainted";
958 $res = $s =~ s/(.+)/xyz$TAINT/r;
960 ok(!tainted($s), "$desc: s not tainted");
961 ok( tainted($res), "$desc: res tainted");
962 ok(!tainted($one), "$desc: \$1 not tainted");
963 is($s, 'abcd', "$desc: s value");
964 is($res, 'xyz', "$desc: res value");
965 is($one, 'abcd', "$desc: \$1 value");
968 $foo = $1 if 'bar' =~ /(.+)$TAINT/;
972 my $pi = 4 * atan2(1,1) + $TAINT0;
975 ($pi) = $pi =~ /(\d+\.\d+)/;
976 test not tainted $pi;
977 test sprintf("%.5f", $pi) eq '3.14159';
980 # How about command-line arguments? The problem is that we don't
981 # always get some, so we'll run another process with some.
983 my $arg = tempfile();
984 open PROG, "> $arg" or die "Can't create $arg: $!";
986 eval { join('', @ARGV), kill 0 };
987 exit 0 if $@ =~ /^Insecure dependency/;
988 print "# Oops: \$@ was [$@]\n";
992 print `$Invoke_Perl "-T" $arg and some suspect arguments`;
993 test !$?, "Exited with status $?";
997 # Reading from a file should be tainted
999 test open(FILE, $TEST), "Couldn't open '$TEST': $!";
1002 sysread(FILE, $block, 100);
1005 test tainted $block;
1009 # Globs should be forbidden, except under VMS,
1010 # which doesn't spawn an external program.
1012 skip "globs should be forbidden", 2 if 1 or $Is_VMS;
1014 my @globs = eval { <*> };
1015 test @globs == 0 && $@ =~ /^Insecure dependency/;
1017 @globs = eval { glob '*' };
1018 test @globs == 0 && $@ =~ /^Insecure dependency/;
1021 # Output of commands should be tainted
1023 my $foo = `$echo abc`;
1027 # Certain system variables should be tainted
1029 test all_tainted $^X, $0;
1032 # Results of matching should all be untainted
1034 my $foo = "abcdefghi" . $TAINT;
1038 test not any_tainted $`, $&, $';
1040 $foo =~ /(...)(...)(...)/;
1041 test not any_tainted $1, $2, $3, $+;
1043 my @bar = $foo =~ /(...)(...)(...)/;
1044 test not any_tainted @bar;
1046 test tainted $foo; # $foo should still be tainted!
1047 test $foo eq "abcdefghi";
1050 # Operations which affect files can't use tainted data.
1052 test !eval { chmod 0, $TAINT }, 'chmod';
1053 test $@ =~ /^Insecure dependency/, $@;
1055 # There is no feature test in $Config{} for truncate,
1056 # so we allow for the possibility that it's missing.
1057 test !eval { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate';
1058 test $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
1060 test !eval { rename '', $TAINT }, 'rename';
1061 test $@ =~ /^Insecure dependency/, $@;
1063 test !eval { unlink $TAINT }, 'unlink';
1064 test $@ =~ /^Insecure dependency/, $@;
1066 test !eval { utime $TAINT }, 'utime';
1067 test $@ =~ /^Insecure dependency/, $@;
1070 skip "chown() is not available", 2 unless $Config{d_chown};
1072 test !eval { chown -1, -1, $TAINT }, 'chown';
1073 test $@ =~ /^Insecure dependency/, $@;
1077 skip "link() is not available", 2 unless $Config{d_link};
1079 test !eval { link $TAINT, '' }, 'link';
1080 test $@ =~ /^Insecure dependency/, $@;
1084 skip "symlink() is not available", 2 unless $Config{d_symlink};
1086 test !eval { symlink $TAINT, '' }, 'symlink';
1087 test $@ =~ /^Insecure dependency/, $@;
1091 # Operations which affect directories can't use tainted data.
1093 test !eval { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir';
1094 test $@ =~ /^Insecure dependency/, $@;
1096 test !eval { rmdir $TAINT }, 'rmdir';
1097 test $@ =~ /^Insecure dependency/, $@;
1099 test !eval { chdir "foo".$TAINT }, 'chdir';
1100 test $@ =~ /^Insecure dependency/, $@;
1103 skip "chroot() is not available", 2 unless $Config{d_chroot};
1105 test !eval { chroot $TAINT }, 'chroot';
1106 test $@ =~ /^Insecure dependency/, $@;
1110 # Some operations using files can't use tainted data.
1112 my $foo = "imaginary library" . $TAINT;
1113 test !eval { require $foo }, 'require';
1114 test $@ =~ /^Insecure dependency/, $@;
1116 my $filename = tempfile(); # NB: $filename isn't tainted!
1117 $foo = $filename . $TAINT;
1118 unlink $filename; # in any case
1120 test !eval { open FOO, $foo }, 'open for read';
1121 test $@ eq '', $@; # NB: This should be allowed
1123 # Try first new style but allow also old style.
1124 # We do not want the whole taint.t to fail
1125 # just because Errno possibly failing.
1126 test eval('$!{ENOENT}') ||
1127 $! == 2 || # File not found
1128 ($Is_Dos && $! == 22);
1130 test !eval { open FOO, "> $foo" }, 'open for write';
1131 test $@ =~ /^Insecure dependency/, $@;
1134 # Commands to the system can't use tainted data
1139 skip "open('|') is not available", 4 if $^O eq 'amigaos';
1141 test !eval { open FOO, "| x$foo" }, 'popen to';
1142 test $@ =~ /^Insecure dependency/, $@;
1144 test !eval { open FOO, "x$foo |" }, 'popen from';
1145 test $@ =~ /^Insecure dependency/, $@;
1148 test !eval { exec $TAINT }, 'exec';
1149 test $@ =~ /^Insecure dependency/, $@;
1151 test !eval { system $TAINT }, 'system';
1152 test $@ =~ /^Insecure dependency/, $@;
1157 test !eval { `$echo 1$foo` }, 'backticks';
1158 test $@ =~ /^Insecure dependency/, $@;
1161 # wildcard expansion doesn't invoke shell on VMS, so is safe
1162 skip "This is not VMS", 2 unless $Is_VMS;
1164 test join('', eval { glob $foo } ) ne '', 'globbing';
1169 # Operations which affect processes can't use tainted data.
1171 test !eval { kill 0, $TAINT }, 'kill';
1172 test $@ =~ /^Insecure dependency/, $@;
1175 skip "setpgrp() is not available", 2 unless $Config{d_setpgrp};
1177 test !eval { setpgrp 0, $TAINT0 }, 'setpgrp';
1178 test $@ =~ /^Insecure dependency/, $@;
1182 skip "setpriority() is not available", 2 unless $Config{d_setprior};
1184 test !eval { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority';
1185 test $@ =~ /^Insecure dependency/, $@;
1189 # Some miscellaneous operations can't use tainted data.
1192 skip "syscall() is not available", 2 unless $Config{d_syscall};
1194 test !eval { syscall $TAINT }, 'syscall';
1195 test $@ =~ /^Insecure dependency/, $@;
1199 my $foo = "x" x 979;
1202 my $temp = tempfile();
1203 test open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
1205 test !eval { ioctl FOO, $TAINT0, $foo }, 'ioctl';
1206 test $@ =~ /^Insecure dependency/, $@;
1209 skip "fcntl() is not available", 2 unless $Config{d_fcntl};
1211 test !eval { fcntl FOO, $TAINT0, $foo }, 'fcntl';
1212 test $@ =~ /^Insecure dependency/, $@;
1219 # Some tests involving references
1221 my $foo = 'abc' . $TAINT;
1223 test not tainted $fooref;
1224 test tainted $$fooref;
1228 # Some tests involving assignment
1232 test all_tainted $foo, $bar;
1233 test tainted($foo = $bar);
1234 test tainted($bar = $bar);
1235 test tainted($bar += $bar);
1236 test tainted($bar -= $bar);
1237 test tainted($bar *= $bar);
1238 test tainted($bar++);
1239 test tainted($bar /= $bar);
1240 test tainted($bar += 0);
1241 test tainted($bar -= 2);
1242 test tainted($bar *= -1);
1243 test tainted($bar /= 1);
1244 test tainted($bar--);
1248 # Test assignment and return of lists
1250 my @foo = ("A", "tainted" . $TAINT, "B");
1251 test not tainted $foo[0];
1252 test tainted $foo[1];
1253 test not tainted $foo[2];
1255 test not tainted $bar[0];
1256 test tainted $bar[1];
1257 test not tainted $bar[2];
1258 my @baz = eval { "A", "tainted" . $TAINT, "B" };
1259 test not tainted $baz[0];
1260 test tainted $baz[1];
1261 test not tainted $baz[2];
1262 my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
1263 test not tainted $plugh[0];
1264 test tainted $plugh[1];
1265 test not tainted $plugh[2];
1266 my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
1267 test not tainted ((&$nautilus)[0]);
1268 test tainted ((&$nautilus)[1]);
1269 test not tainted ((&$nautilus)[2]);
1270 my @xyzzy = &$nautilus;
1271 test not tainted $xyzzy[0];
1272 test tainted $xyzzy[1];
1273 test not tainted $xyzzy[2];
1274 my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
1275 test not tainted ((&$red_october)[0]);
1276 test tainted ((&$red_october)[1]);
1277 test not tainted ((&$red_october)[2]);
1278 my @corge = &$red_october;
1279 test not tainted $corge[0];
1280 test tainted $corge[1];
1281 test not tainted $corge[2];
1284 # Test for system/library calls returning string data of dubious origin.
1286 # No reliable %Config check for getpw*
1288 skip "getpwent() is not available", 1 unless
1289 eval { setpwent(); getpwent() };
1292 my @getpwent = getpwent();
1293 die "getpwent: $!\n" unless (@getpwent);
1294 test ( not tainted $getpwent[0]
1295 and tainted $getpwent[1]
1296 and not tainted $getpwent[2]
1297 and not tainted $getpwent[3]
1298 and not tainted $getpwent[4]
1299 and not tainted $getpwent[5]
1300 and tainted $getpwent[6] # ge?cos
1301 and not tainted $getpwent[7]
1302 and tainted $getpwent[8]); # shell
1307 # pretty hard to imagine not
1308 skip "readdir() is not available", 1 unless $Config{d_readdir};
1311 opendir(D, "op") or die "opendir: $!\n";
1312 my $readdir = readdir(D);
1313 test tainted $readdir;
1318 skip "readlink() or symlink() is not available" unless
1319 $Config{d_readlink} && $Config{d_symlink};
1321 my $symlink = "sl$$";
1323 my $sl = "/something/naughty";
1324 # it has to be a real path on Mac OS
1325 symlink($sl, $symlink) or die "symlink: $!\n";
1326 my $readlink = readlink($symlink);
1327 test tainted $readlink;
1332 # test bitwise ops (regression bug)
1336 test not tainted $j;
1342 # test target of substitution (regression bug)
1344 my $why = $TAINT."y";
1352 $why =~ s/e/'-'.$$/ge;
1358 skip "no IPC::SysV", 2 unless $ipcsysv;
1362 skip "shm*() not available", 1 unless $Config{d_shm};
1365 my $sent = "foobar";
1368 my $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
1371 if (shmwrite($id, $sent, 0, 60)) {
1372 if (shmread($id, $rcvd, 0, 60)) {
1373 substr($rcvd, index($rcvd, "\0")) = '';
1375 warn "# shmread failed: $!\n";
1378 warn "# shmwrite failed: $!\n";
1380 shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n";
1382 warn "# shmget failed: $!\n";
1385 skip "SysV shared memory operation failed", 1 unless
1394 skip "msg*() not available", 1 unless $Config{d_msg};
1397 my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
1399 my $sent = "message";
1400 my $type_sent = 1234;
1405 if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) {
1406 if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) {
1407 ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd);
1409 warn "# msgrcv failed: $!\n";
1412 warn "# msgsnd failed: $!\n";
1414 msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n";
1416 warn "# msgget failed\n";
1420 skip "SysV message queue operation failed", 1
1421 unless $rcvd eq $sent && $type_sent == $type_rcvd;
1429 # bug id 20001004.006
1431 open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
1436 ok tainted($a) && tainted($b) && !defined($b);
1442 # bug id 20001004.007
1444 open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
1450 ok !tainted($c->{a}) && tainted($c->{b});
1455 ok tainted($d->{a}) && !tainted($d->{b});
1459 b => { c => $a, d => 42 } };
1460 ok !tainted($e->{a}) &&
1461 !tainted($e->{b}) &&
1462 tainted($e->{b}->{c}) &&
1463 !tainted($e->{b}->{d});
1469 # bug id 20010519.003
1472 use vars qw($has_fcntl);
1473 eval { require Fcntl; import Fcntl; };
1480 skip "no Fcntl", 18 unless $has_fcntl;
1482 my $evil = "foo" . $TAINT;
1484 eval { sysopen(my $ro, $evil, &O_RDONLY) };
1485 test $@ !~ /^Insecure dependency/, $@;
1487 eval { sysopen(my $wo, $evil, &O_WRONLY) };
1488 test $@ =~ /^Insecure dependency/, $@;
1490 eval { sysopen(my $rw, $evil, &O_RDWR) };
1491 test $@ =~ /^Insecure dependency/, $@;
1493 eval { sysopen(my $ap, $evil, &O_APPEND) };
1494 test $@ =~ /^Insecure dependency/, $@;
1496 eval { sysopen(my $cr, $evil, &O_CREAT) };
1497 test $@ =~ /^Insecure dependency/, $@;
1499 eval { sysopen(my $tr, $evil, &O_TRUNC) };
1500 test $@ =~ /^Insecure dependency/, $@;
1502 eval { sysopen(my $ro, "foo", &O_RDONLY | $TAINT0) };
1503 test $@ !~ /^Insecure dependency/, $@;
1505 eval { sysopen(my $wo, "foo", &O_WRONLY | $TAINT0) };
1506 test $@ =~ /^Insecure dependency/, $@;
1508 eval { sysopen(my $rw, "foo", &O_RDWR | $TAINT0) };
1509 test $@ =~ /^Insecure dependency/, $@;
1511 eval { sysopen(my $ap, "foo", &O_APPEND | $TAINT0) };
1512 test $@ =~ /^Insecure dependency/, $@;
1514 eval { sysopen(my $cr, "foo", &O_CREAT | $TAINT0) };
1515 test $@ =~ /^Insecure dependency/, $@;
1517 eval { sysopen(my $tr, "foo", &O_TRUNC | $TAINT0) };
1518 test $@ =~ /^Insecure dependency/, $@;
1520 eval { sysopen(my $ro, "foo", &O_RDONLY, $TAINT0) };
1521 test $@ !~ /^Insecure dependency/, $@;
1523 eval { sysopen(my $wo, "foo", &O_WRONLY, $TAINT0) };
1524 test $@ =~ /^Insecure dependency/, $@;
1526 eval { sysopen(my $rw, "foo", &O_RDWR, $TAINT0) };
1527 test $@ =~ /^Insecure dependency/, $@;
1529 eval { sysopen(my $ap, "foo", &O_APPEND, $TAINT0) };
1530 test $@ =~ /^Insecure dependency/, $@;
1532 eval { sysopen(my $cr, "foo", &O_CREAT, $TAINT0) };
1533 test $@ =~ /^Insecure dependency/, $@;
1535 eval { sysopen(my $tr, "foo", &O_TRUNC, $TAINT0) };
1536 test $@ =~ /^Insecure dependency/, $@;
1538 unlink("foo"); # not unlink($evil), because that would fail...
1547 my $saw_warning = 0;
1548 local $SIG{__WARN__} = sub { $saw_warning = 1 };
1551 my $divnum = shift()/1;
1552 sprintf("%1.1f\n", $divnum);
1564 # Bug ID 20010730.010
1568 sub Tie::TIESCALAR {
1572 bless \$arg => $class;
1583 my $bar = "The Big Bright Green Pleasure Machine";
1585 tie my ($foo), Tie => $bar;
1593 # Check that all environment variables are tainted.
1595 while (my ($k, $v) = each %ENV) {
1597 # These we have explicitly untainted or set earlier.
1598 $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) {
1599 push @untainted, "# '$k' = '$v'\n";
1602 test @untainted == 0, "untainted:\n @untainted";
1606 ok( ${^TAINT} == 1, '$^TAINT is on' );
1608 eval { ${^TAINT} = 0 };
1609 ok( ${^TAINT}, '$^TAINT is not assignable' );
1610 ok( $@ =~ /^Modification of a read-only value attempted/,
1611 'Assigning to ${^TAINT} fails' );
1616 my $re1 = qr/x$TAINT/;
1619 my $re2 = qr/^$re1\z/;
1627 skip "system {} has different semantics on Win32", 1 if $Is_MSWin32;
1630 local $ENV{PATH} .= $TAINT;
1631 eval { system { "echo" } "/arg0", "arg1" };
1632 test $@ =~ /^Insecure \$ENV/;
1636 todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22
1639 # bug 20020208.005 plus some single arg exec/system extras
1640 my $err = qr/^Insecure dependency/ ;
1641 test !eval { exec $TAINT, $TAINT }, 'exec';
1642 test $@ =~ $err, $@;
1643 test !eval { exec $TAINT $TAINT }, 'exec';
1644 test $@ =~ $err, $@;
1645 test !eval { exec $TAINT $TAINT, $TAINT }, 'exec';
1646 test $@ =~ $err, $@;
1647 test !eval { exec $TAINT 'notaint' }, 'exec';
1648 test $@ =~ $err, $@;
1649 test !eval { exec {'notaint'} $TAINT }, 'exec';
1650 test $@ =~ $err, $@;
1652 test !eval { system $TAINT, $TAINT }, 'system';
1653 test $@ =~ $err, $@;
1654 test !eval { system $TAINT $TAINT }, 'system';
1655 test $@ =~ $err, $@;
1656 test !eval { system $TAINT $TAINT, $TAINT }, 'system';
1657 test $@ =~ $err, $@;
1658 test !eval { system $TAINT 'notaint' }, 'system';
1659 test $@ =~ $err, $@;
1660 test !eval { system {'notaint'} $TAINT }, 'system';
1661 test $@ =~ $err, $@;
1665 system("lskdfj does not exist","with","args");
1671 exec("lskdfj does not exist","with","args");
1675 # If you add tests here update also the above skip block for VMS.
1679 # [ID 20020704.001] taint propagation failure
1682 test tainted(my $foo = $1);
1686 # [perl #24291] this used to dump core
1687 our %nonmagicalenv = ( PATH => "util" );
1688 local *ENV = \%nonmagicalenv;
1689 eval { system("lskdfj"); };
1690 test $@ =~ /^%ENV is aliased to another variable while running with -T switch/;
1691 local *ENV = *nonmagicalenv;
1692 eval { system("lskdfj"); };
1693 test $@ =~ /^%ENV is aliased to %nonmagicalenv while running with -T switch/;
1700 test !tainted($notaint);
1703 $notaint =~ /($notaint)/;
1707 $notaint =~ /($TAINT)/;
1712 $TAINT =~ /($notaint)/;
1716 $TAINT =~ /($TAINT)/;
1722 ($r = $TAINT) =~ /($notaint)/;
1724 ($r = $TAINT) =~ /($TAINT)/;
1728 # accessing $^O shoudn't taint it as a side-effect;
1729 # assigning tainted data to it is now an error
1732 if (!$^X) { } elsif ($^O eq 'bar') { }
1734 local $^O; # We're going to clobber something test infrastructure depends on.
1736 test $@ =~ /Insecure dependency in/;
1739 EFFECTIVELY_CONSTANTS: {
1740 my $tainted_number = 12 + $TAINT0;
1741 test tainted( $tainted_number );
1743 # Even though it's always 0, it's still tainted
1744 my $tainted_product = $tainted_number * 0;
1745 test tainted( $tainted_product );
1746 test $tainted_product == 0;
1749 TERNARY_CONDITIONALS: {
1750 my $tainted_true = $TAINT . "blah blah blah";
1751 my $tainted_false = $TAINT0;
1752 test tainted( $tainted_true );
1753 test tainted( $tainted_false );
1755 my $result = $tainted_true ? "True" : "False";
1756 test $result eq "True";
1757 test !tainted( $result );
1759 $result = $tainted_false ? "True" : "False";
1760 test $result eq "False";
1761 test !tainted( $result );
1763 my $untainted_whatever = "The Fabulous Johnny Cash";
1764 my $tainted_whatever = "Soft Cell" . $TAINT;
1766 $result = $tainted_true ? $tainted_whatever : $untainted_whatever;
1767 test $result eq "Soft Cell";
1768 test tainted( $result );
1770 $result = $tainted_false ? $tainted_whatever : $untainted_whatever;
1771 test $result eq "The Fabulous Johnny Cash";
1772 test !tainted( $result );
1776 # rt.perl.org 5900 $1 remains tainted if...
1777 # 1) The regular expression contains a scalar variable AND
1778 # 2) The regular expression appears in an elsif clause
1780 my $foo = "abcdefghi" . $TAINT;
1782 my $valid_chars = 'a-z';
1785 elsif ( $foo =~ /([$valid_chars]+)/o ) {
1786 test not tainted $1;
1791 elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) {
1792 test not any_tainted @bar;
1796 # at scope exit, a restored localised value should have its old
1797 # taint status, not the taint status of the current statement
1804 test not tainted $x99;
1806 my $c = do { local $x99; $^X };
1807 test not tainted $x99;
1813 my $c = do { local $x99; '' };
1817 # an mg_get of a tainted value during localization shouldn't taint the
1821 eval { local $0, eval '1' };
1825 # [perl #8262] //g loops infinitely on tainted data
1831 cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)";
1836 cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)";
1841 cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)";
1847 eval 'use Scalar::Util "dualvar"; $got_dualvar++';
1848 skip "No Scalar::Util::dualvar" unless $got_dualvar;
1849 my $a = Scalar::Util::dualvar(3, $^X);
1851 is ($b, 8, "Arithmetic on tainted dualvars works");
1854 # opening '|-' should not trigger $ENV{PATH} check
1858 skip "fork() is not available", 3 unless $Config{'d_fork'};
1859 skip "opening |- is not stable on threaded Open/MirBSD with taint", 3
1860 if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD;
1862 $ENV{'PATH'} = $TAINT;
1863 local $SIG{'PIPE'} = 'IGNORE';
1865 my $pid = open my $pipe, '|-';
1866 if (!defined $pid) {
1867 die "open failed: $!";
1870 kill 'KILL', $$; # child suicide
1874 test $@ !~ /Insecure \$ENV/, 'fork triggers %ENV check';
1875 test $@ eq '', 'pipe/fork/open/close failed';
1877 open my $pipe, "|$Invoke_Perl -e 1";
1880 test $@ =~ /Insecure \$ENV/, 'popen neglects %ENV check';
1885 package AUTOLOAD_TAINT;
1888 return if $AUTOLOAD =~ /DESTROY/;
1889 if ($AUTOLOAD =~ /untainted/) {
1890 main::ok(!main::tainted($AUTOLOAD), '$AUTOLOAD can be untainted');
1892 main::ok(main::tainted($AUTOLOAD), '$AUTOLOAD can be tainted');
1897 my $o = bless [], 'AUTOLOAD_TAINT';
1903 # tests for tainted format in s?printf
1904 eval { printf($TAINT . "# %s\n", "foo") };
1905 like($@, qr/^Insecure dependency in printf/, q/printf doesn't like tainted formats/);
1906 eval { printf("# %s\n", $TAINT . "foo") };
1907 ok(!$@, q/printf accepts other tainted args/);
1908 eval { sprintf($TAINT . "# %s\n", "foo") };
1909 like($@, qr/^Insecure dependency in sprintf/, q/sprintf doesn't like tainted formats/);
1910 eval { sprintf("# %s\n", $TAINT . "foo") };
1911 ok(!$@, q/sprintf accepts other tainted args/);
1920 is ($val, '7000000000', 'Assignment to untainted variable');
1923 is ($val, '7000000000', 'Assignment to tainted variable');
1928 my $tainted = '1' . $TAINT;
1929 eval '$val = eval $tainted;';
1930 is ($val, 0, "eval doesn't like tainted strings");
1931 like ($@, qr/^Insecure dependency in eval/);
1933 # Rather nice code to get a tainted undef by from Rick Delaney
1934 open FH, "test.pl" or die $!;
1935 seek FH, 0, 2 or die $!;
1938 eval 'eval $tainted';
1939 like ($@, qr/^Insecure dependency in eval/);
1942 foreach my $ord (78, 163, 256) {
1944 my $line = 'A1' . $TAINT . chr $ord;
1948 ok(!tainted($1), "\\S match with chr $ord");
1953 sub cr { my $x = crypt($_[0], $_[1]); $x }
1954 sub co { my $x = ~$_[0]; $x }
1956 $a = cr('hello', 'foo' . $TAINT);
1957 $b = cr('hello', 'foo');
1958 ok(tainted($a), "tainted crypt");
1959 ok(!tainted($b), "untainted crypt");
1960 $a = co('foo' . $TAINT);
1962 ok(tainted($a), "tainted complement");
1963 ok(!tainted($b), "untainted complement");
1967 my @data = qw(bonk zam zlonk qunckkk);
1968 # Clearly some sort of usenet bang-path
1969 my $string = $TAINT . join "!", @data;
1971 ok(tainted($string), "tainted data");
1973 my @got = split /!|,/, $string;
1975 # each @got would be useful here, but I want the test for earlier perls
1976 for my $i (0 .. $#data) {
1977 ok(tainted($got[$i]), "tainted result $i");
1978 is($got[$i], $data[$i], "correct content $i");
1981 ok(tainted($string), "still tainted data");
1983 my @got = split /[!,]/, $string;
1985 # each @got would be useful here, but I want the test for earlier perls
1986 for my $i (0 .. $#data) {
1987 ok(tainted($got[$i]), "tainted result $i");
1988 is($got[$i], $data[$i], "correct content $i");
1991 ok(tainted($string), "still tainted data");
1993 my @got = split /!/, $string;
1995 # each @got would be useful here, but I want the test for earlier perls
1996 for my $i (0 .. $#data) {
1997 ok(tainted($got[$i]), "tainted result $i");
1998 is($got[$i], $data[$i], "correct content $i");
2002 # Bug RT #52552 - broken by change at git commit id f337b08
2004 my $x = $TAINT. q{print "Hello world\n"};
2005 my $y = pack "a*", $x;
2006 ok(tainted($y), "pack a* preserves tainting");
2008 my $z = pack "A*", q{print "Hello world\n"}.$TAINT;
2009 ok(tainted($z), "pack A* preserves tainting");
2011 my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT;
2012 ok(tainted($zz), "pack a*a* preserves tainting");
2015 # Bug RT #61976 tainted $! would show numeric rather than string value
2018 my $tainted_path = substr($^X,0,0) . "/no/such/file";
2020 # $! is used in a tainted expression, so gets tainted
2021 open my $fh, $tainted_path or $err= "$!";
2022 unlike($err, qr/^\d+$/, 'tainted $!');
2026 # #6758: tainted values become untainted in tied hashes
2027 # (also applies to other value magic such as pos)
2032 sub TIEHASH { bless {} }
2033 sub TIEARRAY { bless {} }
2038 main::ok(main::tainted($_[1]), "tied arg1 tainted");
2039 main::ok(main::tainted($_[2]), "tied arg2 tainted");
2045 my ($k,$v) = qw(1111 val);
2047 tie my @array, 'P6758';
2048 tie my %hash , 'P6758';
2051 ok $i == 2, "tied STORE called correct number of times";
2054 # Bug RT #45167 the return value of sprintf sometimes wasn't tainted
2055 # when the args were tainted. This only occured on the first use of
2056 # sprintf; after that, its TARG has taint magic attached, so setmagic
2057 # at the end works. That's why there are multiple sprintf's below, rather
2058 # than just one wrapped in an inner loop. Also, any plaintext between
2059 # fprmat entires would correctly cause tainting to get set. so test with
2060 # "%s%s" rather than eg "%s %s".
2063 for my $var1 ($TAINT, "123") {
2064 for my $var2 ($TAINT0, "456") {
2066 push @s, sprintf '%s', $var1, $var2;
2067 push @s, sprintf ' %s', $var1, $var2;
2068 push @s, sprintf '%s%s', $var1, $var2;
2072 (tainted($var1) || ($_==2 && tainted($var2)))
2074 "sprintf fmt$_, '$var1', '$var2'");
2081 # Bug RT #67962: old tainted $1 gets treated as tainted
2082 # in next untainted # match
2086 "abc".$TAINT =~ /(.*)/; # make $1 tainted
2087 ok(tainted($1), '$1 should be tainted');
2089 my $untainted = "abcdef";
2090 ok(!tainted($untainted), '$untainted should be untainted');
2091 $untainted =~ s/(abc)/$1/;
2092 ok(!tainted($untainted), '$untainted should still be untainted');
2093 $untainted =~ s/(abc)/x$1/;
2094 ok(!tainted($untainted), '$untainted should yet still be untainted');
2098 # On Windows we can't spawn a fresh Perl interpreter unless at
2099 # least the Windows system directory (usually C:\Windows\System32)
2100 # is still on the PATH. There is however no way to determine the
2101 # actual path on the current system without loading the Win32
2102 # module, so we just restore the original $ENV{PATH} here.
2103 local $ENV{PATH} = $ENV{PATH};
2104 $ENV{PATH} = $old_env_path if $Is_MSWin32;
2106 fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] },
2107 $TAINT = substr($^X, 0, 0);
2108 formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt');
2111 "formline survives a tainted dynamic picture");
2115 ok(!tainted($^A), "format accumulator not tainted yet");
2116 formline('@ | @*', 'hallo' . $TAINT, 'welt');
2117 ok(tainted($^A), "tainted formline argument makes a tainted accumulator");
2119 ok(!tainted($^A), "accumulator can be explicitly untainted");
2120 formline('@' .('<'*5) . ' | @*', 'hallo', 'welt');
2121 ok(!tainted($^A), "accumulator still untainted");
2123 ok(tainted($^A), "accumulator can be explicitly tainted");
2124 formline('@' .('<'*5) . ' | @*', 'hallo', 'welt');
2125 ok(tainted($^A), "accumulator still tainted");
2127 ok(!tainted($^A), "accumulator untainted again");
2128 formline('@' .('<'*5) . ' | @*', 'hallo', 'welt');
2129 ok(!tainted($^A), "accumulator still untainted");
2130 formline('@' .('<'*(5+$TAINT0)) . ' | @*', 'hallo', 'welt');
2132 local $::TODO = "get magic handled too late?";
2133 ok(tainted($^A), "the accumulator should be tainted already");
2135 ok(tainted($^A), "tainted formline picture makes a tainted accumulator");
2139 "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi;
2142 ok(! tainted($a), "regex optimization of single char /[]/i doesn't taint");
2143 ok(! tainted($b), "regex optimization of single char /[]/i doesn't taint");
2147 # RT 81230: tainted value during FETCH created extra ref to tied obj
2155 my $x = $^X; # tainted
2158 sub FETCH { my $x = $_[0]; $$x . "" }
2163 local $SIG{__WARN__} = sub { $w .= "@_" };
2165 untie %h if $h{"k"};
2167 ::is($w, "", "RT 81230");
2171 # Compiling a subroutine inside a tainted expression does not make the
2172 # constant folded values tainted.
2173 my $x = sub { "x" . "y" };
2174 my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression
2176 ok( ! tainted($z), "Constants folded value not tainted");
2180 # now that regexes are first class SVs, make sure that they themselves
2181 # as well as references to them are tainted
2183 my $rr = qr/(.)$TAINT/;
2184 my $r = $$rr; # bare REGEX
2186 ok($s =~ s/$r/x/, "match bare regex");
2187 ok(tainted($s), "match bare regex taint");
2188 is($s, 'xbc', "match bare regex taint value");
2192 # [perl #82616] security Issues with user-defined \p{} properties
2193 # A using a tainted user-defined property should croak
2195 sub IsA { sprintf "%02x", ord("A") }
2198 ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case");
2199 $prop = "IsA$TAINT";
2200 eval { "A" =~ /\p{$prop}/};
2201 like($@, qr/Insecure user-defined property \\p{main::IsA}/,
2202 "user-defined property: tainted case");
2205 # This may bomb out with the alarm signal so keep it last
2207 skip "No alarm()" unless $Config{d_alarm};
2208 # Test from RT #41831]
2209 # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x)
2211 my $DATA = <<'END' . $TAINT;
2221 ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as
2222 ## perl is stuck in a regexp infinite loop!
2226 if ($DATA =~ /^line2.*line4/m) {
2227 fail("Should not be a match")
2229 pass("Match on tainted multiline data should fail promptly");
2235 # Keep the previous test last