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