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