t/op/taint.t

   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
   6 # tests that I've missed here, please add them. But this is
   7 # better than having no tests at all, right?
   8 #
   9
  10 BEGIN {
  11     chdir 't' if -d 't';
  12     @INC = '../lib';
  13 }
  14
  15 use strict;
  16 use Config;
  17 use File::Spec::Functions;
  18
  19 BEGIN { require './test.pl'; }
  20 plan tests => 261;
  21
  22 $| = 1;
  23
  24 use vars qw($ipcsysv); # did we manage to load IPC::SysV?
  25
  26 BEGIN {
  27   if ($^O eq 'VMS' && !defined($Config{d_setenv})) {
  28       $ENV{PATH} = $ENV{PATH};
  29       $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy';
  30   }
  31   if ($Config{'extensions'} =~ /\bIPC\/SysV\b/
  32       && ($Config{d_shm} || $Config{d_msg})) {
  33       eval { require IPC::SysV };
  34       unless ($@) {
  35           $ipcsysv++;
  36           IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT));
  37       }
  38   }
  39 }
  40
  41 my $Is_MacOS    = $^O eq 'MacOS';
  42 my $Is_VMS      = $^O eq 'VMS';
  43 my $Is_MSWin32  = $^O eq 'MSWin32';
  44 my $Is_NetWare  = $^O eq 'NetWare';
  45 my $Is_Dos      = $^O eq 'dos';
  46 my $Is_Cygwin   = $^O eq 'cygwin';
  47 my $Is_OpenBSD  = $^O eq 'openbsd';
  48 my $Invoke_Perl = $Is_VMS      ? 'MCR Sys$Disk:[]Perl.exe' :
  49                   $Is_MSWin32  ? '.\perl'               :
  50                   $Is_MacOS    ? ':perl'                :
  51                   $Is_NetWare  ? 'perl'                 :
  52                                  './perl'               ;
  53 my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/;
  54
  55 if ($Is_VMS) {
  56     my (%old, $x);
  57     for $x ('DCL$PATH', @MoreEnv) {
  58         ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x};
  59     }
  60     eval <<EndOfCleanup;
  61         END {
  62             \$ENV{PATH} = '' if $Config{d_setenv};
  63             warn "# Note: logical name 'PATH' may have been deleted\n";
  64             \@ENV{keys %old} = values %old;
  65         }
  66 EndOfCleanup
  67 }
  68
  69 # Sources of taint:
  70 #   The empty tainted value, for tainting strings
  71 my $TAINT = substr($^X, 0, 0);
  72 #   A tainted zero, useful for tainting numbers
  73 my $TAINT0;
  74 {
  75     no warnings;
  76     $TAINT0 = 0 + $TAINT;
  77 }
  78
  79 # This taints each argument passed. All must be lvalues.
  80 # Side effect: It also stringifies them. :-(
  81 sub taint_these (@) {
  82     for (@_) { $_ .= $TAINT }
  83 }
  84
  85 # How to identify taint when you see it
  86 sub any_tainted (@) {
  87     not eval { join("",@_), kill 0; 1 };
  88 }
  89 sub tainted ($) {
  90     any_tainted @_;
  91 }
  92 sub all_tainted (@) {
  93     for (@_) { return 0 unless tainted $_ }
  94     1;
  95 }
  96
  97
  98 sub test ($;$) {
  99     my($ok, $diag) = @_;
 100
 101     my $curr_test = curr_test();
 102
 103     if ($ok) {
 104         print "ok $curr_test\n";
 105     } else {
 106         print "not ok $curr_test\n";
 107         printf "# Failed test at line %d\n", (caller)[2];
 108         for (split m/^/m, $diag) {
 109             print "# $_";
 110         }
 111         print "\n" unless
 112             $diag eq ''
 113             or substr($diag, -1) eq "\n";
 114     }
 115
 116     next_test();
 117
 118     return $ok;
 119 }
 120
 121 # We need an external program to call.
 122 my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : $Is_MacOS ? ":echo$$" : ($Is_NetWare ? "echo$$" : "./echo$$"));
 123 END { unlink $ECHO }
 124 open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
 125 print PROG 'print "@ARGV\n"', "\n";
 126 close PROG;
 127 my $echo = "$Invoke_Perl $ECHO";
 128
 129 my $TEST = catfile(curdir(), 'TEST');
 130
 131 # First, let's make sure that Perl is checking the dangerous
 132 # environment variables. Maybe they aren't set yet, so we'll
 133 # taint them ourselves.
 134 {
 135     $ENV{'DCL$PATH'} = '' if $Is_VMS;
 136
 137     if ($Is_MSWin32 && $Config{ccname} =~ /bcc32/ && ! -f 'cc3250mt.dll') {
 138         my $bcc_dir;
 139         foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
 140             if (-f "$dir/cc3250mt.dll") {
 141                 $bcc_dir = $dir and last;
 142             }
 143         }
 144         if (defined $bcc_dir) {
 145             require File::Copy;
 146             File::Copy::copy("$bcc_dir/cc3250mt.dll", '.') or
 147                 die "$0: failed to copy cc3250mt.dll: $!\n";
 148             eval q{
 149                 END { unlink "cc3250mt.dll" }
 150             };
 151         }
 152     }
 153
 154     $ENV{PATH} = '';
 155     delete @ENV{@MoreEnv};
 156     $ENV{TERM} = 'dumb';
 157
 158     test eval { `$echo 1` } eq "1\n";
 159
 160     SKIP: {
 161         skip "Environment tainting tests skipped", 4
 162           if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos || $Is_MacOS;
 163
 164         my @vars = ('PATH', @MoreEnv);
 165         while (my $v = $vars[0]) {
 166             local $ENV{$v} = $TAINT;
 167             last if eval { `$echo 1` };
 168             last unless $@ =~ /^Insecure \$ENV{$v}/;
 169             shift @vars;
 170         }
 171         test !@vars, "@vars";
 172
 173         # tainted $TERM is unsafe only if it contains metachars
 174         local $ENV{TERM};
 175         $ENV{TERM} = 'e=mc2';
 176         test eval { `$echo 1` } eq "1\n";
 177         $ENV{TERM} = 'e=mc2' . $TAINT;
 178         test !eval { `$echo 1` };
 179         test $@ =~ /^Insecure \$ENV{TERM}/, $@;
 180     }
 181
 182     my $tmp;
 183     if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) {
 184         print "# all directories are writeable\n";
 185     }
 186     else {
 187         $tmp = (grep { defined and -d and (stat _)[2] & 2 }
 188                      qw(sys$scratch /tmp /var/tmp /usr/tmp),
 189                      @ENV{qw(TMP TEMP)})[0]
 190             or print "# can't find world-writeable directory to test PATH\n";
 191     }
 192
 193     SKIP: {
 194         skip "all directories are writeable", 2 unless $tmp;
 195
 196         local $ENV{PATH} = $tmp;
 197         test !eval { `$echo 1` };
 198         test $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
 199     }
 200
 201     SKIP: {
 202         skip "This is not VMS", 4 unless $Is_VMS;
 203
 204         $ENV{'DCL$PATH'} = $TAINT;
 205         test  eval { `$echo 1` } eq '';
 206         test $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
 207         SKIP: {
 208             skip q[can't find world-writeable directory to test DCL$PATH], 2
 209               unless $tmp;
 210
 211             $ENV{'DCL$PATH'} = $tmp;
 212             test eval { `$echo 1` } eq '';
 213             test $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@;
 214         }
 215         $ENV{'DCL$PATH'} = '';
 216     }
 217 }
 218
 219 # Let's see that we can taint and untaint as needed.
 220 {
 221     my $foo = $TAINT;
 222     test tainted $foo;
 223
 224     # That was a sanity check. If it failed, stop the insanity!
 225     die "Taint checks don't seem to be enabled" unless tainted $foo;
 226
 227     $foo = "foo";
 228     test not tainted $foo;
 229
 230     taint_these($foo);
 231     test tainted $foo;
 232
 233     my @list = 1..10;
 234     test not any_tainted @list;
 235     taint_these @list[1,3,5,7,9];
 236     test any_tainted @list;
 237     test all_tainted @list[1,3,5,7,9];
 238     test not any_tainted @list[0,2,4,6,8];
 239
 240     ($foo) = $foo =~ /(.+)/;
 241     test not tainted $foo;
 242
 243     $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
 244     test not tainted $foo;
 245     test $foo eq 'bar';
 246
 247     {
 248       use re 'taint';
 249
 250       ($foo) = ('bar' . $TAINT) =~ /(.+)/;
 251       test tainted $foo;
 252       test $foo eq 'bar';
 253
 254       $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
 255       test tainted $foo;
 256       test $foo eq 'bar';
 257     }
 258
 259     $foo = $1 if 'bar' =~ /(.+)$TAINT/;
 260     test tainted $foo;
 261     test $foo eq 'bar';
 262
 263     my $pi = 4 * atan2(1,1) + $TAINT0;
 264     test tainted $pi;
 265
 266     ($pi) = $pi =~ /(\d+\.\d+)/;
 267     test not tainted $pi;
 268     test sprintf("%.5f", $pi) eq '3.14159';
 269 }
 270
 271 # How about command-line arguments? The problem is that we don't
 272 # always get some, so we'll run another process with some.
 273 SKIP: {
 274     my $arg = catfile(curdir(), "arg$$");
 275     open PROG, "> $arg" or die "Can't create $arg: $!";
 276     print PROG q{
 277         eval { join('', @ARGV), kill 0 };
 278         exit 0 if $@ =~ /^Insecure dependency/;
 279         print "# Oops: \$@ was [$@]\n";
 280         exit 1;
 281     };
 282     close PROG;
 283     print `$Invoke_Perl "-T" $arg and some suspect arguments`;
 284     test !$?, "Exited with status $?";
 285     unlink $arg;
 286 }
 287
 288 # Reading from a file should be tainted
 289 {
 290     test open(FILE, $TEST), "Couldn't open '$TEST': $!";
 291
 292     my $block;
 293     sysread(FILE, $block, 100);
 294     my $line = <FILE>;
 295     close FILE;
 296     test tainted $block;
 297     test tainted $line;
 298 }
 299
 300 # Globs should be forbidden, except under VMS,
 301 #   which doesn't spawn an external program.
 302 SKIP: {
 303     skip "globs should be forbidden", 2 if 1 or $Is_VMS;
 304
 305     my @globs = eval { <*> };
 306     test @globs == 0 && $@ =~ /^Insecure dependency/;
 307
 308     @globs = eval { glob '*' };
 309     test @globs == 0 && $@ =~ /^Insecure dependency/;
 310 }
 311
 312 # Output of commands should be tainted
 313 {
 314     my $foo = `$echo abc`;
 315     test tainted $foo;
 316 }
 317
 318 # Certain system variables should be tainted
 319 {
 320     test all_tainted $^X, $0;
 321 }
 322
 323 # Results of matching should all be untainted
 324 {
 325     my $foo = "abcdefghi" . $TAINT;
 326     test tainted $foo;
 327
 328     $foo =~ /def/;
 329     test not any_tainted $`, $&, $';
 330
 331     $foo =~ /(...)(...)(...)/;
 332     test not any_tainted $1, $2, $3, $+;
 333
 334     my @bar = $foo =~ /(...)(...)(...)/;
 335     test not any_tainted @bar;
 336
 337     test tainted $foo;  # $foo should still be tainted!
 338     test $foo eq "abcdefghi";
 339 }
 340
 341 # Operations which affect files can't use tainted data.
 342 {
 343     test !eval { chmod 0, $TAINT }, 'chmod';
 344     test $@ =~ /^Insecure dependency/, $@;
 345
 346     # There is no feature test in $Config{} for truncate,
 347     #   so we allow for the possibility that it's missing.
 348     test !eval { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate';
 349     test $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
 350
 351     test !eval { rename '', $TAINT }, 'rename';
 352     test $@ =~ /^Insecure dependency/, $@;
 353
 354     test !eval { unlink $TAINT }, 'unlink';
 355     test $@ =~ /^Insecure dependency/, $@;
 356
 357     test !eval { utime $TAINT }, 'utime';
 358     test $@ =~ /^Insecure dependency/, $@;
 359
 360     SKIP: {
 361         skip "chown() is not available", 2 unless $Config{d_chown};
 362
 363         test !eval { chown -1, -1, $TAINT }, 'chown';
 364         test $@ =~ /^Insecure dependency/, $@;
 365     }
 366
 367     SKIP: {
 368         skip "link() is not available", 2 unless $Config{d_link};
 369
 370         test !eval { link $TAINT, '' }, 'link';
 371         test $@ =~ /^Insecure dependency/, $@;
 372     }
 373
 374     SKIP: {
 375         skip "symlink() is not available", 2 unless $Config{d_symlink};
 376
 377         test !eval { symlink $TAINT, '' }, 'symlink';
 378         test $@ =~ /^Insecure dependency/, $@;
 379     }
 380 }
 381
 382 # Operations which affect directories can't use tainted data.
 383 {
 384     test !eval { mkdir "foo".$TAINT, 0755.$TAINT0 }, 'mkdir';
 385     test $@ =~ /^Insecure dependency/, $@;
 386
 387     test !eval { rmdir $TAINT }, 'rmdir';
 388     test $@ =~ /^Insecure dependency/, $@;
 389
 390     test !eval { chdir "foo".$TAINT }, 'chdir';
 391     test $@ =~ /^Insecure dependency/, $@;
 392
 393     SKIP: {
 394         skip "chroot() is not available", 2 unless $Config{d_chroot};
 395
 396         test !eval { chroot $TAINT }, 'chroot';
 397         test $@ =~ /^Insecure dependency/, $@;
 398     }
 399 }
 400
 401 # Some operations using files can't use tainted data.
 402 {
 403     my $foo = "imaginary library" . $TAINT;
 404     test !eval { require $foo }, 'require';
 405     test $@ =~ /^Insecure dependency/, $@;
 406
 407     my $filename = "./taintB$$";        # NB: $filename isn't tainted!
 408     END { unlink $filename if defined $filename }
 409     $foo = $filename . $TAINT;
 410     unlink $filename;   # in any case
 411
 412     test !eval { open FOO, $foo }, 'open for read';
 413     test $@ eq '', $@;          # NB: This should be allowed
 414
 415     # Try first new style but allow also old style.
 416     # We do not want the whole taint.t to fail
 417     # just because Errno possibly failing.
 418     test eval('$!{ENOENT}') ||
 419         $! == 2 || # File not found
 420         ($Is_Dos && $! == 22) ||
 421         ($^O eq 'mint' && $! == 33);
 422
 423     test !eval { open FOO, "> $foo" }, 'open for write';
 424     test $@ =~ /^Insecure dependency/, $@;
 425 }
 426
 427 # Commands to the system can't use tainted data
 428 {
 429     my $foo = $TAINT;
 430
 431     SKIP: {
 432         skip "open('|') is not available", 4 if $^O eq 'amigaos';
 433
 434         test !eval { open FOO, "| x$foo" }, 'popen to';
 435         test $@ =~ /^Insecure dependency/, $@;
 436
 437         test !eval { open FOO, "x$foo |" }, 'popen from';
 438         test $@ =~ /^Insecure dependency/, $@;
 439     }
 440
 441     test !eval { exec $TAINT }, 'exec';
 442     test $@ =~ /^Insecure dependency/, $@;
 443
 444     test !eval { system $TAINT }, 'system';
 445     test $@ =~ /^Insecure dependency/, $@;
 446
 447     $foo = "*";
 448     taint_these $foo;
 449
 450     test !eval { `$echo 1$foo` }, 'backticks';
 451     test $@ =~ /^Insecure dependency/, $@;
 452
 453     SKIP: {
 454         # wildcard expansion doesn't invoke shell on VMS, so is safe
 455         skip "This is not VMS", 2 unless $Is_VMS;
 456
 457         test join('', eval { glob $foo } ) ne '', 'globbing';
 458         test $@ eq '', $@;
 459     }
 460 }
 461
 462 # Operations which affect processes can't use tainted data.
 463 {
 464     test !eval { kill 0, $TAINT }, 'kill';
 465     test $@ =~ /^Insecure dependency/, $@;
 466
 467     SKIP: {
 468         skip "setpgrp() is not available", 2 unless $Config{d_setpgrp};
 469
 470         test !eval { setpgrp 0, $TAINT0 }, 'setpgrp';
 471         test $@ =~ /^Insecure dependency/, $@;
 472     }
 473
 474     SKIP: {
 475         skip "setpriority() is not available", 2 unless $Config{d_setprior};
 476
 477         test !eval { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority';
 478         test $@ =~ /^Insecure dependency/, $@;
 479     }
 480 }
 481
 482 # Some miscellaneous operations can't use tainted data.
 483 {
 484     SKIP: {
 485         skip "syscall() is not available", 2 unless $Config{d_syscall};
 486
 487         test !eval { syscall $TAINT }, 'syscall';
 488         test $@ =~ /^Insecure dependency/, $@;
 489     }
 490
 491     {
 492         my $foo = "x" x 979;
 493         taint_these $foo;
 494         local *FOO;
 495         my $temp = "./taintC$$";
 496         END { unlink $temp }
 497         test open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
 498
 499         test !eval { ioctl FOO, $TAINT0, $foo }, 'ioctl';
 500         test $@ =~ /^Insecure dependency/, $@;
 501
 502         SKIP: {
 503             skip "fcntl() is not available", 2 unless $Config{d_fcntl};
 504
 505             test !eval { fcntl FOO, $TAINT0, $foo }, 'fcntl';
 506             test $@ =~ /^Insecure dependency/, $@;
 507         }
 508
 509         close FOO;
 510     }
 511 }
 512
 513 # Some tests involving references
 514 {
 515     my $foo = 'abc' . $TAINT;
 516     my $fooref = \$foo;
 517     test not tainted $fooref;
 518     test tainted $$fooref;
 519     test tainted $foo;
 520 }
 521
 522 # Some tests involving assignment
 523 {
 524     my $foo = $TAINT0;
 525     my $bar = $foo;
 526     test all_tainted $foo, $bar;
 527     test tainted($foo = $bar);
 528     test tainted($bar = $bar);
 529     test tainted($bar += $bar);
 530     test tainted($bar -= $bar);
 531     test tainted($bar *= $bar);
 532     test tainted($bar++);
 533     test tainted($bar /= $bar);
 534     test tainted($bar += 0);
 535     test tainted($bar -= 2);
 536     test tainted($bar *= -1);
 537     test tainted($bar /= 1);
 538     test tainted($bar--);
 539     test $bar == 0;
 540 }
 541
 542 # Test assignment and return of lists
 543 {
 544     my @foo = ("A", "tainted" . $TAINT, "B");
 545     test not tainted $foo[0];
 546     test     tainted $foo[1];
 547     test not tainted $foo[2];
 548     my @bar = @foo;
 549     test not tainted $bar[0];
 550     test     tainted $bar[1];
 551     test not tainted $bar[2];
 552     my @baz = eval { "A", "tainted" . $TAINT, "B" };
 553     test not tainted $baz[0];
 554     test     tainted $baz[1];
 555     test not tainted $baz[2];
 556     my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
 557     test not tainted $plugh[0];
 558     test     tainted $plugh[1];
 559     test not tainted $plugh[2];
 560     my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
 561     test not tainted ((&$nautilus)[0]);
 562     test     tainted ((&$nautilus)[1]);
 563     test not tainted ((&$nautilus)[2]);
 564     my @xyzzy = &$nautilus;
 565     test not tainted $xyzzy[0];
 566     test     tainted $xyzzy[1];
 567     test not tainted $xyzzy[2];
 568     my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
 569     test not tainted ((&$red_october)[0]);
 570     test     tainted ((&$red_october)[1]);
 571     test not tainted ((&$red_october)[2]);
 572     my @corge = &$red_october;
 573     test not tainted $corge[0];
 574     test     tainted $corge[1];
 575     test not tainted $corge[2];
 576 }
 577
 578 # Test for system/library calls returning string data of dubious origin.
 579 {
 580     # No reliable %Config check for getpw*
 581     SKIP: {
 582         skip "getpwent() is not available", 1 unless
 583           eval { setpwent(); getpwent() };
 584
 585         setpwent();
 586         my @getpwent = getpwent();
 587         die "getpwent: $!\n" unless (@getpwent);
 588         test (    not tainted $getpwent[0]
 589                   and     tainted $getpwent[1]
 590                   and not tainted $getpwent[2]
 591                   and not tainted $getpwent[3]
 592                   and not tainted $getpwent[4]
 593                   and not tainted $getpwent[5]
 594                   and     tainted $getpwent[6]          # ge?cos
 595                   and not tainted $getpwent[7]
 596                   and     tainted $getpwent[8]);        # shell
 597         endpwent();
 598     }
 599
 600     SKIP: {
 601         # pretty hard to imagine not
 602         skip "readdir() is not available", 1 unless $Config{d_readdir};
 603
 604         local(*D);
 605         opendir(D, "op") or die "opendir: $!\n";
 606         my $readdir = readdir(D);
 607         test tainted $readdir;
 608         closedir(D);
 609     }
 610
 611     SKIP: {
 612         skip "readlink() or symlink() is not available" unless
 613           $Config{d_readlink} && $Config{d_symlink};
 614
 615         my $symlink = "sl$$";
 616         unlink($symlink);
 617         my $sl = "/something/naughty";
 618         # it has to be a real path on Mac OS
 619         $sl = MacPerl::MakePath((MacPerl::Volumes())[0]) if $Is_MacOS;
 620         symlink($sl, $symlink) or die "symlink: $!\n";
 621         my $readlink = readlink($symlink);
 622         test tainted $readlink;
 623         unlink($symlink);
 624     }
 625 }
 626
 627 # test bitwise ops (regression bug)
 628 {
 629     my $why = "y";
 630     my $j = "x" | $why;
 631     test not tainted $j;
 632     $why = $TAINT."y";
 633     $j = "x" | $why;
 634     test     tainted $j;
 635 }
 636
 637 # test target of substitution (regression bug)
 638 {
 639     my $why = $TAINT."y";
 640     $why =~ s/y/z/;
 641     test     tainted $why;
 642
 643     my $z = "[z]";
 644     $why =~ s/$z/zee/;
 645     test     tainted $why;
 646
 647     $why =~ s/e/'-'.$$/ge;
 648     test     tainted $why;
 649 }
 650
 651
 652 SKIP: {
 653     skip "no IPC::SysV", 2 unless $ipcsysv;
 654
 655     # test shmread
 656     SKIP: {
 657         skip "shm*() not available", 1 unless $Config{d_shm};
 658
 659         no strict 'subs';
 660         my $sent = "foobar";
 661         my $rcvd;
 662         my $size = 2000;
 663         my $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
 664
 665         if (defined $id) {
 666             if (shmwrite($id, $sent, 0, 60)) {
 667                 if (shmread($id, $rcvd, 0, 60)) {
 668                     substr($rcvd, index($rcvd, "\0")) = '';
 669                 } else {
 670                     warn "# shmread failed: $!\n";
 671                 }
 672             } else {
 673                 warn "# shmwrite failed: $!\n";
 674             }
 675             shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n";
 676         } else {
 677             warn "# shmget failed: $!\n";
 678         }
 679
 680         skip "SysV shared memory operation failed", 1 unless
 681           $rcvd eq $sent;
 682
 683         test tainted $rcvd;
 684     }
 685
 686
 687     # test msgrcv
 688     SKIP: {
 689         skip "msg*() not available", 1 unless $Config{d_msg};
 690
 691         no strict 'subs';
 692         my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
 693
 694         my $sent      = "message";
 695         my $type_sent = 1234;
 696         my $rcvd;
 697         my $type_rcvd;
 698
 699         if (defined $id) {
 700             if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) {
 701                 if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) {
 702                     ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd);
 703                 } else {
 704                     warn "# msgrcv failed: $!\n";
 705                 }
 706             } else {
 707                 warn "# msgsnd failed: $!\n";
 708             }
 709             msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n";
 710         } else {
 711             warn "# msgget failed\n";
 712         }
 713
 714         SKIP: {
 715             skip "SysV message queue operation failed", 1
 716               unless $rcvd eq $sent && $type_sent == $type_rcvd;
 717
 718             test tainted $rcvd;
 719         }
 720     }
 721 }
 722
 723 {
 724     # bug id 20001004.006
 725
 726     open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
 727     local $/;
 728     my $a = <IN>;
 729     my $b = <IN>;
 730
 731     ok tainted($a) && tainted($b) && !defined($b);
 732
 733     close IN;
 734 }
 735
 736 {
 737     # bug id 20001004.007
 738
 739     open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
 740     my $a = <IN>;
 741
 742     my $c = { a => 42,
 743               b => $a };
 744
 745     ok !tainted($c->{a}) && tainted($c->{b});
 746
 747
 748     my $d = { a => $a,
 749               b => 42 };
 750     ok tainted($d->{a}) && !tainted($d->{b});
 751
 752
 753     my $e = { a => 42,
 754               b => { c => $a, d => 42 } };
 755     ok !tainted($e->{a}) &&
 756        !tainted($e->{b}) &&
 757         tainted($e->{b}->{c}) &&
 758        !tainted($e->{b}->{d});
 759
 760     close IN;
 761 }
 762
 763 {
 764     # bug id 20010519.003
 765
 766     BEGIN {
 767         use vars qw($has_fcntl);
 768         eval { require Fcntl; import Fcntl; };
 769         unless ($@) {
 770             $has_fcntl = 1;
 771         }
 772     }
 773
 774     SKIP: {
 775         skip "no Fcntl", 18 unless $has_fcntl;
 776
 777         my $evil = "foo" . $TAINT;
 778
 779         eval { sysopen(my $ro, $evil, &O_RDONLY) };
 780         test $@ !~ /^Insecure dependency/, $@;
 781
 782         eval { sysopen(my $wo, $evil, &O_WRONLY) };
 783         test $@ =~ /^Insecure dependency/, $@;
 784
 785         eval { sysopen(my $rw, $evil, &O_RDWR) };
 786         test $@ =~ /^Insecure dependency/, $@;
 787
 788         eval { sysopen(my $ap, $evil, &O_APPEND) };
 789         test $@ =~ /^Insecure dependency/, $@;
 790
 791         eval { sysopen(my $cr, $evil, &O_CREAT) };
 792         test $@ =~ /^Insecure dependency/, $@;
 793
 794         eval { sysopen(my $tr, $evil, &O_TRUNC) };
 795         test $@ =~ /^Insecure dependency/, $@;
 796
 797         eval { sysopen(my $ro, "foo", &O_RDONLY | $TAINT0) };
 798         test $@ !~ /^Insecure dependency/, $@;
 799
 800         eval { sysopen(my $wo, "foo", &O_WRONLY | $TAINT0) };
 801         test $@ =~ /^Insecure dependency/, $@;
 802
 803         eval { sysopen(my $rw, "foo", &O_RDWR | $TAINT0) };
 804         test $@ =~ /^Insecure dependency/, $@;
 805
 806         eval { sysopen(my $ap, "foo", &O_APPEND | $TAINT0) };
 807         test $@ =~ /^Insecure dependency/, $@;
 808
 809         eval { sysopen(my $cr, "foo", &O_CREAT | $TAINT0) };
 810         test $@ =~ /^Insecure dependency/, $@;
 811
 812         eval { sysopen(my $tr, "foo", &O_TRUNC | $TAINT0) };
 813         test $@ =~ /^Insecure dependency/, $@;
 814
 815         eval { sysopen(my $ro, "foo", &O_RDONLY, $TAINT0) };
 816         test $@ !~ /^Insecure dependency/, $@;
 817
 818         eval { sysopen(my $wo, "foo", &O_WRONLY, $TAINT0) };
 819         test $@ =~ /^Insecure dependency/, $@;
 820
 821         eval { sysopen(my $rw, "foo", &O_RDWR, $TAINT0) };
 822         test $@ =~ /^Insecure dependency/, $@;
 823
 824         eval { sysopen(my $ap, "foo", &O_APPEND, $TAINT0) };
 825         test $@ =~ /^Insecure dependency/, $@;
 826
 827         eval { sysopen(my $cr, "foo", &O_CREAT, $TAINT0) };
 828         test $@ =~ /^Insecure dependency/, $@;
 829
 830         eval { sysopen(my $tr, "foo", &O_TRUNC, $TAINT0) };
 831         test $@ =~ /^Insecure dependency/, $@;
 832
 833         unlink("foo"); # not unlink($evil), because that would fail...
 834     }
 835 }
 836
 837 {
 838     # bug 20010526.004
 839
 840     use warnings;
 841
 842     my $saw_warning = 0;
 843     local $SIG{__WARN__} = sub { $saw_warning = 1 };
 844
 845     sub fmi {
 846         my $divnum = shift()/1;
 847         sprintf("%1.1f\n", $divnum);
 848     }
 849
 850     fmi(21 . $TAINT);
 851     fmi(37);
 852     fmi(248);
 853
 854     test !$saw_warning;
 855 }
 856
 857
 858 {
 859     # Bug ID 20010730.010
 860
 861     my $i = 0;
 862
 863     sub Tie::TIESCALAR {
 864         my $class =  shift;
 865         my $arg   =  shift;
 866
 867         bless \$arg => $class;
 868     }
 869
 870     sub Tie::FETCH {
 871         $i ++;
 872         ${$_ [0]}
 873     }
 874
 875
 876     package main;
 877
 878     my $bar = "The Big Bright Green Pleasure Machine";
 879     taint_these $bar;
 880     tie my ($foo), Tie => $bar;
 881
 882     my $baz = $foo;
 883
 884     ok $i == 1;
 885 }
 886
 887 {
 888     # Check that all environment variables are tainted.
 889     my @untainted;
 890     while (my ($k, $v) = each %ENV) {
 891         if (!tainted($v) &&
 892             # These we have explicitly untainted or set earlier.
 893             $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) {
 894             push @untainted, "# '$k' = '$v'\n";
 895         }
 896     }
 897     test @untainted == 0, "untainted:\n @untainted";
 898 }
 899
 900
 901 ok( ${^TAINT} == 1, '$^TAINT is on' );
 902
 903 eval { ${^TAINT} = 0 };
 904 ok( ${^TAINT},  '$^TAINT is not assignable' );
 905 ok( $@ =~ /^Modification of a read-only value attempted/,
 906                                 'Assigning to ${^TAINT} fails' );
 907
 908 {
 909     # bug 20011111.105
 910
 911     my $re1 = qr/x$TAINT/;
 912     test tainted $re1;
 913
 914     my $re2 = qr/^$re1\z/;
 915     test tainted $re2;
 916
 917     my $re3 = "$re2";
 918     test tainted $re3;
 919 }
 920
 921 SKIP: {
 922     skip "system {} has different semantics on Win32", 1 if $Is_MSWin32;
 923
 924     # bug 20010221.005
 925     local $ENV{PATH} .= $TAINT;
 926     eval { system { "echo" } "/arg0", "arg1" };
 927     test $@ =~ /^Insecure \$ENV/;
 928 }
 929
 930 TODO: {
 931     todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22
 932       if $Is_VMS;
 933
 934     # bug 20020208.005 plus some single arg exec/system extras
 935     my $err = qr/^Insecure dependency/ ;
 936     test !eval { exec $TAINT, $TAINT }, 'exec';
 937     test $@ =~ $err, $@;
 938     test !eval { exec $TAINT $TAINT }, 'exec';
 939     test $@ =~ $err, $@;
 940     test !eval { exec $TAINT $TAINT, $TAINT }, 'exec';
 941     test $@ =~ $err, $@;
 942     test !eval { exec $TAINT 'notaint' }, 'exec';
 943     test $@ =~ $err, $@;
 944     test !eval { exec {'notaint'} $TAINT }, 'exec';
 945     test $@ =~ $err, $@;
 946
 947     test !eval { system $TAINT, $TAINT }, 'system';
 948     test $@ =~ $err, $@;
 949     test !eval { system $TAINT $TAINT }, 'system';
 950     test $@ =~ $err, $@;
 951     test !eval { system $TAINT $TAINT, $TAINT }, 'system';
 952     test $@ =~ $err, $@;
 953     test !eval { system $TAINT 'notaint' }, 'system';
 954     test $@ =~ $err, $@;
 955     test !eval { system {'notaint'} $TAINT }, 'system';
 956     test $@ =~ $err, $@;
 957
 958     eval {
 959         no warnings;
 960         system("lskdfj does not exist","with","args");
 961     };
 962     test !$@;
 963
 964     SKIP: {
 965         skip "no exec() on MacOS Classic" if $Is_MacOS;
 966
 967         eval {
 968             no warnings;
 969             exec("lskdfj does not exist","with","args");
 970         };
 971         test !$@;
 972     }
 973
 974     # If you add tests here update also the above skip block for VMS.
 975 }
 976
 977 {
 978     # [ID 20020704.001] taint propagation failure
 979     use re 'taint';
 980     $TAINT =~ /(.*)/;
 981     test tainted(my $foo = $1);
 982 }
 983
 984 {
 985     # [perl #24291] this used to dump core
 986     our %nonmagicalenv = ( PATH => "util" );
 987     local *ENV = \%nonmagicalenv;
 988     eval { system("lskdfj"); };
 989     test $@ =~ /^%ENV is aliased to another variable while running with -T switch/;
 990     local *ENV = *nonmagicalenv;
 991     eval { system("lskdfj"); };
 992     test $@ =~ /^%ENV is aliased to %nonmagicalenv while running with -T switch/;
 993 }
 994 {
 995     # [perl #24248]
 996     $TAINT =~ /(.*)/;
 997     test !tainted($1);
 998     my $notaint = $1;
 999     test !tainted($notaint);
1000
1001     my $l;
1002     $notaint =~ /($notaint)/;
1003     $l = $1;
1004     test !tainted($1);
1005     test !tainted($l);
1006     $notaint =~ /($TAINT)/;
1007     $l = $1;
1008     test tainted($1);
1009     test tainted($l);
1010
1011     $TAINT =~ /($notaint)/;
1012     $l = $1;
1013     test !tainted($1);
1014     test !tainted($l);
1015     $TAINT =~ /($TAINT)/;
1016     $l = $1;
1017     test tainted($1);
1018     test tainted($l);
1019
1020     my $r;
1021     ($r = $TAINT) =~ /($notaint)/;
1022     test !tainted($1);
1023     ($r = $TAINT) =~ /($TAINT)/;
1024     test tainted($1);
1025
1026     #  [perl #24674]
1027     # accessing $^O  shoudn't taint it as a side-effect;
1028     # assigning tainted data to it is now an error
1029
1030     test !tainted($^O);
1031     if (!$^X) { } elsif ($^O eq 'bar') { }
1032     test !tainted($^O);
1033     eval '$^O = $^X';
1034     test $@ =~ /Insecure dependency in/;
1035 }
1036
1037 EFFECTIVELY_CONSTANTS: {
1038     my $tainted_number = 12 + $TAINT0;
1039     test tainted( $tainted_number );
1040
1041     # Even though it's always 0, it's still tainted
1042     my $tainted_product = $tainted_number * 0;
1043     test tainted( $tainted_product );
1044     test $tainted_product == 0;
1045 }
1046
1047 TERNARY_CONDITIONALS: {
1048     my $tainted_true  = $TAINT . "blah blah blah";
1049     my $tainted_false = $TAINT0;
1050     test tainted( $tainted_true );
1051     test tainted( $tainted_false );
1052
1053     my $result = $tainted_true ? "True" : "False";
1054     test $result eq "True";
1055     test !tainted( $result );
1056
1057     $result = $tainted_false ? "True" : "False";
1058     test $result eq "False";
1059     test !tainted( $result );
1060
1061     my $untainted_whatever = "The Fabulous Johnny Cash";
1062     my $tainted_whatever = "Soft Cell" . $TAINT;
1063
1064     $result = $tainted_true ? $tainted_whatever : $untainted_whatever;
1065     test $result eq "Soft Cell";
1066     test tainted( $result );
1067
1068     $result = $tainted_false ? $tainted_whatever : $untainted_whatever;
1069     test $result eq "The Fabulous Johnny Cash";
1070     test !tainted( $result );
1071 }
1072
1073 {
1074     # rt.perl.org 5900  $1 remains tainted if...
1075     # 1) The regular expression contains a scalar variable AND
1076     # 2) The regular expression appears in an elsif clause
1077
1078     my $foo = "abcdefghi" . $TAINT;
1079
1080     my $valid_chars = 'a-z';
1081     if ( $foo eq '' ) {
1082     }
1083     elsif ( $foo =~ /([$valid_chars]+)/o ) {
1084         test not tainted $1;
1085     }
1086
1087     if ( $foo eq '' ) {
1088     }
1089     elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) {
1090         test not any_tainted @bar;
1091     }
1092 }
1093
1094 # at scope exit, a restored localised value should have its old
1095 # taint status, not the taint status of the current statement
1096
1097 {
1098     our $x99 = $^X;
1099     test tainted $x99;
1100
1101     $x99 = '';
1102     test not tainted $x99;
1103
1104     my $c = do { local $x99; $^X };
1105     test not tainted $x99;
1106 }
1107 {
1108     our $x99 = $^X;
1109     test tainted $x99;
1110
1111     my $c = do { local $x99; '' };
1112     test tainted $x99;
1113 }
1114
1115 # an mg_get of a tainted value during localization shouldn't taint the
1116 # statement
1117
1118 {
1119     eval { local $0, eval '1' };
1120     test $@ eq '';
1121 }
1122
1123 # [perl #8262] //g loops infinitely on tainted data
1124
1125 {
1126     my @a;
1127     local $::TODO = 1;
1128     $a[0] = $^X;
1129     my $i = 0;
1130     while($a[0]=~ m/(.)/g ) {
1131         last if $i++ > 10000;
1132     }
1133     cmp_ok $i, '<', 10000, "infinite m//g";
1134 }
1135
1136 SKIP:
1137 {
1138     my $got_dualvar;
1139     eval 'use Scalar::Util "dualvar"; $got_dualvar++';
1140     skip "No Scalar::Util::dualvar" unless $got_dualvar;
1141     my $a = Scalar::Util::dualvar(3, $^X);
1142     my $b = $a + 5;
1143     is ($b, 8, "Arithmetic on tainted dualvars works");
1144 }
1145
1146 # opening '|-' should not trigger $ENV{PATH} check
1147
1148 {
1149     SKIP: {
1150         skip "fork() is not available", 3 unless $Config{'d_fork'};
1151         skip "opening |- is not stable on threaded OpenBSD with taint", 3
1152             if $Config{useithreads} && $Is_OpenBSD;
1153
1154         $ENV{'PATH'} = $TAINT;
1155         local $SIG{'PIPE'} = 'IGNORE';
1156         eval {
1157             my $pid = open my $pipe, '|-';
1158             if (!defined $pid) {
1159                 die "open failed: $!";
1160             }
1161             if (!$pid) {
1162                 kill 'KILL', $$;        # child suicide
1163             }
1164             close $pipe;
1165         };
1166         test $@ !~ /Insecure \$ENV/, 'fork triggers %ENV check';
1167         test $@ eq '',               'pipe/fork/open/close failed';
1168         eval {
1169             open my $pipe, "|$Invoke_Perl -e 1";
1170             close $pipe;
1171         };
1172         test $@ =~ /Insecure \$ENV/, 'popen neglects %ENV check';
1173     }
1174 }
1175
1176 {
1177     package AUTOLOAD_TAINT;
1178     sub AUTOLOAD {
1179         our $AUTOLOAD;
1180         return if $AUTOLOAD =~ /DESTROY/;
1181         if ($AUTOLOAD =~ /untainted/) {
1182             main::ok(!main::tainted($AUTOLOAD), '$AUTOLOAD can be untainted');
1183         } else {
1184             main::ok(main::tainted($AUTOLOAD), '$AUTOLOAD can be tainted');
1185         }
1186     }
1187
1188     package main;
1189     my $o = bless [], 'AUTOLOAD_TAINT';
1190     $o->$TAINT;
1191     $o->untainted;
1192 }
1193
1194 {
1195     # tests for tainted format in s?printf
1196     eval { printf($TAINT . "# %s\n", "foo") };
1197     like($@, qr/^Insecure dependency in printf/, q/printf doesn't like tainted formats/);
1198     eval { printf("# %s\n", $TAINT . "foo") };
1199     ok(!$@, q/printf accepts other tainted args/);
1200     eval { sprintf($TAINT . "# %s\n", "foo") };
1201     like($@, qr/^Insecure dependency in sprintf/, q/sprintf doesn't like tainted formats/);
1202     eval { sprintf("# %s\n", $TAINT . "foo") };
1203     ok(!$@, q/sprintf accepts other tainted args/);
1204 }
1205
1206 {
1207     # 40708
1208     my $n  = 7e9;
1209     8e9 - $n;
1210
1211     my $val = $n;
1212     is ($val, '7000000000', 'Assignment to untainted variable');
1213     $val = $TAINT;
1214     $val = $n;
1215     is ($val, '7000000000', 'Assignment to tainted variable');
1216 }
1217
1218 {
1219     my $val = 0;
1220     my $tainted = '1' . $TAINT;
1221     eval '$val = eval $tainted;';
1222     is ($val, 0, "eval doesn't like tainted strings");
1223     like ($@, qr/^Insecure dependency in eval/);
1224
1225     # Rather nice code to get a tainted undef by from Rick Delaney
1226     open FH, "test.pl" or die $!;
1227     seek FH, 0, 2 or die $!;
1228     $tainted = <FH>;
1229
1230     eval 'eval $tainted';
1231     like ($@, qr/^Insecure dependency in eval/);
1232 }
1233
1234 # This may bomb out with the alarm signal so keep it last
1235 SKIP: {
1236     skip "No alarm()"  unless $Config{d_alarm};
1237     # Test from RT #41831]
1238     # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x)
1239
1240     my $DATA = <<'END' . $TAINT;
1241 line1 is here
1242 line2 is here
1243 line3 is here
1244 line4 is here
1245
1246 END
1247
1248     #study $DATA;
1249
1250     ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as
1251     ## perl is stuck in a regexp infinite loop!
1252
1253     alarm(10);
1254
1255     if ($DATA =~ /^line2.*line4/m) {
1256         fail("Should not be a match")
1257     } else {
1258         pass("Match on tainted multiline data should fail promptly");
1259     }
1260
1261     alarm(0);
1262 }
1263 __END__
1264 # Keep the previous test last