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 => 244;
  21
  22
  23 $| = 1;
  24
  25 use vars qw($ipcsysv); # did we manage to load IPC::SysV?
  26
  27 BEGIN {
  28   if ($^O eq 'VMS' && !defined($Config{d_setenv})) {
  29       $ENV{PATH} = $ENV{PATH};
  30       $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy';
  31   }
  32   if ($Config{'extensions'} =~ /\bIPC\/SysV\b/
  33       && ($Config{d_shm} || $Config{d_msg})) {
  34       eval { require IPC::SysV };
  35       unless ($@) {
  36           $ipcsysv++;
  37           IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT));
  38       }
  39   }
  40 }
  41
  42 my $Is_MacOS    = $^O eq 'MacOS';
  43 my $Is_VMS      = $^O eq 'VMS';
  44 my $Is_MSWin32  = $^O eq 'MSWin32';
  45 my $Is_NetWare  = $^O eq 'NetWare';
  46 my $Is_Dos      = $^O eq 'dos';
  47 my $Is_Cygwin   = $^O eq 'cygwin';
  48 my $Invoke_Perl = $Is_VMS      ? 'MCR Sys$Disk:[]Perl.' :
  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     if ($Is_Cygwin && ! -f 'cygwin1.dll') {
 159         system("/usr/bin/cp /usr/bin/cygwin1.dll .") &&
 160             die "$0: failed to cp cygwin1.dll: $!\n";
 161         eval q{
 162             END { unlink "cygwin1.dll" }
 163         };
 164     }
 165
 166     if ($Is_Cygwin && ! -f 'cygcrypt-0.dll' && -f '/usr/bin/cygcrypt-0.dll') {
 167         system("/usr/bin/cp /usr/bin/cygcrypt-0.dll .") &&
 168             die "$0: failed to cp cygcrypt-0.dll: $!\n";
 169         eval q{
 170             END { unlink "cygcrypt-0.dll" }
 171         };
 172     }
 173
 174     test eval { `$echo 1` } eq "1\n";
 175
 176     SKIP: {
 177         skip "Environment tainting tests skipped", 4
 178           if $Is_MSWin32 || $Is_NetWare || $Is_VMS || $Is_Dos || $Is_MacOS;
 179
 180         my @vars = ('PATH', @MoreEnv);
 181         while (my $v = $vars[0]) {
 182             local $ENV{$v} = $TAINT;
 183             last if eval { `$echo 1` };
 184             last unless $@ =~ /^Insecure \$ENV{$v}/;
 185             shift @vars;
 186         }
 187         test !@vars, "@vars";
 188
 189         # tainted $TERM is unsafe only if it contains metachars
 190         local $ENV{TERM};
 191         $ENV{TERM} = 'e=mc2';
 192         test eval { `$echo 1` } eq "1\n";
 193         $ENV{TERM} = 'e=mc2' . $TAINT;
 194         test !eval { `$echo 1` };
 195         test $@ =~ /^Insecure \$ENV{TERM}/, $@;
 196     }
 197
 198     my $tmp;
 199     if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_NetWare || $Is_Dos) {
 200         print "# all directories are writeable\n";
 201     }
 202     else {
 203         $tmp = (grep { defined and -d and (stat _)[2] & 2 }
 204                      qw(sys$scratch /tmp /var/tmp /usr/tmp),
 205                      @ENV{qw(TMP TEMP)})[0]
 206             or print "# can't find world-writeable directory to test PATH\n";
 207     }
 208
 209     SKIP: {
 210         skip "all directories are writeable", 2 unless $tmp;
 211
 212         local $ENV{PATH} = $tmp;
 213         test !eval { `$echo 1` };
 214         test $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
 215     }
 216
 217     SKIP: {
 218         skip "This is not VMS", 4 unless $Is_VMS;
 219
 220         $ENV{'DCL$PATH'} = $TAINT;
 221         test  eval { `$echo 1` } eq '';
 222         test $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
 223         SKIP: {
 224             skip q[can't find world-writeable directory to test DCL$PATH], 2
 225               unless $tmp;
 226
 227             $ENV{'DCL$PATH'} = $tmp;
 228             test eval { `$echo 1` } eq '';
 229             test $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@;
 230         }
 231         $ENV{'DCL$PATH'} = '';
 232     }
 233 }
 234
 235 # Let's see that we can taint and untaint as needed.
 236 {
 237     my $foo = $TAINT;
 238     test tainted $foo;
 239
 240     # That was a sanity check. If it failed, stop the insanity!
 241     die "Taint checks don't seem to be enabled" unless tainted $foo;
 242
 243     $foo = "foo";
 244     test not tainted $foo;
 245
 246     taint_these($foo);
 247     test tainted $foo;
 248
 249     my @list = 1..10;
 250     test not any_tainted @list;
 251     taint_these @list[1,3,5,7,9];
 252     test any_tainted @list;
 253     test all_tainted @list[1,3,5,7,9];
 254     test not any_tainted @list[0,2,4,6,8];
 255
 256     ($foo) = $foo =~ /(.+)/;
 257     test not tainted $foo;
 258
 259     $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
 260     test not tainted $foo;
 261     test $foo eq 'bar';
 262
 263     {
 264       use re 'taint';
 265
 266       ($foo) = ('bar' . $TAINT) =~ /(.+)/;
 267       test tainted $foo;
 268       test $foo eq 'bar';
 269
 270       $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
 271       test tainted $foo;
 272       test $foo eq 'bar';
 273     }
 274
 275     $foo = $1 if 'bar' =~ /(.+)$TAINT/;
 276     test tainted $foo;
 277     test $foo eq 'bar';
 278
 279     my $pi = 4 * atan2(1,1) + $TAINT0;
 280     test tainted $pi;
 281
 282     ($pi) = $pi =~ /(\d+\.\d+)/;
 283     test not tainted $pi;
 284     test sprintf("%.5f", $pi) eq '3.14159';
 285 }
 286
 287 # How about command-line arguments? The problem is that we don't
 288 # always get some, so we'll run another process with some.
 289 SKIP: {
 290     my $arg = catfile(curdir(), "arg$$");
 291     open PROG, "> $arg" or die "Can't create $arg: $!";
 292     print PROG q{
 293         eval { join('', @ARGV), kill 0 };
 294         exit 0 if $@ =~ /^Insecure dependency/;
 295         print "# Oops: \$@ was [$@]\n";
 296         exit 1;
 297     };
 298     close PROG;
 299     print `$Invoke_Perl "-T" $arg and some suspect arguments`;
 300     test !$?, "Exited with status $?";
 301     unlink $arg;
 302 }
 303
 304 # Reading from a file should be tainted
 305 {
 306     test open(FILE, $TEST), "Couldn't open '$TEST': $!";
 307
 308     my $block;
 309     sysread(FILE, $block, 100);
 310     my $line = <FILE>;
 311     close FILE;
 312     test tainted $block;
 313     test tainted $line;
 314 }
 315
 316 # Globs should be forbidden, except under VMS,
 317 #   which doesn't spawn an external program.
 318 SKIP: {
 319     skip "globs should be forbidden", 2 if 1 or $Is_VMS;
 320
 321     my @globs = eval { <*> };
 322     test @globs == 0 && $@ =~ /^Insecure dependency/;
 323
 324     @globs = eval { glob '*' };
 325     test @globs == 0 && $@ =~ /^Insecure dependency/;
 326 }
 327
 328 # Output of commands should be tainted
 329 {
 330     my $foo = `$echo abc`;
 331     test tainted $foo;
 332 }
 333
 334 # Certain system variables should be tainted
 335 {
 336     test all_tainted $^X, $0;
 337 }
 338
 339 # Results of matching should all be untainted
 340 {
 341     my $foo = "abcdefghi" . $TAINT;
 342     test tainted $foo;
 343
 344     $foo =~ /def/;
 345     test not any_tainted $`, $&, $';
 346
 347     $foo =~ /(...)(...)(...)/;
 348     test not any_tainted $1, $2, $3, $+;
 349
 350     my @bar = $foo =~ /(...)(...)(...)/;
 351     test not any_tainted @bar;
 352
 353     test tainted $foo;  # $foo should still be tainted!
 354     test $foo eq "abcdefghi";
 355 }
 356
 357 # Operations which affect files can't use tainted data.
 358 {
 359     test !eval { chmod 0, $TAINT }, 'chmod';
 360     test $@ =~ /^Insecure dependency/, $@;
 361
 362     # There is no feature test in $Config{} for truncate,
 363     #   so we allow for the possibility that it's missing.
 364     test !eval { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate';
 365     test $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
 366
 367     test !eval { rename '', $TAINT }, 'rename';
 368     test $@ =~ /^Insecure dependency/, $@;
 369
 370     test !eval { unlink $TAINT }, 'unlink';
 371     test $@ =~ /^Insecure dependency/, $@;
 372
 373     test !eval { utime $TAINT }, 'utime';
 374     test $@ =~ /^Insecure dependency/, $@;
 375
 376     SKIP: {
 377         skip "chown() is not available", 2 unless $Config{d_chown};
 378
 379         test !eval { chown -1, -1, $TAINT }, 'chown';
 380         test $@ =~ /^Insecure dependency/, $@;
 381     }
 382
 383     SKIP: {
 384         skip "link() is not available", 2 unless $Config{d_link};
 385
 386         test !eval { link $TAINT, '' }, 'link';
 387         test $@ =~ /^Insecure dependency/, $@;
 388     }
 389
 390     SKIP: {
 391         skip "symlink() is not available", 2 unless $Config{d_symlink};
 392
 393         test !eval { symlink $TAINT, '' }, 'symlink';
 394         test $@ =~ /^Insecure dependency/, $@;
 395     }
 396 }
 397
 398 # Operations which affect directories can't use tainted data.
 399 {
 400     test !eval { mkdir "foo".$TAINT, 0755.$TAINT0 }, 'mkdir';
 401     test $@ =~ /^Insecure dependency/, $@;
 402
 403     test !eval { rmdir $TAINT }, 'rmdir';
 404     test $@ =~ /^Insecure dependency/, $@;
 405
 406     test !eval { chdir "foo".$TAINT }, 'chdir';
 407     test $@ =~ /^Insecure dependency/, $@;
 408
 409     SKIP: {
 410         skip "chroot() is not available", 2 unless $Config{d_chroot};
 411
 412         test !eval { chroot $TAINT }, 'chroot';
 413         test $@ =~ /^Insecure dependency/, $@;
 414     }
 415 }
 416
 417 # Some operations using files can't use tainted data.
 418 {
 419     my $foo = "imaginary library" . $TAINT;
 420     test !eval { require $foo }, 'require';
 421     test $@ =~ /^Insecure dependency/, $@;
 422
 423     my $filename = "./taintB$$";        # NB: $filename isn't tainted!
 424     END { unlink $filename if defined $filename }
 425     $foo = $filename . $TAINT;
 426     unlink $filename;   # in any case
 427
 428     test !eval { open FOO, $foo }, 'open for read';
 429     test $@ eq '', $@;          # NB: This should be allowed
 430
 431     # Try first new style but allow also old style.
 432     # We do not want the whole taint.t to fail
 433     # just because Errno possibly failing.
 434     test eval('$!{ENOENT}') ||
 435         $! == 2 || # File not found
 436         ($Is_Dos && $! == 22) ||
 437         ($^O eq 'mint' && $! == 33);
 438
 439     test !eval { open FOO, "> $foo" }, 'open for write';
 440     test $@ =~ /^Insecure dependency/, $@;
 441 }
 442
 443 # Commands to the system can't use tainted data
 444 {
 445     my $foo = $TAINT;
 446
 447     SKIP: {
 448         skip "open('|') is not available", 4 if $^O eq 'amigaos';
 449
 450         test !eval { open FOO, "| x$foo" }, 'popen to';
 451         test $@ =~ /^Insecure dependency/, $@;
 452
 453         test !eval { open FOO, "x$foo |" }, 'popen from';
 454         test $@ =~ /^Insecure dependency/, $@;
 455     }
 456
 457     test !eval { exec $TAINT }, 'exec';
 458     test $@ =~ /^Insecure dependency/, $@;
 459
 460     test !eval { system $TAINT }, 'system';
 461     test $@ =~ /^Insecure dependency/, $@;
 462
 463     $foo = "*";
 464     taint_these $foo;
 465
 466     test !eval { `$echo 1$foo` }, 'backticks';
 467     test $@ =~ /^Insecure dependency/, $@;
 468
 469     SKIP: {
 470         # wildcard expansion doesn't invoke shell on VMS, so is safe
 471         skip "This is not VMS", 2 unless $Is_VMS;
 472
 473         test join('', eval { glob $foo } ) ne '', 'globbing';
 474         test $@ eq '', $@;
 475     }
 476 }
 477
 478 # Operations which affect processes can't use tainted data.
 479 {
 480     test !eval { kill 0, $TAINT }, 'kill';
 481     test $@ =~ /^Insecure dependency/, $@;
 482
 483     SKIP: {
 484         skip "setpgrp() is not available", 2 unless $Config{d_setpgrp};
 485
 486         test !eval { setpgrp 0, $TAINT0 }, 'setpgrp';
 487         test $@ =~ /^Insecure dependency/, $@;
 488     }
 489
 490     SKIP: {
 491         skip "setpriority() is not available", 2 unless $Config{d_setprior};
 492
 493         test !eval { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority';
 494         test $@ =~ /^Insecure dependency/, $@;
 495     }
 496 }
 497
 498 # Some miscellaneous operations can't use tainted data.
 499 {
 500     SKIP: {
 501         skip "syscall() is not available", 2 unless $Config{d_syscall};
 502
 503         test !eval { syscall $TAINT }, 'syscall';
 504         test $@ =~ /^Insecure dependency/, $@;
 505     }
 506
 507     {
 508         my $foo = "x" x 979;
 509         taint_these $foo;
 510         local *FOO;
 511         my $temp = "./taintC$$";
 512         END { unlink $temp }
 513         test open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
 514
 515         test !eval { ioctl FOO, $TAINT0, $foo }, 'ioctl';
 516         test $@ =~ /^Insecure dependency/, $@;
 517
 518         SKIP: {
 519             skip "fcntl() is not available", 2 unless $Config{d_fcntl};
 520
 521             test !eval { fcntl FOO, $TAINT0, $foo }, 'fcntl';
 522             test $@ =~ /^Insecure dependency/, $@;
 523         }
 524
 525         close FOO;
 526     }
 527 }
 528
 529 # Some tests involving references
 530 {
 531     my $foo = 'abc' . $TAINT;
 532     my $fooref = \$foo;
 533     test not tainted $fooref;
 534     test tainted $$fooref;
 535     test tainted $foo;
 536 }
 537
 538 # Some tests involving assignment
 539 {
 540     my $foo = $TAINT0;
 541     my $bar = $foo;
 542     test all_tainted $foo, $bar;
 543     test tainted($foo = $bar);
 544     test tainted($bar = $bar);
 545     test tainted($bar += $bar);
 546     test tainted($bar -= $bar);
 547     test tainted($bar *= $bar);
 548     test tainted($bar++);
 549     test tainted($bar /= $bar);
 550     test tainted($bar += 0);
 551     test tainted($bar -= 2);
 552     test tainted($bar *= -1);
 553     test tainted($bar /= 1);
 554     test tainted($bar--);
 555     test $bar == 0;
 556 }
 557
 558 # Test assignment and return of lists
 559 {
 560     my @foo = ("A", "tainted" . $TAINT, "B");
 561     test not tainted $foo[0];
 562     test     tainted $foo[1];
 563     test not tainted $foo[2];
 564     my @bar = @foo;
 565     test not tainted $bar[0];
 566     test     tainted $bar[1];
 567     test not tainted $bar[2];
 568     my @baz = eval { "A", "tainted" . $TAINT, "B" };
 569     test not tainted $baz[0];
 570     test     tainted $baz[1];
 571     test not tainted $baz[2];
 572     my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
 573     test not tainted $plugh[0];
 574     test     tainted $plugh[1];
 575     test not tainted $plugh[2];
 576     my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
 577     test not tainted ((&$nautilus)[0]);
 578     test     tainted ((&$nautilus)[1]);
 579     test not tainted ((&$nautilus)[2]);
 580     my @xyzzy = &$nautilus;
 581     test not tainted $xyzzy[0];
 582     test     tainted $xyzzy[1];
 583     test not tainted $xyzzy[2];
 584     my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
 585     test not tainted ((&$red_october)[0]);
 586     test     tainted ((&$red_october)[1]);
 587     test not tainted ((&$red_october)[2]);
 588     my @corge = &$red_october;
 589     test not tainted $corge[0];
 590     test     tainted $corge[1];
 591     test not tainted $corge[2];
 592 }
 593
 594 # Test for system/library calls returning string data of dubious origin.
 595 {
 596     # No reliable %Config check for getpw*
 597     SKIP: {
 598         skip "getpwent() is not available", 1 unless
 599           eval { setpwent(); getpwent() };
 600
 601         setpwent();
 602         my @getpwent = getpwent();
 603         die "getpwent: $!\n" unless (@getpwent);
 604         test (    not tainted $getpwent[0]
 605                   and     tainted $getpwent[1]
 606                   and not tainted $getpwent[2]
 607                   and not tainted $getpwent[3]
 608                   and not tainted $getpwent[4]
 609                   and not tainted $getpwent[5]
 610                   and     tainted $getpwent[6]          # ge?cos
 611                   and not tainted $getpwent[7]
 612                   and     tainted $getpwent[8]);        # shell
 613         endpwent();
 614     }
 615
 616     SKIP: {
 617         # pretty hard to imagine not
 618         skip "readdir() is not available", 1 unless $Config{d_readdir};
 619
 620         local(*D);
 621         opendir(D, "op") or die "opendir: $!\n";
 622         my $readdir = readdir(D);
 623         test tainted $readdir;
 624         closedir(D);
 625     }
 626
 627     SKIP: {
 628         skip "readlink() or symlink() is not available" unless
 629           $Config{d_readlink} && $Config{d_symlink};
 630
 631         my $symlink = "sl$$";
 632         unlink($symlink);
 633         my $sl = "/something/naughty";
 634         # it has to be a real path on Mac OS
 635         $sl = MacPerl::MakePath((MacPerl::Volumes())[0]) if $Is_MacOS;
 636         symlink($sl, $symlink) or die "symlink: $!\n";
 637         my $readlink = readlink($symlink);
 638         test tainted $readlink;
 639         unlink($symlink);
 640     }
 641 }
 642
 643 # test bitwise ops (regression bug)
 644 {
 645     my $why = "y";
 646     my $j = "x" | $why;
 647     test not tainted $j;
 648     $why = $TAINT."y";
 649     $j = "x" | $why;
 650     test     tainted $j;
 651 }
 652
 653 # test target of substitution (regression bug)
 654 {
 655     my $why = $TAINT."y";
 656     $why =~ s/y/z/;
 657     test     tainted $why;
 658
 659     my $z = "[z]";
 660     $why =~ s/$z/zee/;
 661     test     tainted $why;
 662
 663     $why =~ s/e/'-'.$$/ge;
 664     test     tainted $why;
 665 }
 666
 667
 668 SKIP: {
 669     skip "no IPC::SysV", 2 unless $ipcsysv;
 670
 671     # test shmread
 672     SKIP: {
 673         skip "shm*() not available", 1 unless $Config{d_shm};
 674
 675         no strict 'subs';
 676         my $sent = "foobar";
 677         my $rcvd;
 678         my $size = 2000;
 679         my $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
 680
 681         if (defined $id) {
 682             if (shmwrite($id, $sent, 0, 60)) {
 683                 if (shmread($id, $rcvd, 0, 60)) {
 684                     substr($rcvd, index($rcvd, "\0")) = '';
 685                 } else {
 686                     warn "# shmread failed: $!\n";
 687                 }
 688             } else {
 689                 warn "# shmwrite failed: $!\n";
 690             }
 691             shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n";
 692         } else {
 693             warn "# shmget failed: $!\n";
 694         }
 695
 696         skip "SysV shared memory operation failed", 1 unless
 697           $rcvd eq $sent;
 698
 699         test tainted $rcvd;
 700     }
 701
 702
 703     # test msgrcv
 704     SKIP: {
 705         skip "msg*() not available", 1 unless $Config{d_msg};
 706
 707         no strict 'subs';
 708         my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
 709
 710         my $sent      = "message";
 711         my $type_sent = 1234;
 712         my $rcvd;
 713         my $type_rcvd;
 714
 715         if (defined $id) {
 716             if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) {
 717                 if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) {
 718                     ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd);
 719                 } else {
 720                     warn "# msgrcv failed: $!\n";
 721                 }
 722             } else {
 723                 warn "# msgsnd failed: $!\n";
 724             }
 725             msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n";
 726         } else {
 727             warn "# msgget failed\n";
 728         }
 729
 730         SKIP: {
 731             skip "SysV message queue operation failed", 1
 732               unless $rcvd eq $sent && $type_sent == $type_rcvd;
 733
 734             test tainted $rcvd;
 735         }
 736     }
 737 }
 738
 739 {
 740     # bug id 20001004.006
 741
 742     open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
 743     local $/;
 744     my $a = <IN>;
 745     my $b = <IN>;
 746
 747     ok tainted($a) && tainted($b) && !defined($b);
 748
 749     close IN;
 750 }
 751
 752 {
 753     # bug id 20001004.007
 754
 755     open IN, $TEST or warn "$0: cannot read $TEST: $!" ;
 756     my $a = <IN>;
 757
 758     my $c = { a => 42,
 759               b => $a };
 760
 761     ok !tainted($c->{a}) && tainted($c->{b});
 762
 763
 764     my $d = { a => $a,
 765               b => 42 };
 766     ok tainted($d->{a}) && !tainted($d->{b});
 767
 768
 769     my $e = { a => 42,
 770               b => { c => $a, d => 42 } };
 771     ok !tainted($e->{a}) &&
 772        !tainted($e->{b}) &&
 773         tainted($e->{b}->{c}) &&
 774        !tainted($e->{b}->{d});
 775
 776     close IN;
 777 }
 778
 779 {
 780     # bug id 20010519.003
 781
 782     BEGIN {
 783         use vars qw($has_fcntl);
 784         eval { require Fcntl; import Fcntl; };
 785         unless ($@) {
 786             $has_fcntl = 1;
 787         }
 788     }
 789
 790     SKIP: {
 791         skip "no Fcntl", 18 unless $has_fcntl;
 792
 793         my $evil = "foo" . $TAINT;
 794
 795         eval { sysopen(my $ro, $evil, &O_RDONLY) };
 796         test $@ !~ /^Insecure dependency/, $@;
 797
 798         eval { sysopen(my $wo, $evil, &O_WRONLY) };
 799         test $@ =~ /^Insecure dependency/, $@;
 800
 801         eval { sysopen(my $rw, $evil, &O_RDWR) };
 802         test $@ =~ /^Insecure dependency/, $@;
 803
 804         eval { sysopen(my $ap, $evil, &O_APPEND) };
 805         test $@ =~ /^Insecure dependency/, $@;
 806
 807         eval { sysopen(my $cr, $evil, &O_CREAT) };
 808         test $@ =~ /^Insecure dependency/, $@;
 809
 810         eval { sysopen(my $tr, $evil, &O_TRUNC) };
 811         test $@ =~ /^Insecure dependency/, $@;
 812
 813         eval { sysopen(my $ro, "foo", &O_RDONLY | $TAINT0) };
 814         test $@ !~ /^Insecure dependency/, $@;
 815
 816         eval { sysopen(my $wo, "foo", &O_WRONLY | $TAINT0) };
 817         test $@ =~ /^Insecure dependency/, $@;
 818
 819         eval { sysopen(my $rw, "foo", &O_RDWR | $TAINT0) };
 820         test $@ =~ /^Insecure dependency/, $@;
 821
 822         eval { sysopen(my $ap, "foo", &O_APPEND | $TAINT0) };
 823         test $@ =~ /^Insecure dependency/, $@;
 824
 825         eval { sysopen(my $cr, "foo", &O_CREAT | $TAINT0) };
 826         test $@ =~ /^Insecure dependency/, $@;
 827
 828         eval { sysopen(my $tr, "foo", &O_TRUNC | $TAINT0) };
 829         test $@ =~ /^Insecure dependency/, $@;
 830
 831         eval { sysopen(my $ro, "foo", &O_RDONLY, $TAINT0) };
 832         test $@ !~ /^Insecure dependency/, $@;
 833
 834         eval { sysopen(my $wo, "foo", &O_WRONLY, $TAINT0) };
 835         test $@ =~ /^Insecure dependency/, $@;
 836
 837         eval { sysopen(my $rw, "foo", &O_RDWR, $TAINT0) };
 838         test $@ =~ /^Insecure dependency/, $@;
 839
 840         eval { sysopen(my $ap, "foo", &O_APPEND, $TAINT0) };
 841         test $@ =~ /^Insecure dependency/, $@;
 842
 843         eval { sysopen(my $cr, "foo", &O_CREAT, $TAINT0) };
 844         test $@ =~ /^Insecure dependency/, $@;
 845
 846         eval { sysopen(my $tr, "foo", &O_TRUNC, $TAINT0) };
 847         test $@ =~ /^Insecure dependency/, $@;
 848
 849         unlink("foo"); # not unlink($evil), because that would fail...
 850     }
 851 }
 852
 853 {
 854     # bug 20010526.004
 855
 856     use warnings;
 857
 858     my $saw_warning = 0;
 859     local $SIG{__WARN__} = sub { $saw_warning = 1 };
 860
 861     sub fmi {
 862         my $divnum = shift()/1;
 863         sprintf("%1.1f\n", $divnum);
 864     }
 865
 866     fmi(21 . $TAINT);
 867     fmi(37);
 868     fmi(248);
 869
 870     test !$saw_warning;
 871 }
 872
 873
 874 {
 875     # Bug ID 20010730.010
 876
 877     my $i = 0;
 878
 879     sub Tie::TIESCALAR {
 880         my $class =  shift;
 881         my $arg   =  shift;
 882
 883         bless \$arg => $class;
 884     }
 885
 886     sub Tie::FETCH {
 887         $i ++;
 888         ${$_ [0]}
 889     }
 890
 891
 892     package main;
 893
 894     my $bar = "The Big Bright Green Pleasure Machine";
 895     taint_these $bar;
 896     tie my ($foo), Tie => $bar;
 897
 898     my $baz = $foo;
 899
 900     ok $i == 1;
 901 }
 902
 903 {
 904     # Check that all environment variables are tainted.
 905     my @untainted;
 906     while (my ($k, $v) = each %ENV) {
 907         if (!tainted($v) &&
 908             # These we have explicitly untainted or set earlier.
 909             $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP)$/) {
 910             push @untainted, "# '$k' = '$v'\n";
 911         }
 912     }
 913     test @untainted == 0, "untainted:\n @untainted";
 914 }
 915
 916
 917 ok( ${^TAINT} == 1, '$^TAINT is on' );
 918
 919 eval { ${^TAINT} = 0 };
 920 ok( ${^TAINT},  '$^TAINT is not assignable' );
 921 ok( $@ =~ /^Modification of a read-only value attempted/,
 922                                 'Assigning to ${^TAINT} fails' );
 923
 924 {
 925     # bug 20011111.105
 926
 927     my $re1 = qr/x$TAINT/;
 928     test tainted $re1;
 929
 930     my $re2 = qr/^$re1\z/;
 931     test tainted $re2;
 932
 933     my $re3 = "$re2";
 934     test tainted $re3;
 935 }
 936
 937 SKIP: {
 938     skip "system {} has different semantics on Win32", 1 if $Is_MSWin32;
 939
 940     # bug 20010221.005
 941     local $ENV{PATH} .= $TAINT;
 942     eval { system { "echo" } "/arg0", "arg1" };
 943     test $@ =~ /^Insecure \$ENV/;
 944 }
 945
 946 TODO: {
 947     todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22
 948       if $Is_VMS;
 949
 950     # bug 20020208.005 plus some single arg exec/system extras
 951     my $err = qr/^Insecure dependency/ ;
 952     test !eval { exec $TAINT, $TAINT }, 'exec';
 953     test $@ =~ $err, $@;
 954     test !eval { exec $TAINT $TAINT }, 'exec';
 955     test $@ =~ $err, $@;
 956     test !eval { exec $TAINT $TAINT, $TAINT }, 'exec';
 957     test $@ =~ $err, $@;
 958     test !eval { exec $TAINT 'notaint' }, 'exec';
 959     test $@ =~ $err, $@;
 960     test !eval { exec {'notaint'} $TAINT }, 'exec';
 961     test $@ =~ $err, $@;
 962
 963     test !eval { system $TAINT, $TAINT }, 'system';
 964     test $@ =~ $err, $@;
 965     test !eval { system $TAINT $TAINT }, 'system';
 966     test $@ =~ $err, $@;
 967     test !eval { system $TAINT $TAINT, $TAINT }, 'system';
 968     test $@ =~ $err, $@;
 969     test !eval { system $TAINT 'notaint' }, 'system';
 970     test $@ =~ $err, $@;
 971     test !eval { system {'notaint'} $TAINT }, 'system';
 972     test $@ =~ $err, $@;
 973
 974     eval {
 975         no warnings;
 976         system("lskdfj does not exist","with","args");
 977     };
 978     test !$@;
 979
 980     SKIP: {
 981         skip "no exec() on MacOS Classic" if $Is_MacOS;
 982
 983         eval {
 984             no warnings;
 985             exec("lskdfj does not exist","with","args");
 986         };
 987         test !$@;
 988     }
 989
 990     # If you add tests here update also the above skip block for VMS.
 991 }
 992
 993 {
 994     # [ID 20020704.001] taint propagation failure
 995     use re 'taint';
 996     $TAINT =~ /(.*)/;
 997     test tainted(my $foo = $1);
 998 }
 999
1000 {
1001     # [perl #24291] this used to dump core
1002     our %nonmagicalenv = ( PATH => "util" );
1003     local *ENV = \%nonmagicalenv;
1004     eval { system("lskdfj"); };
1005     test $@ =~ /^%ENV is aliased to another variable while running with -T switch/;
1006     local *ENV = *nonmagicalenv;
1007     eval { system("lskdfj"); };
1008     test $@ =~ /^%ENV is aliased to %nonmagicalenv while running with -T switch/;
1009 }
1010 {
1011     # [perl #24248]
1012     $TAINT =~ /(.*)/;
1013     test !tainted($1);
1014     my $notaint = $1;
1015     test !tainted($notaint);
1016
1017     my $l;
1018     $notaint =~ /($notaint)/;
1019     $l = $1;
1020     test !tainted($1);
1021     test !tainted($l);
1022     $notaint =~ /($TAINT)/;
1023     $l = $1;
1024     test tainted($1);
1025     test tainted($l);
1026
1027     $TAINT =~ /($notaint)/;
1028     $l = $1;
1029     test !tainted($1);
1030     test !tainted($l);
1031     $TAINT =~ /($TAINT)/;
1032     $l = $1;
1033     test tainted($1);
1034     test tainted($l);
1035
1036     my $r;
1037     ($r = $TAINT) =~ /($notaint)/;
1038     test !tainted($1);
1039     ($r = $TAINT) =~ /($TAINT)/;
1040     test tainted($1);
1041
1042     #  [perl #24674]
1043     # accessing $^O  shoudn't taint it as a side-effect;
1044     # assigning tainted data to it is now an error
1045
1046     test !tainted($^O);
1047     if (!$^X) { } elsif ($^O eq 'bar') { }
1048     test !tainted($^O);
1049     eval '$^O = $^X';
1050     test $@ =~ /Insecure dependency in/;
1051 }
1052
1053 EFFECTIVELY_CONSTANTS: {
1054     my $tainted_number = 12 + $TAINT0;
1055     test tainted( $tainted_number );
1056
1057     # Even though it's always 0, it's still tainted
1058     my $tainted_product = $tainted_number * 0;
1059     test tainted( $tainted_product );
1060     test $tainted_product == 0;
1061 }
1062
1063 TERNARY_CONDITIONALS: {
1064     my $tainted_true  = $TAINT . "blah blah blah";
1065     my $tainted_false = $TAINT0;
1066     test tainted( $tainted_true );
1067     test tainted( $tainted_false );
1068
1069     my $result = $tainted_true ? "True" : "False";
1070     test $result eq "True";
1071     test !tainted( $result );
1072
1073     $result = $tainted_false ? "True" : "False";
1074     test $result eq "False";
1075     test !tainted( $result );
1076
1077     my $untainted_whatever = "The Fabulous Johnny Cash";
1078     my $tainted_whatever = "Soft Cell" . $TAINT;
1079
1080     $result = $tainted_true ? $tainted_whatever : $untainted_whatever;
1081     test $result eq "Soft Cell";
1082     test tainted( $result );
1083
1084     $result = $tainted_false ? $tainted_whatever : $untainted_whatever;
1085     test $result eq "The Fabulous Johnny Cash";
1086     test !tainted( $result );
1087 }
1088
1089 {
1090     # rt.perl.org 5900  $1 remains tainted if...
1091     # 1) The regular expression contains a scalar variable AND
1092     # 2) The regular expression appears in an elsif clause
1093
1094     my $foo = "abcdefghi" . $TAINT;
1095
1096     my $valid_chars = 'a-z';
1097     if ( $foo eq '' ) {
1098     }
1099     elsif ( $foo =~ /([$valid_chars]+)/o ) {
1100         test not tainted $1;
1101     }
1102
1103     if ( $foo eq '' ) {
1104     }
1105     elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) {
1106         test not any_tainted @bar;
1107     }
1108 }
1109
1110 # at scope exit, a restored localised value should have its old
1111 # taint status, not the taint status of the current statement
1112
1113 {
1114     our $x99 = $^X;
1115     test tainted $x99;
1116
1117     $x99 = '';
1118     test not tainted $x99;
1119
1120     my $c = do { local $x99; $^X };
1121     test not tainted $x99;
1122 }
1123 {
1124     our $x99 = $^X;
1125     test tainted $x99;
1126
1127     my $c = do { local $x99; '' };
1128     test tainted $x99;
1129 }
1130
1131 # an mg_get of a tainted value during localization shouldn't taint the
1132 # statement
1133
1134 {
1135     eval { local $0, eval '1' };
1136     test $@ eq '';
1137 }