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 10BEGIN { 11 chdir 't' if -d 't'; 12 require './test.pl'; 13 set_up_inc('../lib'); 14 require './loc_tools.pl'; 15} 16 17use strict; 18use warnings; 19use Config; 20 21my $NoTaintSupport = exists($Config{taint_support}) && !$Config{taint_support}; 22 23if ($NoTaintSupport) { 24 skip_all("your perl was built without taint support"); 25 exit 0; 26} 27 28plan tests => 1065; 29 30$| = 1; 31 32my $ipcsysv; # did we manage to load IPC::SysV? 33 34my ($old_env_path, $old_env_dcl_path, $old_env_term); 35BEGIN { 36 $old_env_path = $ENV{'PATH'}; 37 $old_env_dcl_path = $ENV{'DCL$PATH'}; 38 $old_env_term = $ENV{'TERM'}; 39 if ($^O eq 'VMS' && !defined($Config{d_setenv})) { 40 $ENV{PATH} = $ENV{PATH}; 41 $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; 42 } 43 if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ 44 && ($Config{d_shm} || $Config{d_msg})) { 45 eval { require IPC::SysV }; 46 unless ($@) { 47 $ipcsysv++; 48 IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU IPC_NOWAIT)); 49 } 50 } 51} 52 53my $Is_VMS = $^O eq 'VMS'; 54my $Is_MSWin32 = $^O eq 'MSWin32'; 55my $Is_Cygwin = $^O eq 'cygwin'; 56my $Is_OpenBSD = $^O eq 'openbsd'; 57my $Is_MirBSD = $^O eq 'mirbsd'; 58my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.exe' : 59 $Is_MSWin32 ? '.\perl' : 60 './perl' ; 61my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; 62 63if ($Is_VMS) { 64 my (%old, $x); 65 for $x ('DCL$PATH', @MoreEnv) { 66 ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; 67 } 68 # VMS note: PATH and TERM are automatically created by the C 69 # library in VMS on reference to the their keys in %ENV. 70 # There is currently no way to determine if they did not exist 71 # before this test was run. 72 eval <<EndOfCleanup; 73 END { 74 \$ENV{PATH} = \$old_env_path; 75 warn "# Note: logical name 'PATH' may have been created\n"; 76 \$ENV{'TERM'} = \$old_env_term; 77 warn "# Note: logical name 'TERM' may have been created\n"; 78 \@ENV{keys %old} = values %old; 79 if (defined \$old_env_dcl_path) { 80 \$ENV{'DCL\$PATH'} = \$old_env_dcl_path; 81 } else { 82 delete \$ENV{'DCL\$PATH'}; 83 } 84 } 85EndOfCleanup 86} 87 88# Sources of taint: 89# The empty tainted value, for tainting strings 90my $TAINT = substr($^X, 0, 0); 91# A tainted non-empty string 92my $TAINTXYZ = "xyz".$TAINT; 93# A tainted zero, useful for tainting numbers 94my $TAINT0; 95{ 96 no warnings; 97 $TAINT0 = 0 + $TAINT; 98} 99 100# This taints each argument passed. All must be lvalues. 101# Side effect: It also stringifies them. :-( 102sub taint_these :prototype(@) { 103 for (@_) { $_ .= $TAINT } 104} 105 106# How to identify taint when you see it 107sub tainted :prototype($) { 108 local $@; # Don't pollute caller's value. 109 not eval { no warnings; join("", @_), kill 0; 1 }; 110} 111 112sub is_tainted { 113 my $thing = shift; 114 local $::Level = $::Level + 1; 115 ok(tainted($thing), @_); 116} 117 118sub isnt_tainted { 119 my $thing = shift; 120 local $::Level = $::Level + 1; 121 ok(!tainted($thing), @_); 122} 123 124sub violates_taint { 125 my ($code, $what, $desc) = @_; 126 $desc //= $what; 127 local $::Level = $::Level + 1; 128 is(eval { $code->(); }, undef, $desc); 129 like($@, qr/^Insecure dependency in $what while running with -T switch/); 130} 131 132# We need an external program to call. 133my $ECHO = ($Is_MSWin32 ? ".\\tmpecho$$" : "./tmpecho$$"); 134END { unlink $ECHO unless $NoTaintSupport } 135open my $fh, '>', $ECHO or die "Can't create $ECHO: $!"; 136print $fh 'print "@ARGV\n"', "\n"; 137close $fh; 138my $echo = "$Invoke_Perl $ECHO"; 139 140my $TEST = 'TEST'; 141 142# First, let's make sure that Perl is checking the dangerous 143# environment variables. Maybe they aren't set yet, so we'll 144# taint them ourselves. 145{ 146 $ENV{'DCL$PATH'} = '' if $Is_VMS; 147 148 # Empty path is the same as "." on *nix, so we have to set it 149 # to something or we will fail taint tests. perhaps setting it 150 # to "/" would be better. Anything absolute will do. 151 $ENV{PATH} = $Is_VMS ? 'sys$system:' : '/usr/bin'; 152 delete @ENV{@MoreEnv}; 153 $ENV{TERM} = 'dumb'; 154 155 is(eval { `$echo 1` }, "1\n"); 156 157 SKIP: { 158 skip "Environment tainting tests skipped", 11 159 if $Is_MSWin32 || $Is_VMS; 160 161 my @vars = ('PATH', @MoreEnv); 162 while (my $v = $vars[0]) { 163 local $ENV{$v} = $TAINT; 164 last if eval { `$echo 1` }; 165 last unless $@ =~ /^Insecure \$ENV\{$v\}/; 166 shift @vars; 167 } 168 is("@vars", ""); 169 170 # make sure that the empty path or empty path components 171 # trigger an "Insecure directory in $ENV{PATH}" error. 172 for my $path ("", ".", "/:", ":/", "/::/", ".:/", "/:.") { 173 local $ENV{PATH} = $path; 174 eval {`$echo 1`}; 175 ok($@ =~ /Insecure directory in \$ENV\{PATH\}/, 176 "path '$path' is insecure as expected") 177 or diag "$@"; 178 } 179 180 # tainted $TERM is unsafe only if it contains metachars 181 local $ENV{TERM}; 182 $ENV{TERM} = 'e=mc2'; 183 is(eval { `$echo 1` }, "1\n"); 184 $ENV{TERM} = 'e=mc2' . $TAINT; 185 is(eval { `$echo 1` }, undef); 186 like($@, qr/^Insecure \$ENV\{TERM\}/); 187 } 188 189 my $tmp; 190 if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32) { 191 print "# all directories are writeable\n"; 192 } 193 else { 194 $tmp = (grep { defined and -d and (stat _)[2] & 2 } 195 qw(sys$scratch /tmp /var/tmp /usr/tmp), 196 @ENV{qw(TMP TEMP)})[0] 197 or print "# can't find world-writeable directory to test PATH\n"; 198 } 199 200 SKIP: { 201 skip "all directories are writeable", 2 unless $tmp; 202 203 local $ENV{PATH} = $tmp; 204 is(eval { `$echo 1` }, undef); 205 # Message can be different depending on whether echo 206 # is a builtin or not 207 like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/); 208 } 209 210 # Relative paths in $ENV{PATH} are always implicitly tainted. 211 SKIP: { 212 skip "Do these work on VMS?", 4 if $Is_VMS; 213 skip "Not applicable to DOSish systems", 4 if! $tmp; 214 215 local $ENV{PATH} = '.'; 216 is(eval { `$echo 1` }, undef); 217 like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/); 218 219 # Backslash should not fool perl into thinking that this is one 220 # path. 221 local $ENV{PATH} = '/\:.'; 222 is(eval { `$echo 1` }, undef); 223 like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH\}/); 224 } 225 226 SKIP: { 227 skip "This is not VMS", 4 unless $Is_VMS; 228 229 $ENV{'DCL$PATH'} = $TAINT; 230 is(eval { `$echo 1` }, undef); 231 like($@, qr/^Insecure \$ENV\{DCL\$PATH\}/); 232 SKIP: { 233 skip q[can't find world-writeable directory to test DCL$PATH], 2 234 unless $tmp; 235 236 $ENV{'DCL$PATH'} = $tmp; 237 is(eval { `$echo 1` }, undef); 238 like($@, qr/^Insecure directory in \$ENV\{DCL\$PATH\}/); 239 } 240 $ENV{'DCL$PATH'} = ''; 241 } 242} 243 244# Let's see that we can taint and untaint as needed. 245{ 246 my $foo = $TAINT; 247 is_tainted($foo); 248 249 # That was a sanity check. If it failed, stop the insanity! 250 die "Taint checks don't seem to be enabled" unless tainted $foo; 251 252 $foo = "foo"; 253 isnt_tainted($foo); 254 255 taint_these($foo); 256 is_tainted($foo); 257 258 my @list = 1..10; 259 isnt_tainted($_) foreach @list; 260 taint_these @list[1,3,5,7,9]; 261 is_tainted($_) foreach @list[1,3,5,7,9]; 262 isnt_tainted($_) foreach @list[0,2,4,6,8]; 263 264 ($foo) = $foo =~ /(.+)/; 265 isnt_tainted($foo); 266 267 my ($desc, $s, $res, $res2, $one); 268 269 $desc = "match with string tainted"; 270 271 $s = 'abcd' . $TAINT; 272 $res = $s =~ /(.+)/; 273 $one = $1; 274 is_tainted($s, "$desc: s tainted"); 275 isnt_tainted($res, "$desc: res not tainted"); 276 isnt_tainted($one, "$desc: \$1 not tainted"); 277 is($res, 1, "$desc: res value"); 278 is($one, 'abcd', "$desc: \$1 value"); 279 280 $desc = "match /g with string tainted"; 281 282 $s = 'abcd' . $TAINT; 283 $res = $s =~ /(.)/g; 284 $one = $1; 285 is_tainted($s, "$desc: s tainted"); 286 isnt_tainted($res, "$desc: res not tainted"); 287 isnt_tainted($one, "$desc: \$1 not tainted"); 288 is($res, 1, "$desc: res value"); 289 is($one, 'a', "$desc: \$1 value"); 290 291 $desc = "match with string tainted, list cxt"; 292 293 $s = 'abcd' . $TAINT; 294 ($res) = $s =~ /(.+)/; 295 $one = $1; 296 is_tainted($s, "$desc: s tainted"); 297 isnt_tainted($res, "$desc: res not tainted"); 298 isnt_tainted($one, "$desc: \$1 not tainted"); 299 is($res, 'abcd', "$desc: res value"); 300 is($one, 'abcd', "$desc: \$1 value"); 301 302 $desc = "match /g with string tainted, list cxt"; 303 304 $s = 'abcd' . $TAINT; 305 ($res, $res2) = $s =~ /(.)/g; 306 $one = $1; 307 is_tainted($s, "$desc: s tainted"); 308 isnt_tainted($res, "$desc: res not tainted"); 309 isnt_tainted($res2,"$desc: res2 not tainted"); 310 isnt_tainted($one, "$desc: \$1 not tainted"); 311 is($res, 'a', "$desc: res value"); 312 is($res2,'b', "$desc: res2 value"); 313 is($one, 'd', "$desc: \$1 value"); 314 315 $desc = "match with pattern tainted"; 316 317 $s = 'abcd'; 318 $res = $s =~ /$TAINT(.+)/; 319 $one = $1; 320 isnt_tainted($s, "$desc: s not tainted"); 321 isnt_tainted($res, "$desc: res not tainted"); 322 is_tainted($one, "$desc: \$1 tainted"); 323 is($res, 1, "$desc: res value"); 324 is($one, 'abcd', "$desc: \$1 value"); 325 326 $desc = "match /g with pattern tainted"; 327 328 $s = 'abcd'; 329 $res = $s =~ /$TAINT(.)/g; 330 $one = $1; 331 isnt_tainted($s, "$desc: s not tainted"); 332 isnt_tainted($res, "$desc: res not tainted"); 333 is_tainted($one, "$desc: \$1 tainted"); 334 is($res, 1, "$desc: res value"); 335 is($one, 'a', "$desc: \$1 value"); 336 337 SKIP: { 338 skip 'Locales not available', 10 unless locales_enabled('LC_CTYPE'); 339 340 $desc = "match with pattern tainted via locale"; 341 342 $s = 'abcd'; 343 { 344 use locale; 345 $res = $s =~ /(\w+)/; $one = $1; 346 } 347 isnt_tainted($s, "$desc: s not tainted"); 348 isnt_tainted($res, "$desc: res not tainted"); 349 is_tainted($one, "$desc: \$1 tainted"); 350 is($res, 1, "$desc: res value"); 351 is($one, 'abcd', "$desc: \$1 value"); 352 353 $desc = "match /g with pattern tainted via locale"; 354 355 $s = 'abcd'; 356 { 357 use locale; 358 $res = $s =~ /(\w)/g; $one = $1; 359 } 360 isnt_tainted($s, "$desc: s not tainted"); 361 isnt_tainted($res, "$desc: res not tainted"); 362 is_tainted($one, "$desc: \$1 tainted"); 363 is($res, 1, "$desc: res value"); 364 is($one, 'a', "$desc: \$1 value"); 365 } 366 367 $desc = "match with pattern tainted, list cxt"; 368 369 $s = 'abcd'; 370 ($res) = $s =~ /$TAINT(.+)/; 371 $one = $1; 372 isnt_tainted($s, "$desc: s not tainted"); 373 is_tainted($res, "$desc: res tainted"); 374 is_tainted($one, "$desc: \$1 tainted"); 375 is($res, 'abcd', "$desc: res value"); 376 is($one, 'abcd', "$desc: \$1 value"); 377 378 $desc = "match /g with pattern tainted, list cxt"; 379 380 $s = 'abcd'; 381 ($res, $res2) = $s =~ /$TAINT(.)/g; 382 $one = $1; 383 isnt_tainted($s, "$desc: s not tainted"); 384 is_tainted($res, "$desc: res tainted"); 385 is_tainted($one, "$desc: \$1 tainted"); 386 is($res, 'a', "$desc: res value"); 387 is($res2,'b', "$desc: res2 value"); 388 is($one, 'd', "$desc: \$1 value"); 389 390 SKIP: { 391 skip 'Locales not available', 12 unless locales_enabled('LC_CTYPE'); 392 393 $desc = "match with pattern tainted via locale, list cxt"; 394 395 $s = 'abcd'; 396 { 397 use locale; 398 ($res) = $s =~ /(\w+)/; $one = $1; 399 } 400 isnt_tainted($s, "$desc: s not tainted"); 401 is_tainted($res, "$desc: res tainted"); 402 is_tainted($one, "$desc: \$1 tainted"); 403 is($res, 'abcd', "$desc: res value"); 404 is($one, 'abcd', "$desc: \$1 value"); 405 406 $desc = "match /g with pattern tainted via locale, list cxt"; 407 408 $s = 'abcd'; 409 { 410 use locale; 411 ($res, $res2) = $s =~ /(\w)/g; $one = $1; 412 } 413 isnt_tainted($s, "$desc: s not tainted"); 414 is_tainted($res, "$desc: res tainted"); 415 is_tainted($res2, "$desc: res2 tainted"); 416 is_tainted($one, "$desc: \$1 tainted"); 417 is($res, 'a', "$desc: res value"); 418 is($res2,'b', "$desc: res2 value"); 419 is($one, 'd', "$desc: \$1 value"); 420 } 421 422 $desc = "substitution with string tainted"; 423 424 $s = 'abcd' . $TAINT; 425 $res = $s =~ s/(.+)/xyz/; 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 /g with string tainted"; 435 436 $s = 'abcd' . $TAINT; 437 $res = $s =~ s/(.)/x/g; 438 $one = $1; 439 is_tainted($s, "$desc: s tainted"); 440 is_tainted($res, "$desc: res tainted"); 441 isnt_tainted($one, "$desc: \$1 not tainted"); 442 is($s, 'xxxx', "$desc: s value"); 443 is($res, 4, "$desc: res value"); 444 is($one, 'd', "$desc: \$1 value"); 445 446 $desc = "substitution /r with string tainted"; 447 448 $s = 'abcd' . $TAINT; 449 $res = $s =~ s/(.+)/xyz/r; 450 $one = $1; 451 is_tainted($s, "$desc: s tainted"); 452 is_tainted($res, "$desc: res tainted"); 453 isnt_tainted($one, "$desc: \$1 not tainted"); 454 is($s, 'abcd', "$desc: s value"); 455 is($res, 'xyz', "$desc: res value"); 456 is($one, 'abcd', "$desc: \$1 value"); 457 458 $desc = "substitution /e with string tainted"; 459 460 $s = 'abcd' . $TAINT; 461 $one = ''; 462 $res = $s =~ s{(.+)}{ 463 $one = $one . "x"; # make sure code not tainted 464 isnt_tainted($one, "$desc: code not tainted within /e"); 465 $one = $1; 466 isnt_tainted($one, "$desc: \$1 not tainted within /e"); 467 "xyz"; 468 }e; 469 $one = $1; 470 is_tainted($s, "$desc: s tainted"); 471 isnt_tainted($res, "$desc: res not tainted"); 472 isnt_tainted($one, "$desc: \$1 not tainted"); 473 is($s, 'xyz', "$desc: s value"); 474 is($res, 1, "$desc: res value"); 475 is($one, 'abcd', "$desc: \$1 value"); 476 477 $desc = "substitution with pattern tainted"; 478 479 $s = 'abcd'; 480 $res = $s =~ s/$TAINT(.+)/xyz/; 481 $one = $1; 482 is_tainted($s, "$desc: s tainted"); 483 isnt_tainted($res, "$desc: res not tainted"); 484 is_tainted($one, "$desc: \$1 tainted"); 485 is($s, 'xyz', "$desc: s value"); 486 is($res, 1, "$desc: res value"); 487 is($one, 'abcd', "$desc: \$1 value"); 488 489 $desc = "substitution /g with pattern tainted"; 490 491 $s = 'abcd'; 492 $res = $s =~ s/$TAINT(.)/x/g; 493 $one = $1; 494 is_tainted($s, "$desc: s tainted"); 495 is_tainted($res, "$desc: res tainted"); 496 is_tainted($one, "$desc: \$1 tainted"); 497 is($s, 'xxxx', "$desc: s value"); 498 is($res, 4, "$desc: res value"); 499 is($one, 'd', "$desc: \$1 value"); 500 501 $desc = "substitution /ge with pattern tainted"; 502 503 $s = 'abc'; 504 { 505 my $i = 0; 506 my $j; 507 $res = $s =~ s{(.)$TAINT}{ 508 $j = $i; # make sure code not tainted 509 $one = $1; 510 isnt_tainted($j, "$desc: code not tainted within /e"); 511 $i++; 512 if ($i == 1) { 513 isnt_tainted($s, "$desc: s not tainted loop 1"); 514 } 515 else { 516 is_tainted($s, "$desc: s tainted loop $i"); 517 } 518 is_tainted($one, "$desc: \$1 tainted loop $i"); 519 $i.$TAINT; 520 }ge; 521 $one = $1; 522 } 523 is_tainted($s, "$desc: s tainted"); 524 is_tainted($res, "$desc: res tainted"); 525 is_tainted($one, "$desc: \$1 tainted"); 526 is($s, '123', "$desc: s value"); 527 is($res, 3, "$desc: res value"); 528 is($one, 'c', "$desc: \$1 value"); 529 530 $desc = "substitution /r with pattern tainted"; 531 532 $s = 'abcd'; 533 $res = $s =~ s/$TAINT(.+)/xyz/r; 534 $one = $1; 535 isnt_tainted($s, "$desc: s not tainted"); 536 is_tainted($res, "$desc: res tainted"); 537 is_tainted($one, "$desc: \$1 tainted"); 538 is($s, 'abcd', "$desc: s value"); 539 is($res, 'xyz', "$desc: res value"); 540 is($one, 'abcd', "$desc: \$1 value"); 541 542 SKIP: { 543 skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE'); 544 545 $desc = "substitution with pattern tainted via locale"; 546 547 $s = 'abcd'; 548 { 549 use locale; 550 $res = $s =~ s/(\w+)/xyz/; $one = $1; 551 } 552 is_tainted($s, "$desc: s tainted"); 553 isnt_tainted($res, "$desc: res not tainted"); 554 is_tainted($one, "$desc: \$1 tainted"); 555 is($s, 'xyz', "$desc: s value"); 556 is($res, 1, "$desc: res value"); 557 is($one, 'abcd', "$desc: \$1 value"); 558 559 $desc = "substitution /g with pattern tainted via locale"; 560 561 $s = 'abcd'; 562 { 563 use locale; 564 $res = $s =~ s/(\w)/x/g; $one = $1; 565 } 566 is_tainted($s, "$desc: s tainted"); 567 is_tainted($res, "$desc: res tainted"); 568 is_tainted($one, "$desc: \$1 tainted"); 569 is($s, 'xxxx', "$desc: s value"); 570 is($res, 4, "$desc: res value"); 571 is($one, 'd', "$desc: \$1 value"); 572 573 $desc = "substitution /r with pattern tainted via locale"; 574 575 $s = 'abcd'; 576 { 577 use locale; 578 $res = $s =~ s/(\w+)/xyz/r; $one = $1; 579 } 580 isnt_tainted($s, "$desc: s not tainted"); 581 is_tainted($res, "$desc: res tainted"); 582 is_tainted($one, "$desc: \$1 tainted"); 583 is($s, 'abcd', "$desc: s value"); 584 is($res, 'xyz', "$desc: res value"); 585 is($one, 'abcd', "$desc: \$1 value"); 586 } 587 588 $desc = "substitution with partial replacement tainted"; 589 590 $s = 'abcd'; 591 $res = $s =~ s/(.+)/xyz$TAINT/; 592 $one = $1; 593 is_tainted($s, "$desc: s tainted"); 594 isnt_tainted($res, "$desc: res not tainted"); 595 isnt_tainted($one, "$desc: \$1 not tainted"); 596 is($s, 'xyz', "$desc: s value"); 597 is($res, 1, "$desc: res value"); 598 is($one, 'abcd', "$desc: \$1 value"); 599 600 $desc = "substitution /g with partial replacement tainted"; 601 602 $s = 'abcd'; 603 $res = $s =~ s/(.)/x$TAINT/g; 604 $one = $1; 605 is_tainted($s, "$desc: s tainted"); 606 isnt_tainted($res, "$desc: res not tainted"); 607 isnt_tainted($one, "$desc: \$1 not tainted"); 608 is($s, 'xxxx', "$desc: s value"); 609 is($res, 4, "$desc: res value"); 610 is($one, 'd', "$desc: \$1 value"); 611 612 $desc = "substitution /ge with partial replacement tainted"; 613 614 $s = 'abc'; 615 { 616 my $i = 0; 617 my $j; 618 $res = $s =~ s{(.)}{ 619 $j = $i; # make sure code not tainted 620 $one = $1; 621 isnt_tainted($j, "$desc: code not tainted within /e"); 622 $i++; 623 if ($i == 1) { 624 isnt_tainted($s, "$desc: s not tainted loop 1"); 625 } 626 else { 627 is_tainted($s, "$desc: s tainted loop $i"); 628 } 629 isnt_tainted($one, "$desc: \$1 not tainted within /e"); 630 $i.$TAINT; 631 }ge; 632 $one = $1; 633 } 634 is_tainted($s, "$desc: s tainted"); 635 isnt_tainted($res, "$desc: res tainted"); 636 isnt_tainted($one, "$desc: \$1 not tainted"); 637 is($s, '123', "$desc: s value"); 638 is($res, 3, "$desc: res value"); 639 is($one, 'c', "$desc: \$1 value"); 640 641 $desc = "substitution /r with partial replacement tainted"; 642 643 $s = 'abcd'; 644 $res = $s =~ s/(.+)/xyz$TAINT/r; 645 $one = $1; 646 isnt_tainted($s, "$desc: s not tainted"); 647 is_tainted($res, "$desc: res tainted"); 648 isnt_tainted($one, "$desc: \$1 not tainted"); 649 is($s, 'abcd', "$desc: s value"); 650 is($res, 'xyz', "$desc: res value"); 651 is($one, 'abcd', "$desc: \$1 value"); 652 653 $desc = "substitution with whole replacement tainted"; 654 655 $s = 'abcd'; 656 $res = $s =~ s/(.+)/$TAINTXYZ/; 657 $one = $1; 658 is_tainted($s, "$desc: s tainted"); 659 isnt_tainted($res, "$desc: res not tainted"); 660 isnt_tainted($one, "$desc: \$1 not tainted"); 661 is($s, 'xyz', "$desc: s value"); 662 is($res, 1, "$desc: res value"); 663 is($one, 'abcd', "$desc: \$1 value"); 664 665 $desc = "substitution /g with whole replacement tainted"; 666 667 $s = 'abcd'; 668 $res = $s =~ s/(.)/$TAINTXYZ/g; 669 $one = $1; 670 is_tainted($s, "$desc: s tainted"); 671 isnt_tainted($res, "$desc: res not tainted"); 672 isnt_tainted($one, "$desc: \$1 not tainted"); 673 is($s, 'xyz' x 4, "$desc: s value"); 674 is($res, 4, "$desc: res value"); 675 is($one, 'd', "$desc: \$1 value"); 676 677 $desc = "substitution /ge with whole replacement tainted"; 678 679 $s = 'abc'; 680 { 681 my $i = 0; 682 my $j; 683 $res = $s =~ s{(.)}{ 684 $j = $i; # make sure code not tainted 685 $one = $1; 686 isnt_tainted($j, "$desc: code not tainted within /e"); 687 $i++; 688 if ($i == 1) { 689 isnt_tainted($s, "$desc: s not tainted loop 1"); 690 } 691 else { 692 is_tainted($s, "$desc: s tainted loop $i"); 693 } 694 isnt_tainted($one, "$desc: \$1 not tainted within /e"); 695 $TAINTXYZ; 696 }ge; 697 $one = $1; 698 } 699 is_tainted($s, "$desc: s tainted"); 700 isnt_tainted($res, "$desc: res tainted"); 701 isnt_tainted($one, "$desc: \$1 not tainted"); 702 is($s, 'xyz' x 3, "$desc: s value"); 703 is($res, 3, "$desc: res value"); 704 is($one, 'c', "$desc: \$1 value"); 705 706 $desc = "substitution /r with whole replacement tainted"; 707 708 $s = 'abcd'; 709 $res = $s =~ s/(.+)/$TAINTXYZ/r; 710 $one = $1; 711 isnt_tainted($s, "$desc: s not tainted"); 712 is_tainted($res, "$desc: res tainted"); 713 isnt_tainted($one, "$desc: \$1 not tainted"); 714 is($s, 'abcd', "$desc: s value"); 715 is($res, 'xyz', "$desc: res value"); 716 is($one, 'abcd', "$desc: \$1 value"); 717 718 { 719 # now do them all again with "use re 'taint" 720 721 use re 'taint'; 722 723 $desc = "use re 'taint': match with string tainted"; 724 725 $s = 'abcd' . $TAINT; 726 $res = $s =~ /(.+)/; 727 $one = $1; 728 is_tainted($s, "$desc: s tainted"); 729 isnt_tainted($res, "$desc: res not tainted"); 730 is_tainted($one, "$desc: \$1 tainted"); 731 is($res, 1, "$desc: res value"); 732 is($one, 'abcd', "$desc: \$1 value"); 733 734 $desc = "use re 'taint': match /g with string tainted"; 735 736 $s = 'abcd' . $TAINT; 737 $res = $s =~ /(.)/g; 738 $one = $1; 739 is_tainted($s, "$desc: s tainted"); 740 isnt_tainted($res, "$desc: res not tainted"); 741 is_tainted($one, "$desc: \$1 tainted"); 742 is($res, 1, "$desc: res value"); 743 is($one, 'a', "$desc: \$1 value"); 744 745 $desc = "use re 'taint': match with string tainted, list cxt"; 746 747 $s = 'abcd' . $TAINT; 748 ($res) = $s =~ /(.+)/; 749 $one = $1; 750 is_tainted($s, "$desc: s tainted"); 751 is_tainted($res, "$desc: res tainted"); 752 is_tainted($one, "$desc: \$1 tainted"); 753 is($res, 'abcd', "$desc: res value"); 754 is($one, 'abcd', "$desc: \$1 value"); 755 756 $desc = "use re 'taint': match /g with string tainted, list cxt"; 757 758 $s = 'abcd' . $TAINT; 759 ($res, $res2) = $s =~ /(.)/g; 760 $one = $1; 761 is_tainted($s, "$desc: s tainted"); 762 is_tainted($res, "$desc: res tainted"); 763 is_tainted($res2, "$desc: res2 tainted"); 764 is_tainted($one, "$desc: \$1 not tainted"); 765 is($res, 'a', "$desc: res value"); 766 is($res2,'b', "$desc: res2 value"); 767 is($one, 'd', "$desc: \$1 value"); 768 769 $desc = "use re 'taint': match with pattern tainted"; 770 771 $s = 'abcd'; 772 $res = $s =~ /$TAINT(.+)/; 773 $one = $1; 774 isnt_tainted($s, "$desc: s not tainted"); 775 isnt_tainted($res, "$desc: res not tainted"); 776 is_tainted($one, "$desc: \$1 tainted"); 777 is($res, 1, "$desc: res value"); 778 is($one, 'abcd', "$desc: \$1 value"); 779 780 $desc = "use re 'taint': match /g with pattern tainted"; 781 782 $s = 'abcd'; 783 $res = $s =~ /$TAINT(.)/g; 784 $one = $1; 785 isnt_tainted($s, "$desc: s not tainted"); 786 isnt_tainted($res, "$desc: res not tainted"); 787 is_tainted($one, "$desc: \$1 tainted"); 788 is($res, 1, "$desc: res value"); 789 is($one, 'a', "$desc: \$1 value"); 790 791 SKIP: { 792 skip 'Locales not available', 10 unless locales_enabled('LC_CTYPE'); 793 794 $desc = "use re 'taint': match with pattern tainted via locale"; 795 796 $s = 'abcd'; 797 { 798 use locale; 799 $res = $s =~ /(\w+)/; $one = $1; 800 } 801 isnt_tainted($s, "$desc: s not tainted"); 802 isnt_tainted($res, "$desc: res not tainted"); 803 is_tainted($one, "$desc: \$1 tainted"); 804 is($res, 1, "$desc: res value"); 805 is($one, 'abcd', "$desc: \$1 value"); 806 807 $desc = "use re 'taint': match /g with pattern tainted via locale"; 808 809 $s = 'abcd'; 810 { 811 use locale; 812 $res = $s =~ /(\w)/g; $one = $1; 813 } 814 isnt_tainted($s, "$desc: s not tainted"); 815 isnt_tainted($res, "$desc: res not tainted"); 816 is_tainted($one, "$desc: \$1 tainted"); 817 is($res, 1, "$desc: res value"); 818 is($one, 'a', "$desc: \$1 value"); 819 } 820 821 $desc = "use re 'taint': match with pattern tainted, list cxt"; 822 823 $s = 'abcd'; 824 ($res) = $s =~ /$TAINT(.+)/; 825 $one = $1; 826 isnt_tainted($s, "$desc: s not tainted"); 827 is_tainted($res, "$desc: res tainted"); 828 is_tainted($one, "$desc: \$1 tainted"); 829 is($res, 'abcd', "$desc: res value"); 830 is($one, 'abcd', "$desc: \$1 value"); 831 832 $desc = "use re 'taint': match /g with pattern tainted, list cxt"; 833 834 $s = 'abcd'; 835 ($res, $res2) = $s =~ /$TAINT(.)/g; 836 $one = $1; 837 isnt_tainted($s, "$desc: s not tainted"); 838 is_tainted($res, "$desc: res tainted"); 839 is_tainted($one, "$desc: \$1 tainted"); 840 is($res, 'a', "$desc: res value"); 841 is($res2,'b', "$desc: res2 value"); 842 is($one, 'd', "$desc: \$1 value"); 843 844 SKIP: { 845 skip 'Locales not available', 12 unless locales_enabled('LC_CTYPE'); 846 847 $desc = "use re 'taint': match with pattern tainted via locale, list cxt"; 848 849 $s = 'abcd'; 850 { 851 use locale; 852 ($res) = $s =~ /(\w+)/; $one = $1; 853 } 854 isnt_tainted($s, "$desc: s not tainted"); 855 is_tainted($res, "$desc: res tainted"); 856 is_tainted($one, "$desc: \$1 tainted"); 857 is($res, 'abcd', "$desc: res value"); 858 is($one, 'abcd', "$desc: \$1 value"); 859 860 $desc = "use re 'taint': match /g with pattern tainted via locale, list cxt"; 861 862 $s = 'abcd'; 863 { 864 use locale; 865 ($res, $res2) = $s =~ /(\w)/g; $one = $1; 866 } 867 isnt_tainted($s, "$desc: s not tainted"); 868 is_tainted($res, "$desc: res tainted"); 869 is_tainted($res2, "$desc: res2 tainted"); 870 is_tainted($one, "$desc: \$1 tainted"); 871 is($res, 'a', "$desc: res value"); 872 is($res2,'b', "$desc: res2 value"); 873 is($one, 'd', "$desc: \$1 value"); 874 } 875 876 $desc = "use re 'taint': substitution with string tainted"; 877 878 $s = 'abcd' . $TAINT; 879 $res = $s =~ s/(.+)/xyz/; 880 $one = $1; 881 is_tainted($s, "$desc: s tainted"); 882 isnt_tainted($res, "$desc: res not tainted"); 883 is_tainted($one, "$desc: \$1 tainted"); 884 is($s, 'xyz', "$desc: s value"); 885 is($res, 1, "$desc: res value"); 886 is($one, 'abcd', "$desc: \$1 value"); 887 888 $desc = "use re 'taint': substitution /g with string tainted"; 889 890 $s = 'abcd' . $TAINT; 891 $res = $s =~ s/(.)/x/g; 892 $one = $1; 893 is_tainted($s, "$desc: s tainted"); 894 is_tainted($res, "$desc: res tainted"); 895 is_tainted($one, "$desc: \$1 tainted"); 896 is($s, 'xxxx', "$desc: s value"); 897 is($res, 4, "$desc: res value"); 898 is($one, 'd', "$desc: \$1 value"); 899 900 $desc = "use re 'taint': substitution /r with string tainted"; 901 902 $s = 'abcd' . $TAINT; 903 $res = $s =~ s/(.+)/xyz/r; 904 $one = $1; 905 is_tainted($s, "$desc: s tainted"); 906 is_tainted($res, "$desc: res tainted"); 907 is_tainted($one, "$desc: \$1 tainted"); 908 is($s, 'abcd', "$desc: s value"); 909 is($res, 'xyz', "$desc: res value"); 910 is($one, 'abcd', "$desc: \$1 value"); 911 912 $desc = "use re 'taint': substitution /e with string tainted"; 913 914 $s = 'abcd' . $TAINT; 915 $one = ''; 916 $res = $s =~ s{(.+)}{ 917 $one = $one . "x"; # make sure code not tainted 918 isnt_tainted($one, "$desc: code not tainted within /e"); 919 $one = $1; 920 is_tainted($one, "$desc: $1 tainted within /e"); 921 "xyz"; 922 }e; 923 $one = $1; 924 is_tainted($s, "$desc: s tainted"); 925 isnt_tainted($res, "$desc: res not tainted"); 926 is_tainted($one, "$desc: \$1 tainted"); 927 is($s, 'xyz', "$desc: s value"); 928 is($res, 1, "$desc: res value"); 929 is($one, 'abcd', "$desc: \$1 value"); 930 931 $desc = "use re 'taint': substitution with pattern tainted"; 932 933 $s = 'abcd'; 934 $res = $s =~ s/$TAINT(.+)/xyz/; 935 $one = $1; 936 is_tainted($s, "$desc: s tainted"); 937 isnt_tainted($res, "$desc: res not tainted"); 938 is_tainted($one, "$desc: \$1 tainted"); 939 is($s, 'xyz', "$desc: s value"); 940 is($res, 1, "$desc: res value"); 941 is($one, 'abcd', "$desc: \$1 value"); 942 943 $desc = "use re 'taint': substitution /g with pattern tainted"; 944 945 $s = 'abcd'; 946 $res = $s =~ s/$TAINT(.)/x/g; 947 $one = $1; 948 is_tainted($s, "$desc: s tainted"); 949 is_tainted($res, "$desc: res tainted"); 950 is_tainted($one, "$desc: \$1 tainted"); 951 is($s, 'xxxx', "$desc: s value"); 952 is($res, 4, "$desc: res value"); 953 is($one, 'd', "$desc: \$1 value"); 954 955 $desc = "use re 'taint': substitution /ge with pattern tainted"; 956 957 $s = 'abc'; 958 { 959 my $i = 0; 960 my $j; 961 $res = $s =~ s{(.)$TAINT}{ 962 $j = $i; # make sure code not tainted 963 $one = $1; 964 isnt_tainted($j, "$desc: code not tainted within /e"); 965 $i++; 966 if ($i == 1) { 967 isnt_tainted($s, "$desc: s not tainted loop 1"); 968 } 969 else { 970 is_tainted($s, "$desc: s tainted loop $i"); 971 } 972 is_tainted($one, "$desc: \$1 tainted loop $i"); 973 $i.$TAINT; 974 }ge; 975 $one = $1; 976 } 977 is_tainted($s, "$desc: s tainted"); 978 is_tainted($res, "$desc: res tainted"); 979 is_tainted($one, "$desc: \$1 tainted"); 980 is($s, '123', "$desc: s value"); 981 is($res, 3, "$desc: res value"); 982 is($one, 'c', "$desc: \$1 value"); 983 984 985 $desc = "use re 'taint': substitution /r with pattern tainted"; 986 987 $s = 'abcd'; 988 $res = $s =~ s/$TAINT(.+)/xyz/r; 989 $one = $1; 990 isnt_tainted($s, "$desc: s not tainted"); 991 is_tainted($res, "$desc: res tainted"); 992 is_tainted($one, "$desc: \$1 tainted"); 993 is($s, 'abcd', "$desc: s value"); 994 is($res, 'xyz', "$desc: res value"); 995 is($one, 'abcd', "$desc: \$1 value"); 996 997 SKIP: { 998 skip 'Locales not available', 18 unless locales_enabled('LC_CTYPE'); 999 1000 $desc = "use re 'taint': substitution with pattern tainted via locale"; 1001 1002 $s = 'abcd'; 1003 { 1004 use locale; 1005 $res = $s =~ s/(\w+)/xyz/; $one = $1; 1006 } 1007 is_tainted($s, "$desc: s tainted"); 1008 isnt_tainted($res, "$desc: res not tainted"); 1009 is_tainted($one, "$desc: \$1 tainted"); 1010 is($s, 'xyz', "$desc: s value"); 1011 is($res, 1, "$desc: res value"); 1012 is($one, 'abcd', "$desc: \$1 value"); 1013 1014 $desc = "use re 'taint': substitution /g with pattern tainted via locale"; 1015 1016 $s = 'abcd'; 1017 { 1018 use locale; 1019 $res = $s =~ s/(\w)/x/g; $one = $1; 1020 } 1021 is_tainted($s, "$desc: s tainted"); 1022 is_tainted($res, "$desc: res tainted"); 1023 is_tainted($one, "$desc: \$1 tainted"); 1024 is($s, 'xxxx', "$desc: s value"); 1025 is($res, 4, "$desc: res value"); 1026 is($one, 'd', "$desc: \$1 value"); 1027 1028 $desc = "use re 'taint': substitution /r with pattern tainted via locale"; 1029 1030 $s = 'abcd'; 1031 { 1032 use locale; 1033 $res = $s =~ s/(\w+)/xyz/r; $one = $1; 1034 } 1035 isnt_tainted($s, "$desc: s not tainted"); 1036 is_tainted($res, "$desc: res tainted"); 1037 is_tainted($one, "$desc: \$1 tainted"); 1038 is($s, 'abcd', "$desc: s value"); 1039 is($res, 'xyz', "$desc: res value"); 1040 is($one, 'abcd', "$desc: \$1 value"); 1041 } 1042 1043 $desc = "use re 'taint': substitution with partial replacement tainted"; 1044 1045 $s = 'abcd'; 1046 $res = $s =~ s/(.+)/xyz$TAINT/; 1047 $one = $1; 1048 is_tainted($s, "$desc: s tainted"); 1049 isnt_tainted($res, "$desc: res not tainted"); 1050 isnt_tainted($one, "$desc: \$1 not tainted"); 1051 is($s, 'xyz', "$desc: s value"); 1052 is($res, 1, "$desc: res value"); 1053 is($one, 'abcd', "$desc: \$1 value"); 1054 1055 $desc = "use re 'taint': substitution /g with partial replacement tainted"; 1056 1057 $s = 'abcd'; 1058 $res = $s =~ s/(.)/x$TAINT/g; 1059 $one = $1; 1060 is_tainted($s, "$desc: s tainted"); 1061 isnt_tainted($res, "$desc: res not tainted"); 1062 isnt_tainted($one, "$desc: \$1 not tainted"); 1063 is($s, 'xxxx', "$desc: s value"); 1064 is($res, 4, "$desc: res value"); 1065 is($one, 'd', "$desc: \$1 value"); 1066 1067 $desc = "use re 'taint': substitution /ge with partial replacement tainted"; 1068 1069 $s = 'abc'; 1070 { 1071 my $i = 0; 1072 my $j; 1073 $res = $s =~ s{(.)}{ 1074 $j = $i; # make sure code not tainted 1075 $one = $1; 1076 isnt_tainted($j, "$desc: code not tainted within /e"); 1077 $i++; 1078 if ($i == 1) { 1079 isnt_tainted($s, "$desc: s not tainted loop 1"); 1080 } 1081 else { 1082 is_tainted($s, "$desc: s tainted loop $i"); 1083 } 1084 isnt_tainted($one, "$desc: \$1 not tainted"); 1085 $i.$TAINT; 1086 }ge; 1087 $one = $1; 1088 } 1089 is_tainted($s, "$desc: s tainted"); 1090 isnt_tainted($res, "$desc: res tainted"); 1091 isnt_tainted($one, "$desc: \$1 not tainted"); 1092 is($s, '123', "$desc: s value"); 1093 is($res, 3, "$desc: res value"); 1094 is($one, 'c', "$desc: \$1 value"); 1095 1096 $desc = "use re 'taint': substitution /r with partial replacement tainted"; 1097 1098 $s = 'abcd'; 1099 $res = $s =~ s/(.+)/xyz$TAINT/r; 1100 $one = $1; 1101 isnt_tainted($s, "$desc: s not tainted"); 1102 is_tainted($res, "$desc: res tainted"); 1103 isnt_tainted($one, "$desc: \$1 not tainted"); 1104 is($s, 'abcd', "$desc: s value"); 1105 is($res, 'xyz', "$desc: res value"); 1106 is($one, 'abcd', "$desc: \$1 value"); 1107 1108 $desc = "use re 'taint': substitution with whole replacement tainted"; 1109 1110 $s = 'abcd'; 1111 $res = $s =~ s/(.+)/$TAINTXYZ/; 1112 $one = $1; 1113 is_tainted($s, "$desc: s tainted"); 1114 isnt_tainted($res, "$desc: res not tainted"); 1115 isnt_tainted($one, "$desc: \$1 not tainted"); 1116 is($s, 'xyz', "$desc: s value"); 1117 is($res, 1, "$desc: res value"); 1118 is($one, 'abcd', "$desc: \$1 value"); 1119 1120 $desc = "use re 'taint': substitution /g with whole replacement tainted"; 1121 1122 $s = 'abcd'; 1123 $res = $s =~ s/(.)/$TAINTXYZ/g; 1124 $one = $1; 1125 is_tainted($s, "$desc: s tainted"); 1126 isnt_tainted($res, "$desc: res not tainted"); 1127 isnt_tainted($one, "$desc: \$1 not tainted"); 1128 is($s, 'xyz' x 4, "$desc: s value"); 1129 is($res, 4, "$desc: res value"); 1130 is($one, 'd', "$desc: \$1 value"); 1131 1132 $desc = "use re 'taint': substitution /ge with whole replacement tainted"; 1133 1134 $s = 'abc'; 1135 { 1136 my $i = 0; 1137 my $j; 1138 $res = $s =~ s{(.)}{ 1139 $j = $i; # make sure code not tainted 1140 $one = $1; 1141 isnt_tainted($j, "$desc: code not tainted within /e"); 1142 $i++; 1143 if ($i == 1) { 1144 isnt_tainted($s, "$desc: s not tainted loop 1"); 1145 } 1146 else { 1147 is_tainted($s, "$desc: s tainted loop $i"); 1148 } 1149 isnt_tainted($one, "$desc: \$1 not tainted"); 1150 $TAINTXYZ; 1151 }ge; 1152 $one = $1; 1153 } 1154 is_tainted($s, "$desc: s tainted"); 1155 isnt_tainted($res, "$desc: res tainted"); 1156 isnt_tainted($one, "$desc: \$1 not tainted"); 1157 is($s, 'xyz' x 3, "$desc: s value"); 1158 is($res, 3, "$desc: res value"); 1159 is($one, 'c', "$desc: \$1 value"); 1160 1161 $desc = "use re 'taint': substitution /r with whole replacement tainted"; 1162 1163 $s = 'abcd'; 1164 $res = $s =~ s/(.+)/$TAINTXYZ/r; 1165 $one = $1; 1166 isnt_tainted($s, "$desc: s not tainted"); 1167 is_tainted($res, "$desc: res tainted"); 1168 isnt_tainted($one, "$desc: \$1 not tainted"); 1169 is($s, 'abcd', "$desc: s value"); 1170 is($res, 'xyz', "$desc: res value"); 1171 is($one, 'abcd', "$desc: \$1 value"); 1172 1173 # [perl #121854] match taintedness became sticky 1174 # when one match has a taintess result, subseqent matches 1175 # using the same pattern shouldn't necessarily be tainted 1176 1177 { 1178 my $f = sub { $_[0] =~ /(.*)/ or die; $1 }; 1179 $res = $f->($TAINT); 1180 is_tainted($res, "121854: res tainted"); 1181 $res = $f->("abc"); 1182 isnt_tainted($res, "121854: res not tainted"); 1183 } 1184 } 1185 1186 $foo = $1 if 'bar' =~ /(.+)$TAINT/; 1187 is_tainted($foo); 1188 is($foo, 'bar'); 1189 1190 my $pi = 4 * atan2(1,1) + $TAINT0; 1191 is_tainted($pi); 1192 1193 ($pi) = $pi =~ /(\d+\.\d+)/; 1194 isnt_tainted($pi); 1195 is(sprintf("%.5f", $pi), '3.14159'); 1196} 1197 1198# How about command-line arguments? The problem is that we don't 1199# always get some, so we'll run another process with some. 1200SKIP: { 1201 my $arg = tempfile(); 1202 open $fh, '>', $arg or die "Can't create $arg: $!"; 1203 print $fh q{ 1204 eval { my $x = join('', @ARGV), kill 0 }; 1205 exit 0 if $@ =~ /^Insecure dependency/; 1206 print "# Oops: \$@ was [$@]\n"; 1207 exit 1; 1208 }; 1209 close $fh or die "Can't close $arg: $!"; 1210 print `$Invoke_Perl "-T" $arg and some suspect arguments`; 1211 is($?, 0, "Exited with status $?"); 1212 unlink $arg; 1213} 1214 1215# Reading from a file should be tainted 1216{ 1217 ok(open my $fh, '<', $TEST) or diag("Couldn't open '$TEST': $!"); 1218 binmode $fh; 1219 my $block; 1220 sysread($fh, $block, 100); 1221 my $line = <$fh>; 1222 close $fh; 1223 is_tainted($block); 1224 is_tainted($line); 1225} 1226 1227# Output of commands should be tainted 1228{ 1229 my $foo = `$echo abc`; 1230 is_tainted($foo); 1231} 1232 1233# Certain system variables should be tainted 1234{ 1235 is_tainted($^X); 1236 is_tainted($0); 1237} 1238 1239# Results of matching should all be untainted 1240{ 1241 my $foo = "abcdefghi" . $TAINT; 1242 is_tainted($foo); 1243 1244 $foo =~ /def/; 1245 isnt_tainted($`); 1246 isnt_tainted($&); 1247 isnt_tainted($'); 1248 1249 $foo =~ /(...)(...)(...)/; 1250 isnt_tainted($1); 1251 isnt_tainted($2); 1252 isnt_tainted($3); 1253 isnt_tainted($+); 1254 1255 my @bar = $foo =~ /(...)(...)(...)/; 1256 isnt_tainted($_) foreach @bar; 1257 1258 is_tainted($foo); # $foo should still be tainted! 1259 is($foo, "abcdefghi"); 1260} 1261 1262# Operations which affect files can't use tainted data. 1263{ 1264 violates_taint(sub { chmod 0, $TAINT }, 'chmod'); 1265 1266 SKIP: { 1267 skip "truncate() is not available", 2 unless $Config{d_truncate}; 1268 1269 violates_taint(sub { truncate 'NoSuChFiLe', $TAINT0 }, 'truncate'); 1270 } 1271 1272 violates_taint(sub { rename '', $TAINT }, 'rename'); 1273 violates_taint(sub { unlink $TAINT }, 'unlink'); 1274 violates_taint(sub { utime $TAINT }, 'utime'); 1275 1276 SKIP: { 1277 skip "chown() is not available", 2 unless $Config{d_chown}; 1278 1279 violates_taint(sub { chown -1, -1, $TAINT }, 'chown'); 1280 } 1281 1282 SKIP: { 1283 skip "link() is not available", 2 unless $Config{d_link}; 1284 1285violates_taint(sub { link $TAINT, '' }, 'link'); 1286 } 1287 1288 SKIP: { 1289 skip "symlink() is not available", 2 unless $Config{d_symlink}; 1290 1291 violates_taint(sub { symlink $TAINT, '' }, 'symlink'); 1292 } 1293} 1294 1295# Operations which affect directories can't use tainted data. 1296{ 1297 violates_taint(sub { mkdir "foo".$TAINT, 0755 . $TAINT0 }, 'mkdir'); 1298 violates_taint(sub { rmdir $TAINT }, 'rmdir'); 1299 violates_taint(sub { chdir "foo".$TAINT }, 'chdir'); 1300 1301 SKIP: { 1302 skip "chroot() is not available", 2 unless $Config{d_chroot}; 1303 1304 violates_taint(sub { chroot $TAINT }, 'chroot'); 1305 } 1306} 1307 1308# Some operations using files can't use tainted data. 1309{ 1310 my $foo = "imaginary library" . $TAINT; 1311 violates_taint(sub { require $foo }, 'require'); 1312 violates_taint(sub { do $foo }, 'do'); 1313 1314 my $filename = tempfile(); # NB: $filename isn't tainted! 1315 $foo = $filename . $TAINT; 1316 unlink $filename; # in any case 1317 1318 is(eval { open FOO, $foo }, undef, 'open for read'); 1319 is($@, ''); # NB: This should be allowed 1320 is(eval { open my $fh, , '<', $foo }, undef, 'open for read'); 1321 is($@, ''); # NB: This should be allowed 1322 1323 # Try first new style but allow also old style. 1324 # We do not want the whole taint.t to fail 1325 # just because Errno possibly failing. 1326 ok(eval('$!{ENOENT}') || 1327 $! == 2); # File not found 1328 1329 violates_taint(sub { open FOO, "> $foo" }, 'open', 'open for write'); 1330 violates_taint(sub { open my $fh, '>', $foo }, 'open', 'open for write'); 1331} 1332 1333# Commands to the system can't use tainted data 1334{ 1335 my $foo = $TAINT; 1336 1337 SKIP: { 1338 skip "open('|') is not available", 8 if $^O eq 'amigaos'; 1339 1340 violates_taint(sub { open FOO, "| x$foo" }, 'piped open', 'popen to'); 1341 violates_taint(sub { open FOO, "x$foo |" }, 'piped open', 'popen from'); 1342 violates_taint(sub { open my $fh, '|-', "x$foo" }, 'piped open', 'popen to'); 1343 violates_taint(sub { open my $fh, '-|', "x$foo" }, 'piped open', 'popen from'); 1344 } 1345 1346 violates_taint(sub { exec $TAINT }, 'exec'); 1347 violates_taint(sub { system $TAINT }, 'system'); 1348 1349 $foo = "*"; 1350 taint_these $foo; 1351 1352 violates_taint(sub { `$echo 1$foo` }, '``', 'backticks'); 1353 1354 SKIP: { 1355 # wildcard expansion doesn't invoke shell on VMS, so is safe 1356 skip "This is not VMS", 2 unless $Is_VMS; 1357 1358 isnt(join('', eval { glob $foo } ), '', 'globbing'); 1359 is($@, ''); 1360 } 1361} 1362 1363# Operations which affect processes can't use tainted data. 1364{ 1365 violates_taint(sub { kill 0, $TAINT }, 'kill'); 1366 1367 SKIP: { 1368 skip "setpgrp() is not available", 2 unless $Config{d_setpgrp}; 1369 1370 violates_taint(sub { setpgrp 0, $TAINT0 }, 'setpgrp'); 1371 } 1372 1373 SKIP: { 1374 skip "setpriority() is not available", 2 unless $Config{d_setprior}; 1375 1376 violates_taint(sub { setpriority 0, $TAINT0, $TAINT0 }, 'setpriority'); 1377 } 1378} 1379 1380# Some miscellaneous operations can't use tainted data. 1381{ 1382 SKIP: { 1383 skip "syscall() is not available", 2 unless $Config{d_syscall}; 1384 1385 violates_taint(sub { syscall $TAINT }, 'syscall'); 1386 } 1387 1388 { 1389 my $foo = "x" x 979; 1390 taint_these $foo; 1391 local *FOO; 1392 my $temp = tempfile(); 1393 ok(open FOO, "> $temp") or diag("Couldn't open $temp for write: $!"); 1394 violates_taint(sub { ioctl FOO, $TAINT0, $foo }, 'ioctl'); 1395 1396 my $temp2 = tempfile(); 1397 ok(open my $fh, '>', $temp2) or diag("Couldn't open $temp2 for write: $!"); 1398 violates_taint(sub { ioctl $fh, $TAINT0, $foo }, 'ioctl'); 1399 1400 SKIP: { 1401 skip "fcntl() is not available", 4 unless $Config{d_fcntl}; 1402 1403 violates_taint(sub { fcntl FOO, $TAINT0, $foo }, 'fcntl'); 1404 violates_taint(sub { fcntl $fh, $TAINT0, $foo }, 'fcntl'); 1405 } 1406 1407 close FOO; 1408 } 1409} 1410 1411# Some tests involving references 1412{ 1413 my $foo = 'abc' . $TAINT; 1414 my $fooref = \$foo; 1415 isnt_tainted($fooref); 1416 is_tainted($$fooref); 1417 is_tainted($foo); 1418} 1419 1420# Some tests involving assignment 1421{ 1422 my $foo = $TAINT0; 1423 my $bar = $foo; 1424 is_tainted($foo); 1425 is_tainted($bar); 1426 is_tainted($foo = $bar); 1427 is_tainted($bar = $bar); 1428 is_tainted($bar += $bar); 1429 is_tainted($bar -= $bar); 1430 is_tainted($bar *= $bar); 1431 is_tainted($bar++); 1432 is_tainted($bar /= $bar); 1433 is_tainted($bar += 0); 1434 is_tainted($bar -= 2); 1435 is_tainted($bar *= -1); 1436 is_tainted($bar /= 1); 1437 is_tainted($bar--); 1438 is($bar, 0); 1439} 1440 1441# Test assignment and return of lists 1442{ 1443 my @foo = ("A", "tainted" . $TAINT, "B"); 1444 isnt_tainted($foo[0]); 1445 is_tainted( $foo[1]); 1446 isnt_tainted($foo[2]); 1447 my @bar = @foo; 1448 isnt_tainted($bar[0]); 1449 is_tainted( $bar[1]); 1450 isnt_tainted($bar[2]); 1451 my @baz = eval { "A", "tainted" . $TAINT, "B" }; 1452 isnt_tainted($baz[0]); 1453 is_tainted( $baz[1]); 1454 isnt_tainted($baz[2]); 1455 my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; 1456 isnt_tainted($plugh[0]); 1457 is_tainted( $plugh[1]); 1458 isnt_tainted($plugh[2]); 1459 my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; 1460 isnt_tainted(((&$nautilus)[0])); 1461 is_tainted( ((&$nautilus)[1])); 1462 isnt_tainted(((&$nautilus)[2])); 1463 my @xyzzy = &$nautilus; 1464 isnt_tainted($xyzzy[0]); 1465 is_tainted( $xyzzy[1]); 1466 isnt_tainted($xyzzy[2]); 1467 my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; 1468 isnt_tainted(((&$red_october)[0])); 1469 is_tainted( ((&$red_october)[1])); 1470 isnt_tainted(((&$red_october)[2])); 1471 my @corge = &$red_october; 1472 isnt_tainted($corge[0]); 1473 is_tainted( $corge[1]); 1474 isnt_tainted($corge[2]); 1475} 1476 1477# Test for system/library calls returning string data of dubious origin. 1478{ 1479 # No reliable %Config check for getpw* 1480 SKIP: { 1481 skip "getpwent() is not available", 9 unless 1482 eval { setpwent(); getpwent() }; 1483 1484 setpwent(); 1485 my @getpwent = getpwent(); 1486 die "getpwent: $!\n" unless (@getpwent); 1487 isnt_tainted($getpwent[0]); 1488 is_tainted($getpwent[1]); 1489 isnt_tainted($getpwent[2]); 1490 isnt_tainted($getpwent[3]); 1491 isnt_tainted($getpwent[4]); 1492 isnt_tainted($getpwent[5]); 1493 is_tainted($getpwent[6], 'ge?cos'); 1494 isnt_tainted($getpwent[7]); 1495 is_tainted($getpwent[8], 'shell'); 1496 endpwent(); 1497 } 1498 1499 SKIP: { 1500 # pretty hard to imagine not 1501 skip "readdir() is not available", 1 unless $Config{d_readdir}; 1502 1503 opendir my $dh, "op" or die "opendir: $!\n"; 1504 my $readdir = readdir $dh; 1505 is_tainted($readdir); 1506 closedir $dh; 1507 } 1508 1509 SKIP: { 1510 skip "readlink() or symlink() is not available" unless 1511 $Config{d_readlink} && $Config{d_symlink}; 1512 1513 my $symlink = "sl$$"; 1514 unlink($symlink); 1515 my $sl = "/something/naughty"; 1516 # it has to be a real path on Mac OS 1517 unless (symlink($sl, $symlink)) { 1518 skip "symlink not available or no priviliges", 1, 1519 if $^O eq "MSWin32"; 1520 die "symlink: $!\n"; 1521 } 1522 my $readlink = readlink($symlink); 1523 is_tainted($readlink); 1524 unlink($symlink); 1525 } 1526} 1527 1528# test bitwise ops (regression bug) 1529{ 1530 no warnings 'numeric'; 1531 my $why = "y"; 1532 my $j = "x" | $why; 1533 isnt_tainted($j); 1534 $why = $TAINT."y"; 1535 $j = "x" | $why; 1536 is_tainted( $j); 1537} 1538 1539# test target of substitution (regression bug) 1540{ 1541 my $why = $TAINT."y"; 1542 $why =~ s/y/z/; 1543 is_tainted( $why); 1544 1545 my $z = "[z]"; 1546 $why =~ s/$z/zee/; 1547 is_tainted( $why); 1548 1549 $why =~ s/e/'-'.$$/ge; 1550 is_tainted( $why); 1551} 1552 1553 1554SKIP: { 1555 skip "no IPC::SysV", 2 unless $ipcsysv; 1556 1557 # test shmread 1558 SKIP: { 1559 skip "shm*() not available", 1 unless $Config{d_shm}; 1560 1561 no strict 'subs'; 1562 my $sent = "foobar"; 1563 my $rcvd; 1564 my $size = 2000; 1565 my $id; 1566 eval { 1567 local $SIG{SYS} = sub { die "SIGSYS caught\n" }; 1568 $id = shmget(IPC_PRIVATE, $size, S_IRWXU); 1569 1; 1570 } or do { chomp(my $msg = $@); skip "shmget: $msg", 1; }; 1571 1572 if (defined $id) { 1573 if (shmwrite($id, $sent, 0, 60)) { 1574 if (shmread($id, $rcvd, 0, 60)) { 1575 substr($rcvd, index($rcvd, "\0")) = ''; 1576 } else { 1577 warn "# shmread failed: $!\n"; 1578 } 1579 } else { 1580 warn "# shmwrite failed: $!\n"; 1581 } 1582 shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; 1583 } else { 1584 warn "# shmget failed: $!\n"; 1585 } 1586 1587 skip "SysV shared memory operation failed", 1 1588 unless defined $rcvd and $rcvd eq $sent; 1589 1590 is_tainted($rcvd, "shmread"); 1591 } 1592 1593 1594 # test msgrcv 1595 SKIP: { 1596 skip "msg*() not available", 1 unless $Config{d_msg}; 1597 1598 no strict 'subs'; 1599 my $id; 1600 eval { 1601 local $SIG{SYS} = sub { die "SIGSYS caught\n" }; 1602 $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); 1603 1; 1604 } or do { chomp(my $msg = $@); skip "msgget: $msg", 1; }; 1605 1606 my $sent = "message"; 1607 my $type_sent = 1234; 1608 my $rcvd; 1609 my $type_rcvd; 1610 1611 if (defined $id) { 1612 if (msgsnd($id, pack("l! a*", $type_sent, $sent), IPC_NOWAIT)) { 1613 if (msgrcv($id, $rcvd, 60, 0, IPC_NOWAIT)) { 1614 ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); 1615 } else { 1616 warn "# msgrcv failed: $!\n"; 1617 } 1618 } else { 1619 warn "# msgsnd failed: $!\n"; 1620 } 1621 msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; 1622 } else { 1623 warn "# msgget failed\n"; 1624 } 1625 1626 SKIP: { 1627 skip "SysV message queue operation failed", 1 1628 unless $rcvd eq $sent && $type_sent == $type_rcvd; 1629 1630 is_tainted($rcvd, "msgrcv"); 1631 } 1632 } 1633} 1634 1635{ 1636 # bug id 20001004.006 (#4380) 1637 1638 open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; 1639 local $/; 1640 my $a = <$fh>; 1641 my $b = <$fh>; 1642 1643 is_tainted($a); 1644 is_tainted($b); 1645 is($b, undef); 1646} 1647 1648{ 1649 # bug id 20001004.007 (#4381) 1650 1651 open my $fh, '<', $TEST or warn "$0: cannot read $TEST: $!" ; 1652 my $a = <$fh>; 1653 1654 my $c = { a => 42, 1655 b => $a }; 1656 1657 isnt_tainted($c->{a}); 1658 is_tainted($c->{b}); 1659 1660 1661 my $d = { a => $a, 1662 b => 42 }; 1663 is_tainted($d->{a}); 1664 isnt_tainted($d->{b}); 1665 1666 1667 my $e = { a => 42, 1668 b => { c => $a, d => 42 } }; 1669 isnt_tainted($e->{a}); 1670 isnt_tainted($e->{b}); 1671 is_tainted($e->{b}->{c}); 1672 isnt_tainted($e->{b}->{d}); 1673} 1674 1675{ 1676 # bug id 20010519.003 (#7015) 1677 1678 our $has_fcntl; 1679 BEGIN { 1680 eval { require Fcntl; Fcntl->import; }; 1681 unless ($@) { 1682 $has_fcntl = 1; 1683 } 1684 } 1685 1686 SKIP: { 1687 skip "no Fcntl", 36 unless $has_fcntl; 1688 1689 my $foo = tempfile(); 1690 my $evil = $foo . $TAINT; 1691 1692 is(eval { sysopen(my $ro, $evil, &O_RDONLY) }, undef); 1693 is($@, ''); 1694 1695 violates_taint(sub { sysopen(my $wo, $evil, &O_WRONLY) }, 'sysopen'); 1696 violates_taint(sub { sysopen(my $rw, $evil, &O_RDWR) }, 'sysopen'); 1697 violates_taint(sub { sysopen(my $ap, $evil, &O_APPEND) }, 'sysopen'); 1698 violates_taint(sub { sysopen(my $cr, $evil, &O_CREAT) }, 'sysopen'); 1699 violates_taint(sub { sysopen(my $tr, $evil, &O_TRUNC) }, 'sysopen'); 1700 1701 is(eval { sysopen(my $ro, $foo, &O_RDONLY | $TAINT0) }, undef); 1702 is($@, ''); 1703 1704 violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY | $TAINT0) }, 'sysopen'); 1705 violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR | $TAINT0) }, 'sysopen'); 1706 violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND | $TAINT0) }, 'sysopen'); 1707 violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT | $TAINT0) }, 'sysopen'); 1708 violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC | $TAINT0) }, 'sysopen'); 1709 is(eval { sysopen(my $ro, $foo, &O_RDONLY, $TAINT0) }, undef); 1710 is($@, ''); 1711 1712 violates_taint(sub { sysopen(my $wo, $foo, &O_WRONLY, $TAINT0) }, 'sysopen'); 1713 violates_taint(sub { sysopen(my $rw, $foo, &O_RDWR, $TAINT0) }, 'sysopen'); 1714 violates_taint(sub { sysopen(my $ap, $foo, &O_APPEND, $TAINT0) }, 'sysopen'); 1715 violates_taint(sub { sysopen(my $cr, $foo, &O_CREAT, $TAINT0) }, 'sysopen'); 1716 violates_taint(sub { sysopen(my $tr, $foo, &O_TRUNC, $TAINT0) }, 'sysopen'); 1717 } 1718} 1719 1720{ 1721 # bug 20010526.004 (#7041) 1722 1723 use warnings; 1724 1725 my $saw_warning = 0; 1726 local $SIG{__WARN__} = sub { ++$saw_warning }; 1727 1728 sub fmi { 1729 my $divnum = shift()/1; 1730 sprintf("%1.1f\n", $divnum); 1731 } 1732 1733 fmi(21 . $TAINT); 1734 fmi(37); 1735 fmi(248); 1736 1737 is($saw_warning, 0); 1738} 1739 1740 1741{ 1742 # Bug ID 20010730.010 (#7387) 1743 1744 my $i = 0; 1745 1746 sub Tie::TIESCALAR { 1747 my $class = shift; 1748 my $arg = shift; 1749 1750 bless \$arg => $class; 1751 } 1752 1753 sub Tie::FETCH { 1754 $i ++; 1755 ${$_ [0]} 1756 } 1757 1758 1759 package main; 1760 1761 my $bar = "The Big Bright Green Pleasure Machine"; 1762 taint_these $bar; 1763 tie my ($foo), Tie => $bar; 1764 1765 my $baz = $foo; 1766 1767 ok $i == 1; 1768} 1769 1770{ 1771 # Check that all environment variables are tainted. 1772 my @untainted; 1773 while (my ($k, $v) = each %ENV) { 1774 if (!tainted($v) && 1775 # These we have explicitly untainted or set earlier. 1776 $k !~ /^(BASH_ENV|CDPATH|ENV|IFS|PATH|PERL_CORE|TEMP|TERM|TMP|PERL5LIB)$/) { 1777 push @untainted, "# '$k' = '$v'\n"; 1778 } 1779 } 1780 is("@untainted", "", "untainted"); 1781} 1782 1783 1784is(${^TAINT}, 1, '$^TAINT is on'); 1785 1786eval { ${^TAINT} = 0 }; 1787is(${^TAINT}, 1, '$^TAINT is not assignable'); 1788like($@, qr/^Modification of a read-only value attempted/, 1789 'Assigning to ${^TAINT} fails'); 1790 1791{ 1792 # bug 20011111.105 (#7897) 1793 1794 my $re1 = qr/x$TAINT/; 1795 is_tainted($re1); 1796 1797 my $re2 = qr/^$re1\z/; 1798 is_tainted($re2); 1799 1800 my $re3 = "$re2"; 1801 is_tainted($re3); 1802} 1803 1804SKIP: { 1805 skip "system {} has different semantics on Win32", 1 if $Is_MSWin32; 1806 1807 # bug 20010221.005 (#5882) 1808 local $ENV{PATH} .= $TAINT; 1809 eval { system { "echo" } "/arg0", "arg1" }; 1810 like($@, qr/^Insecure \$ENV/); 1811} 1812 1813TODO: { 1814 todo_skip 'tainted %ENV warning occludes tainted arguments warning', 22 1815 if $Is_VMS; 1816 1817 # bug 20020208.005 (#8465) plus some single arg exec/system extras 1818 violates_taint(sub { exec $TAINT, $TAINT }, 'exec'); 1819 violates_taint(sub { exec $TAINT $TAINT }, 'exec'); 1820 violates_taint(sub { exec $TAINT $TAINT, $TAINT }, 'exec'); 1821 violates_taint(sub { exec $TAINT 'notaint' }, 'exec'); 1822 violates_taint(sub { exec {'notaint'} $TAINT }, 'exec'); 1823 1824 violates_taint(sub { system $TAINT, $TAINT }, 'system'); 1825 violates_taint(sub { system $TAINT $TAINT }, 'system'); 1826 violates_taint(sub { system $TAINT $TAINT, $TAINT }, 'system'); 1827 violates_taint(sub { system $TAINT 'notaint' }, 'system'); 1828 violates_taint(sub { system {'notaint'} $TAINT }, 'system'); 1829 1830 eval { 1831 no warnings; 1832 system("lskdfj does not exist","with","args"); 1833 }; 1834 is($@, ""); 1835 1836 eval { 1837 no warnings; 1838 exec("lskdfj does not exist","with","args"); 1839 }; 1840 is($@, ""); 1841 1842 # If you add tests here update also the above skip block for VMS. 1843} 1844 1845{ 1846 # [ID 20020704.001 (#10026)] taint propagation failure 1847 use re 'taint'; 1848 $TAINT =~ /(.*)/; 1849 is_tainted(my $foo = $1); 1850} 1851 1852{ 1853 # [perl #24291] this used to dump core 1854 our %nonmagicalenv = ( PATH => "util" ); 1855 local *ENV = \%nonmagicalenv; 1856 eval { system("lskdfj"); }; 1857 like($@, qr/^%ENV is aliased to another variable while running with -T switch/); 1858 local *ENV = *nonmagicalenv; 1859 eval { system("lskdfj"); }; 1860 like($@, qr/^%ENV is aliased to %nonmagicalenv while running with -T switch/); 1861} 1862{ 1863 # [perl #24248] 1864 $TAINT =~ /(.*)/; 1865 isnt_tainted($1); 1866 my $notaint = $1; 1867 isnt_tainted($notaint); 1868 1869 my $l; 1870 $notaint =~ /($notaint)/; 1871 $l = $1; 1872 isnt_tainted($1); 1873 isnt_tainted($l); 1874 $notaint =~ /($TAINT)/; 1875 $l = $1; 1876 is_tainted($1); 1877 is_tainted($l); 1878 1879 $TAINT =~ /($notaint)/; 1880 $l = $1; 1881 isnt_tainted($1); 1882 isnt_tainted($l); 1883 $TAINT =~ /($TAINT)/; 1884 $l = $1; 1885 is_tainted($1); 1886 is_tainted($l); 1887 1888 my $r; 1889 ($r = $TAINT) =~ /($notaint)/; 1890 isnt_tainted($1); 1891 ($r = $TAINT) =~ /($TAINT)/; 1892 is_tainted($1); 1893 1894 { 1895 use re 'eval'; # this shouldn't make any difference 1896 ($r = $TAINT) =~ /($notaint)/; 1897 isnt_tainted($1); 1898 ($r = $TAINT) =~ /($TAINT)/; 1899 is_tainted($1); 1900 } 1901 1902 # [perl #24674] 1903 # accessing $^O shoudn't taint it as a side-effect; 1904 # assigning tainted data to it is now an error 1905 1906 isnt_tainted($^O); 1907 if (!$^X) { } elsif ($^O eq 'bar') { } 1908 isnt_tainted($^O); 1909 local $^O; # We're going to clobber something test infrastructure depends on. 1910 eval '$^O = $^X'; 1911 like($@, qr/Insecure dependency in/); 1912} 1913 1914EFFECTIVELY_CONSTANTS: { 1915 my $tainted_number = 12 + $TAINT0; 1916 is_tainted( $tainted_number ); 1917 1918 # Even though it's always 0, it's still tainted 1919 my $tainted_product = $tainted_number * 0; 1920 is_tainted( $tainted_product ); 1921 is($tainted_product, 0); 1922} 1923 1924TERNARY_CONDITIONALS: { 1925 my $tainted_true = $TAINT . "blah blah blah"; 1926 my $tainted_false = $TAINT0; 1927 is_tainted( $tainted_true ); 1928 is_tainted( $tainted_false ); 1929 1930 my $result = $tainted_true ? "True" : "False"; 1931 is($result, "True"); 1932 isnt_tainted( $result ); 1933 1934 $result = $tainted_false ? "True" : "False"; 1935 is($result, "False"); 1936 isnt_tainted( $result ); 1937 1938 my $untainted_whatever = "The Fabulous Johnny Cash"; 1939 my $tainted_whatever = "Soft Cell" . $TAINT; 1940 1941 $result = $tainted_true ? $tainted_whatever : $untainted_whatever; 1942 is($result, "Soft Cell"); 1943 is_tainted( $result ); 1944 1945 $result = $tainted_false ? $tainted_whatever : $untainted_whatever; 1946 is($result, "The Fabulous Johnny Cash"); 1947 isnt_tainted( $result ); 1948} 1949 1950{ 1951 # rt.perl.org 5900 $1 remains tainted if... 1952 # 1) The regular expression contains a scalar variable AND 1953 # 2) The regular expression appears in an elsif clause 1954 1955 my $foo = "abcdefghi" . $TAINT; 1956 1957 my $valid_chars = 'a-z'; 1958 if ( $foo eq '' ) { 1959 } 1960 elsif ( $foo =~ /([$valid_chars]+)/o ) { 1961 isnt_tainted($1); 1962 isnt($1, undef); 1963 } 1964 1965 if ( $foo eq '' ) { 1966 } 1967 elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) { 1968 isnt_tainted($bar[0]); 1969 is(scalar @bar, 1); 1970 } 1971} 1972 1973# at scope exit, a restored localised value should have its old 1974# taint status, not the taint status of the current statement 1975 1976{ 1977 our $x99 = $^X; 1978 is_tainted($x99); 1979 1980 $x99 = ''; 1981 isnt_tainted($x99); 1982 1983 my $c = do { local $x99; $^X }; 1984 isnt_tainted($x99); 1985} 1986{ 1987 our $x99 = $^X; 1988 is_tainted($x99); 1989 1990 my $c = do { local $x99; '' }; 1991 is_tainted($x99); 1992} 1993 1994# an mg_get of a tainted value during localization shouldn't taint the 1995# statement 1996 1997{ 1998 eval { local $0, eval '1' }; 1999 is($@, ''); 2000} 2001 2002# [perl #8262] //g loops infinitely on tainted data 2003 2004{ 2005 my @a; 2006 $a[0] = $^X . '-'; 2007 $a[0]=~ m/(.)/g; 2008 cmp_ok pos($a[0]), '>', 0, "infinite m//g on arrays (aelemfast)"; 2009 2010 my $i = 1; 2011 $a[$i] = $^X . '-'; 2012 $a[$i]=~ m/(.)/g; 2013 cmp_ok pos($a[$i]), '>', 0, "infinite m//g on arrays (aelem)"; 2014 2015 my %h; 2016 $h{a} = $^X . '-'; 2017 $h{a}=~ m/(.)/g; 2018 cmp_ok pos($h{a}), '>', 0, "infinite m//g on hashes (helem)"; 2019} 2020 2021SKIP: 2022{ 2023 my $got_dualvar; 2024 eval 'use Scalar::Util "dualvar"; $got_dualvar++'; 2025 skip "No Scalar::Util::dualvar" unless $got_dualvar; 2026 my $a = Scalar::Util::dualvar(3, $^X); 2027 my $b = $a + 5; 2028 is ($b, 8, "Arithmetic on tainted dualvars works"); 2029} 2030 2031# opening '|-' should not trigger $ENV{PATH} check 2032 2033{ 2034 SKIP: { 2035 skip "fork() is not available", 3 unless $Config{'d_fork'}; 2036 skip "opening |- is not stable on threaded Open/MirBSD with taint", 3 2037 if $Config{useithreads} and $Is_OpenBSD || $Is_MirBSD; 2038 2039 $ENV{'PATH'} = $TAINT; 2040 local $SIG{'PIPE'} = 'IGNORE'; 2041 eval { 2042 my $pid = open my $pipe, '|-'; 2043 if (!defined $pid) { 2044 die "open failed: $!"; 2045 } 2046 if (!$pid) { 2047 kill 'KILL', $$; # child suicide 2048 } 2049 close $pipe; 2050 }; 2051 unlike($@, qr/Insecure \$ENV/, 'fork triggers %ENV check'); 2052 is($@, '', 'pipe/fork/open/close failed'); 2053 eval { 2054 open my $pipe, "|$Invoke_Perl -e 1"; 2055 close $pipe; 2056 }; 2057 like($@, qr/Insecure \$ENV/, 'popen neglects %ENV check'); 2058 } 2059} 2060 2061{ 2062 package AUTOLOAD_TAINT; 2063 sub AUTOLOAD { 2064 our $AUTOLOAD; 2065 return if $AUTOLOAD =~ /DESTROY/; 2066 if ($AUTOLOAD =~ /untainted/) { 2067 main::isnt_tainted($AUTOLOAD, '$AUTOLOAD can be untainted'); 2068 my $copy = $AUTOLOAD; 2069 main::isnt_tainted($copy, '$AUTOLOAD can be untainted'); 2070 } else { 2071 main::is_tainted($AUTOLOAD, '$AUTOLOAD can be tainted'); 2072 my $copy = $AUTOLOAD; 2073 main::is_tainted($copy, '$AUTOLOAD can be tainted'); 2074 } 2075 } 2076 2077 package main; 2078 my $o = bless [], 'AUTOLOAD_TAINT'; 2079 $o->untainted; 2080 $o->$TAINT; 2081 $o->untainted; 2082} 2083 2084{ 2085 # tests for tainted format in s?printf 2086 my $fmt = $TAINT . "# %s\n"; 2087 violates_taint(sub { printf($fmt, "foo") }, 'printf', 2088 q/printf doesn't like tainted formats/); 2089 violates_taint(sub { printf($TAINT . "# %s\n", "foo") }, 'printf', 2090 q/printf doesn't like tainted format expressions/); 2091 eval { printf("# %s\n", $TAINT . "foo") }; 2092 is($@, '', q/printf accepts other tainted args/); 2093 violates_taint(sub { sprintf($fmt, "foo") }, 'sprintf', 2094 q/sprintf doesn't like tainted formats/); 2095 violates_taint(sub { sprintf($TAINT . "# %s\n", "foo") }, 'sprintf', 2096 q/sprintf doesn't like tainted format expressions/); 2097 eval { my $str = sprintf("# %s\n", $TAINT . "foo") }; 2098 is($@, '', q/sprintf accepts other tainted args/); 2099} 2100 2101{ 2102 # 40708 2103 my $n = 7e9; 2104 my $sub = 8e9 - $n; 2105 is ( $sub, 1000000000, '8e9 - 7e9' ); 2106 2107 my $val = $n; 2108 is ($val, '7000000000', 'Assignment to untainted variable'); 2109 $val = $TAINT; 2110 $val = $n; 2111 is ($val, '7000000000', 'Assignment to tainted variable'); 2112} 2113 2114{ 2115 my $val = 0; 2116 my $tainted = '1' . $TAINT; 2117 eval '$val = eval $tainted;'; 2118 is ($val, 0, "eval doesn't like tainted strings"); 2119 like ($@, qr/^Insecure dependency in eval/); 2120 2121 # Rather nice code to get a tainted undef by from Rick Delaney 2122 open my $fh, "test.pl" or die $!; 2123 seek $fh, 0, 2 or die $!; 2124 $tainted = <$fh>; 2125 2126 no warnings 'uninitialized'; 2127 eval 'eval $tainted'; 2128 like ($@, qr/^Insecure dependency in eval/); 2129} 2130 2131foreach my $ord (78, 163, 256) { 2132 # 47195 2133 my $line = 'A1' . $TAINT . chr $ord; 2134 chop $line; 2135 is($line, 'A1'); 2136 $line =~ /(A\S*)/; 2137 isnt_tainted($1, "\\S match with chr $ord"); 2138} 2139 2140{ 2141 SKIP: { 2142 skip 'No crypt function, skipping crypt tests', 4 if(!$Config{d_crypt}); 2143 # 59998 2144 sub cr { 2145 # On platforms implementing FIPS mode, using a weak algorithm 2146 # (including the default triple-DES algorithm) causes crypt(3) to 2147 # return a null pointer, which Perl converts into undef. We assume 2148 # for now that all such platforms support glibc-style selection of 2149 # a different hashing algorithm. 2150 # glibc supports MD5, but OpenBSD only supports Blowfish. 2151 my $alg = ''; # Use default algorithm 2152 if ( !defined(crypt("ab", $alg."cd")) ) { 2153 $alg = '$5$'; # Try SHA-256 2154 } 2155 if ( !defined(crypt("ab", $alg."cd")) ) { 2156 $alg = '$2b$12$FPWWO2RJ3CK4FINTw0Hi'; # Try Blowfish 2157 } 2158 if ( !defined(crypt("ab", $alg."cd")) ) { 2159 $alg = ''; # Nothing worked. Back to default 2160 } 2161 my $x = crypt($_[0], $alg . $_[1]); 2162 $x 2163 } 2164 sub co { no warnings 'numeric'; my $x = ~$_[0]; $x } 2165 my ($a, $b); 2166 $a = cr('hello', 'foo' . $TAINT); 2167 $b = cr('hello', 'foo'); 2168 is_tainted($a, "tainted crypt"); 2169 isnt_tainted($b, "untainted crypt"); 2170 $a = co('foo' . $TAINT); 2171 $b = co('foo'); 2172 is_tainted($a, "tainted complement"); 2173 isnt_tainted($b, "untainted complement"); 2174 } 2175} 2176 2177{ 2178 my @data = qw(bonk zam zlonk qunckkk); 2179 # Clearly some sort of usenet bang-path 2180 my $string = $TAINT . join "!", @data; 2181 2182 is_tainted($string, "tainted data"); 2183 2184 my @got = split /!|,/, $string; 2185 2186 # each @got would be useful here, but I want the test for earlier perls 2187 for my $i (0 .. $#data) { 2188 is_tainted($got[$i], "tainted result $i"); 2189 is($got[$i], $data[$i], "correct content $i"); 2190 } 2191 2192 is_tainted($string, "still tainted data"); 2193 2194 @got = split /[!,]/, $string; 2195 2196 # each @got would be useful here, but I want the test for earlier perls 2197 for my $i (0 .. $#data) { 2198 is_tainted($got[$i], "tainted result $i"); 2199 is($got[$i], $data[$i], "correct content $i"); 2200 } 2201 2202 is_tainted($string, "still tainted data"); 2203 2204 @got = split /!/, $string; 2205 2206 # each @got would be useful here, but I want the test for earlier perls 2207 for my $i (0 .. $#data) { 2208 is_tainted($got[$i], "tainted result $i"); 2209 is($got[$i], $data[$i], "correct content $i"); 2210 } 2211} 2212 2213# Bug RT #52552 - broken by change at git commit id f337b08 2214{ 2215 my $x = $TAINT. q{print "Hello world\n"}; 2216 my $y = pack "a*", $x; 2217 is_tainted($y, "pack a* preserves tainting"); 2218 2219 my $z = pack "A*", q{print "Hello world\n"}.$TAINT; 2220 is_tainted($z, "pack A* preserves tainting"); 2221 2222 my $zz = pack "a*a*", q{print "Hello world\n"}, $TAINT; 2223 is_tainted($zz, "pack a*a* preserves tainting"); 2224} 2225 2226# Bug RT #61976 tainted $! would show numeric rather than string value 2227 2228{ 2229 my $tainted_path = substr($^X,0,0) . "/no/such/file"; 2230 my $err; 2231 # $! is used in a tainted expression, so gets tainted 2232 open my $fh, $tainted_path or $err= "$!"; 2233 unlike($err, qr/^\d+$/, 'tainted $!'); 2234} 2235 2236{ 2237 # #6758: tainted values become untainted in tied hashes 2238 # (also applies to other value magic such as pos) 2239 2240 2241 package P6758; 2242 2243 sub TIEHASH { bless {} } 2244 sub TIEARRAY { bless {} } 2245 2246 my $i = 0; 2247 2248 sub STORE { 2249 main::is_tainted($_[1], "tied arg1 tainted"); 2250 main::is_tainted($_[2], "tied arg2 tainted"); 2251 $i++; 2252 } 2253 2254 package main; 2255 2256 my ($k,$v) = qw(1111 val); 2257 taint_these($k,$v); 2258 tie my @array, 'P6758'; 2259 tie my %hash , 'P6758'; 2260 $array[$k] = $v; 2261 $hash{$k} = $v; 2262 ok $i == 2, "tied STORE called correct number of times"; 2263} 2264 2265# Bug RT #45167 the return value of sprintf sometimes wasn't tainted 2266# when the args were tainted. This only occurred on the first use of 2267# sprintf; after that, its TARG has taint magic attached, so setmagic 2268# at the end works. That's why there are multiple sprintf's below, rather 2269# than just one wrapped in an inner loop. Also, any plaintext between 2270# format entries would correctly cause tainting to get set. so test with 2271# "%s%s" rather than eg "%s %s". 2272 2273{ 2274 for my $var1 ($TAINT, "123") { 2275 for my $var2 ($TAINT0, "456") { 2276 no warnings q(redundant); 2277 is( tainted(sprintf '%s', $var1, $var2), tainted($var1), 2278 "sprintf '%s', '$var1', '$var2'" ); 2279 is( tainted(sprintf ' %s', $var1, $var2), tainted($var1), 2280 "sprintf ' %s', '$var1', '$var2'" ); 2281 is( tainted(sprintf '%s%s', $var1, $var2), 2282 tainted($var1) || tainted($var2), 2283 "sprintf '%s%s', '$var1', '$var2'" ); 2284 } 2285 } 2286} 2287 2288 2289# Bug RT #67962: old tainted $1 gets treated as tainted 2290# in next untainted # match 2291 2292{ 2293 use re 'taint'; 2294 my $x = "abc".$TAINT =~ /(.*)/; # make $1 tainted 2295 is_tainted($1, '$1 should be tainted'); 2296 2297 my $untainted = "abcdef"; 2298 isnt_tainted($untainted, '$untainted should be untainted'); 2299 $untainted =~ s/(abc)/$1/; 2300 isnt_tainted($untainted, '$untainted should still be untainted'); 2301 $untainted =~ s/(abc)/x$1/; 2302 isnt_tainted($untainted, '$untainted should yet still be untainted'); 2303} 2304 2305{ 2306 # On Windows we can't spawn a fresh Perl interpreter unless at 2307 # least the Windows system directory (usually C:\Windows\System32) 2308 # is still on the PATH. There is however no way to determine the 2309 # actual path on the current system without loading the Win32 2310 # module, so we just restore the original $ENV{PATH} here. 2311 local $ENV{PATH} = $ENV{PATH}; 2312 $ENV{PATH} = $old_env_path if $Is_MSWin32; 2313 2314 fresh_perl_is(<<'end', "ok", { switches => [ '-T' ] }, 2315 $TAINT = substr($^X, 0, 0); 2316 formline('@'.('<'x("2000".$TAINT)).' | @*', 'hallo', 'welt'); 2317 print "ok"; 2318end 2319 "formline survives a tainted dynamic picture"); 2320} 2321 2322{ 2323 isnt_tainted($^A, "format accumulator not tainted yet"); 2324 formline('@ | @*', 'hallo' . $TAINT, 'welt'); 2325 is_tainted($^A, "tainted formline argument makes a tainted accumulator"); 2326 $^A = ""; 2327 isnt_tainted($^A, "accumulator can be explicitly untainted"); 2328 formline('@' .('<'x5) . ' | @*', 'hallo', 'welt'); 2329 isnt_tainted($^A, "accumulator still untainted"); 2330 $^A = "" . $TAINT; 2331 is_tainted($^A, "accumulator can be explicitly tainted"); 2332 formline('@' .('<'x5) . ' | @*', 'hallo', 'welt'); 2333 is_tainted($^A, "accumulator still tainted"); 2334 $^A = ""; 2335 isnt_tainted($^A, "accumulator untainted again"); 2336 formline('@' .('<'x5) . ' | @*', 'hallo', 'welt'); 2337 isnt_tainted($^A, "accumulator still untainted"); 2338 formline('@' .('<'x(5+$TAINT0)) . ' | @*', 'hallo', 'welt'); 2339 is_tainted($^A, "the accumulator should be tainted already"); 2340 is_tainted($^A, "tainted formline picture makes a tainted accumulator"); 2341} 2342 2343{ # Bug #80610 2344 "Constant(1)" =~ / ^ ([a-z_]\w*) (?: [(] (.*) [)] )? $ /xi; 2345 my $a = $1; 2346 my $b = $2; 2347 isnt_tainted($a, "regex optimization of single char /[]/i doesn't taint"); 2348 isnt_tainted($b, "regex optimization of single char /[]/i doesn't taint"); 2349} 2350 2351{ 2352 # RT 81230: tainted value during FETCH created extra ref to tied obj 2353 2354 package P81230; 2355 use warnings; 2356 2357 my %h; 2358 2359 sub TIEHASH { 2360 my $x = $^X; # tainted 2361 bless \$x; 2362 } 2363 sub FETCH { my $x = $_[0]; $$x . "" } 2364 2365 tie %h, 'P81230'; 2366 2367 my $w = ""; 2368 local $SIG{__WARN__} = sub { $w .= "@_" }; 2369 2370 untie %h if $h{"k"}; 2371 2372 ::is($w, "", "RT 81230"); 2373} 2374 2375{ 2376 # Compiling a subroutine inside a tainted expression does not make the 2377 # constant folded values tainted. 2378 my $x = sub { "x" . "y" }; 2379 my $y = $ENV{PATH} . $x->(); # Compile $x inside a tainted expression 2380 my $z = $x->(); 2381 isnt_tainted($z, "Constants folded value not tainted"); 2382} 2383 2384{ 2385 # now that regexes are first class SVs, make sure that they themselves 2386 # as well as references to them are tainted 2387 2388 my $rr = qr/(.)$TAINT/; 2389 my $r = $$rr; # bare REGEX 2390 my $s ="abc"; 2391 ok($s =~ s/$r/x/, "match bare regex"); 2392 is_tainted($s, "match bare regex taint"); 2393 is($s, 'xbc', "match bare regex taint value"); 2394} 2395 2396{ 2397 # [perl #82616] security Issues with user-defined \p{} properties 2398 # A using a tainted user-defined property should croak 2399 2400 sub IsA { sprintf "%02x", ord("A") } 2401 2402 my $prop = "IsA"; 2403 ok("A" =~ /\p{$prop}/, "user-defined property: non-tainted case"); 2404 $prop = "IsA$TAINT"; 2405 eval { "A" =~ /\p{$prop}/}; 2406 like($@, qr/Insecure user-defined property "IsA" in regex/, 2407 "user-defined property: tainted case"); 2408 2409} 2410 2411{ 2412 SKIP: { 2413 skip "Environment tainting tests skipped", 1 2414 if $Is_MSWin32 || $Is_VMS; 2415 2416 local $ENV{XX} = '\p{IsB}'; # Making it an environment variable taints it 2417 2418 fresh_perl_like(<<'EOF', 2419 BEGIN { $re = qr/$ENV{XX}/; } 2420 2421 sub IsB { "42" }; 2422 "B" =~ $re 2423EOF 2424 qr/Insecure user-defined property \\p\{main::IsB\}/, 2425 { switches => [ "-T" ] }, 2426 "user-defined property; defn not known until runtime, tainted case"); 2427 } 2428} 2429 2430{ 2431 # [perl #87336] lc/uc(first) failing to taint the returned string 2432 my $source = "foo$TAINT"; 2433 my $dest = lc $source; 2434 is_tainted $dest, "lc(tainted) taints its return value"; 2435 $dest = lcfirst $source; 2436 is_tainted $dest, "lcfirst(tainted) taints its return value"; 2437 $dest = uc $source; 2438 is_tainted $dest, "uc(tainted) taints its return value"; 2439 $dest = ucfirst $source; 2440 is_tainted $dest, "ucfirst(tainted) taints its return value"; 2441} 2442 2443{ 2444 # Taintedness of values returned from given() 2445 use feature 'switch'; 2446 no warnings 'experimental::smartmatch'; 2447 2448 my @descriptions = ('when', 'given end', 'default'); 2449 2450 for (qw<x y z>) { 2451 my $letter = "$_$TAINT"; 2452 2453 my $desc = "tainted value returned from " . shift(@descriptions); 2454 2455 my $res = do { 2456 no warnings 'deprecated'; 2457 given ($_) { 2458 when ('x') { $letter } 2459 when ('y') { goto leavegiven } 2460 default { $letter } 2461 leavegiven: $letter 2462 } 2463 }; 2464 is $res, $letter, "$desc is correct"; 2465 is_tainted $res, "$desc stays tainted"; 2466 } 2467} 2468 2469 2470# tainted constants and index() 2471# RT 64804; http://bugs.debian.org/291450 2472{ 2473 ok(tainted $old_env_path, "initial taintedness"); 2474 BEGIN { no strict 'refs'; my $v = $old_env_path; *{"::C"} = sub () { $v }; } 2475 ok(tainted C, "constant is tainted properly"); 2476 ok(!tainted "", "tainting not broken yet"); 2477 no warnings 'uninitialized'; 2478 my $ix = index(undef, C); 2479 is( $ix, -1, q[index(undef, C)] ); 2480 ok(!tainted "", "tainting still works after index() of the constant"); 2481} 2482 2483# Tainted values with smartmatch 2484# [perl #93590] S_do_smartmatch stealing its own string buffers 2485{ 2486no warnings 'deprecated'; 2487ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]'; 2488ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]'; 2489} 2490 2491# Tainted values and ref() 2492for(1,2) { 2493 my $x = bless \"M$TAINT", ref(bless[], "main"); 2494} 2495pass("no death when TARG of ref is tainted"); 2496 2497# $$ should not be tainted by being read in a tainted expression. 2498{ 2499 isnt_tainted $$, "PID not tainted initially"; 2500 my $x = $ENV{PATH}.$$; 2501 isnt_tainted $$, "PID not tainted when read in tainted expression"; 2502} 2503 2504SKIP: { 2505 skip 'Locales not available', 4 unless locales_enabled('LC_CTYPE'); 2506 2507 use feature 'fc'; 2508 use locale; 2509 my ($latin1, $utf8) = ("\xDF") x 2; 2510 utf8::downgrade($latin1); 2511 utf8::upgrade($utf8); 2512 2513 is_tainted fc($latin1), "under locale, lc(latin1) taints the result"; 2514 is_tainted fc($utf8), "under locale, lc(utf8) taints the result"; 2515 2516 is_tainted "\F$latin1", "under locale, \\Flatin1 taints the result"; 2517 is_tainted "\F$utf8", "under locale, \\Futf8 taints the result"; 2518} 2519 2520{ # 111654 2521 eval { 2522 eval { die "Test\n".substr($ENV{PATH}, 0, 0); }; 2523 die; 2524 }; 2525 like($@, qr/^Test\n\t\.\.\.propagated at /, "error should be propagated"); 2526} 2527 2528# tainted run-time (?{}) should die 2529 2530{ 2531 my $code = '(?{})' . $TAINT; 2532 use re 'eval'; 2533 eval { "a" =~ /$code/ }; 2534 like($@, qr/Eval-group in insecure regular expression/, "tainted (?{})"); 2535} 2536 2537# reset() and tainted undef (?!) 2538$::x = "foo"; 2539$_ = "$TAINT".reset "x"; 2540is eval { no warnings; eval $::x.1 }, 1, 'reset does not taint undef'; 2541 2542# [perl #122669] 2543{ 2544 # See the comment above the first formline test. 2545 local $ENV{PATH} = $ENV{PATH}; 2546 $ENV{PATH} = $old_env_path if $Is_MSWin32; 2547 is runperl( 2548 switches => [ '-T' ], 2549 prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; ' 2550 .'print 122669, qq-\n-', 2551 stderr => 1, 2552 ), "122669\n", 2553 'tainted constant as logop condition should not prevent "use"'; 2554} 2555 2556# optimised SETi etc need to handle tainting 2557 2558{ 2559 my ($i1, $i2, $i3) = (1, 1, 1); 2560 my ($n1, $n2, $n3) = (1.1, 1.1, 1.1); 2561 my $tn = $TAINT0 + 1.1; 2562 2563 $i1 = $TAINT0 + 2; 2564 is_tainted $i1, "+ SETi"; 2565 $i2 = $TAINT0 - 2; 2566 is_tainted $i2, "- SETi"; 2567 $i3 = $TAINT0 * 2; 2568 is_tainted $i3, "* SETi"; 2569 2570 $n1 = $tn + 2.2; 2571 is_tainted $n1, "+ SETn"; 2572 $n2 = $tn - 2.2; 2573 is_tainted $n2, "- SETn"; 2574 $n3 = $tn * 2.2; 2575 is_tainted $n3, "* SETn"; 2576} 2577 2578# check that localizing something with get magic (e.g. taint) doesn't 2579# upgrade pIOK to IOK 2580 2581{ 2582 local our $x = 1.1 + $TAINT0; # $x should be NOK 2583 my $ix = int($x); # now NOK, pIOK 2584 { 2585 local $x = 0; 2586 } 2587 my $x1 = $x * 1; 2588 isnt($x, 1); # it should be 1.1, not 1 2589} 2590 2591# RT #129996 2592# every item in a list assignment is independent, even if the lvalue 2593# has taint magic already 2594{ 2595 my ($a, $b, $c, $d); 2596 $d = ""; 2597 $b = $TAINT; 2598 ($a, $b, $c) = ($TAINT, 0, 0); 2599 is_tainted $a, "list assign tainted a"; 2600 isnt_tainted $b, "list assign tainted b"; 2601 isnt_tainted $c, "list assign tainted c"; 2602 2603 $b = $TAINT; 2604 $b = ""; # untaint; 2605 ($a, $b, $c) = ($TAINT, 0, 0); 2606 is_tainted $a, "list assign detainted a"; 2607 isnt_tainted $b, "list assign detainted b"; 2608 isnt_tainted $c, "list assign detainted c"; 2609 2610 $b = $TAINT; 2611 $b = ""; # untaint; 2612 ($a, $b, $c) = ($TAINT); 2613 is_tainted $a, "list assign empty rhs a"; 2614 isnt_tainted $b, "list assign empty rhs b"; 2615 isnt_tainted $c, "list assign empty rhs c"; 2616 2617 $b = $TAINT; 2618 $b = ""; # untaint; 2619 ($a = ($TAINT. "x")), (($b, $c) = (0)); 2620 is_tainted $a, "list assign already tainted expression a"; 2621 isnt_tainted $b, "list assign already tainted expression b"; 2622 isnt_tainted $c, "list assign already tainted expression c"; 2623 2624 $b = $TAINT; 2625 $b = ""; # untaint; 2626 (($a) = ($TAINT. "x")), ($b = $b . "x"); 2627 is_tainted $a, "list assign post tainted expression a"; 2628 isnt_tainted $b, "list assign post tainted expression b"; 2629} 2630 2631# Module::Runtime was temporarily broken between 5.27.0 and 5.27.1 because 2632# ref() would fail an assertion in a tainted statement. (No ok() neces- 2633# sary since it aborts when it fails.) 2634() = defined $^X && ref \$^X; 2635 2636# taint passing through overloading 2637package OvTaint { 2638 sub new { bless({ t => $_[1] }, $_[0]) } 2639 use overload '""' => sub { $_[0]->{t} ? "hi".$TAINT : "hello" }; 2640} 2641my $ovclean = OvTaint->new(0); 2642my $ovtaint = OvTaint->new(1); 2643isnt_tainted("$ovclean", "overload preserves cleanliness"); 2644is_tainted("$ovtaint", "overload preserves taint"); 2645 2646# substitutions with overloaded replacement 2647{ 2648 my ($desc, $s, $res, $one); 2649 2650 $desc = "substitution with partial replacement overloaded and clean"; 2651 $s = 'abcd'; 2652 $res = $s =~ s/(.+)/xyz$ovclean/; 2653 $one = $1; 2654 isnt_tainted($s, "$desc: s not tainted"); 2655 isnt_tainted($res, "$desc: res not tainted"); 2656 isnt_tainted($one, "$desc: \$1 not tainted"); 2657 is($s, 'xyzhello', "$desc: s value"); 2658 is($res, 1, "$desc: res value"); 2659 is($one, 'abcd', "$desc: \$1 value"); 2660 2661 $desc = "substitution with partial replacement overloaded and tainted"; 2662 $s = 'abcd'; 2663 $res = $s =~ s/(.+)/xyz$ovtaint/; 2664 $one = $1; 2665 is_tainted($s, "$desc: s tainted"); 2666 isnt_tainted($res, "$desc: res not tainted"); 2667 isnt_tainted($one, "$desc: \$1 not tainted"); 2668 is($s, 'xyzhi', "$desc: s value"); 2669 is($res, 1, "$desc: res value"); 2670 is($one, 'abcd', "$desc: \$1 value"); 2671 2672 $desc = "substitution with whole replacement overloaded and clean"; 2673 $s = 'abcd'; 2674 $res = $s =~ s/(.+)/$ovclean/; 2675 $one = $1; 2676 isnt_tainted($s, "$desc: s not tainted"); 2677 isnt_tainted($res, "$desc: res not tainted"); 2678 isnt_tainted($one, "$desc: \$1 not tainted"); 2679 is($s, 'hello', "$desc: s value"); 2680 is($res, 1, "$desc: res value"); 2681 is($one, 'abcd', "$desc: \$1 value"); 2682 2683 $desc = "substitution with whole replacement overloaded and tainted"; 2684 $s = 'abcd'; 2685 $res = $s =~ s/(.+)/$ovtaint/; 2686 $one = $1; 2687 is_tainted($s, "$desc: s tainted"); 2688 isnt_tainted($res, "$desc: res not tainted"); 2689 isnt_tainted($one, "$desc: \$1 not tainted"); 2690 is($s, 'hi', "$desc: s value"); 2691 is($res, 1, "$desc: res value"); 2692 is($one, 'abcd', "$desc: \$1 value"); 2693 2694 $desc = "substitution /e with partial replacement overloaded and clean"; 2695 $s = 'abcd'; 2696 $res = $s =~ s/(.+)/"xyz".$ovclean/e; 2697 $one = $1; 2698 isnt_tainted($s, "$desc: s not tainted"); 2699 isnt_tainted($res, "$desc: res not tainted"); 2700 isnt_tainted($one, "$desc: \$1 not tainted"); 2701 is($s, 'xyzhello', "$desc: s value"); 2702 is($res, 1, "$desc: res value"); 2703 is($one, 'abcd', "$desc: \$1 value"); 2704 2705 $desc = "substitution /e with partial replacement overloaded and tainted"; 2706 $s = 'abcd'; 2707 $res = $s =~ s/(.+)/"xyz".$ovtaint/e; 2708 $one = $1; 2709 is_tainted($s, "$desc: s tainted"); 2710 isnt_tainted($res, "$desc: res not tainted"); 2711 isnt_tainted($one, "$desc: \$1 not tainted"); 2712 is($s, 'xyzhi', "$desc: s value"); 2713 is($res, 1, "$desc: res value"); 2714 is($one, 'abcd', "$desc: \$1 value"); 2715 2716 $desc = "substitution /e with whole replacement overloaded and clean"; 2717 $s = 'abcd'; 2718 $res = $s =~ s/(.+)/$ovclean/e; 2719 $one = $1; 2720 isnt_tainted($s, "$desc: s not tainted"); 2721 isnt_tainted($res, "$desc: res not tainted"); 2722 isnt_tainted($one, "$desc: \$1 not tainted"); 2723 is($s, 'hello', "$desc: s value"); 2724 is($res, 1, "$desc: res value"); 2725 is($one, 'abcd', "$desc: \$1 value"); 2726 2727 $desc = "substitution /e with whole replacement overloaded and tainted"; 2728 $s = 'abcd'; 2729 $res = $s =~ s/(.+)/$ovtaint/e; 2730 $one = $1; 2731 is_tainted($s, "$desc: s tainted"); 2732 isnt_tainted($res, "$desc: res not tainted"); 2733 isnt_tainted($one, "$desc: \$1 not tainted"); 2734 is($s, 'hi', "$desc: s value"); 2735 is($res, 1, "$desc: res value"); 2736 is($one, 'abcd', "$desc: \$1 value"); 2737 2738 $desc = "substitution /e with extra code and partial replacement overloaded and clean"; 2739 $s = 'abcd'; 2740 $res = $s =~ s/(.+)/(my $z++), "xyz".$ovclean/e; 2741 $one = $1; 2742 isnt_tainted($s, "$desc: s not tainted"); 2743 isnt_tainted($res, "$desc: res not tainted"); 2744 isnt_tainted($one, "$desc: \$1 not tainted"); 2745 is($s, 'xyzhello', "$desc: s value"); 2746 is($res, 1, "$desc: res value"); 2747 is($one, 'abcd', "$desc: \$1 value"); 2748 2749 $desc = "substitution /e with extra code and partial replacement overloaded and tainted"; 2750 $s = 'abcd'; 2751 $res = $s =~ s/(.+)/(my $z++), "xyz".$ovtaint/e; 2752 $one = $1; 2753 is_tainted($s, "$desc: s tainted"); 2754 isnt_tainted($res, "$desc: res not tainted"); 2755 isnt_tainted($one, "$desc: \$1 not tainted"); 2756 is($s, 'xyzhi', "$desc: s value"); 2757 is($res, 1, "$desc: res value"); 2758 is($one, 'abcd', "$desc: \$1 value"); 2759 2760 $desc = "substitution /e with extra code and whole replacement overloaded and clean"; 2761 $s = 'abcd'; 2762 $res = $s =~ s/(.+)/(my $z++), $ovclean/e; 2763 $one = $1; 2764 isnt_tainted($s, "$desc: s not tainted"); 2765 isnt_tainted($res, "$desc: res not tainted"); 2766 isnt_tainted($one, "$desc: \$1 not tainted"); 2767 is($s, 'hello', "$desc: s value"); 2768 is($res, 1, "$desc: res value"); 2769 is($one, 'abcd', "$desc: \$1 value"); 2770 2771 $desc = "substitution /e with extra code and whole replacement overloaded and tainted"; 2772 $s = 'abcd'; 2773 $res = $s =~ s/(.+)/(my $z++), $ovtaint/e; 2774 $one = $1; 2775 is_tainted($s, "$desc: s tainted"); 2776 isnt_tainted($res, "$desc: res not tainted"); 2777 isnt_tainted($one, "$desc: \$1 not tainted"); 2778 is($s, 'hi', "$desc: s value"); 2779 is($res, 1, "$desc: res value"); 2780 is($one, 'abcd', "$desc: \$1 value"); 2781 2782 $desc = "substitution /r with partial replacement overloaded and clean"; 2783 $s = 'abcd'; 2784 $res = $s =~ s/(.+)/xyz$ovclean/r; 2785 $one = $1; 2786 isnt_tainted($s, "$desc: s not tainted"); 2787 isnt_tainted($res, "$desc: res not tainted"); 2788 isnt_tainted($one, "$desc: \$1 not tainted"); 2789 is($s, 'abcd', "$desc: s value"); 2790 is($res, 'xyzhello', "$desc: res value"); 2791 is($one, 'abcd', "$desc: \$1 value"); 2792 2793 $desc = "substitution /r with partial replacement overloaded and tainted"; 2794 $s = 'abcd'; 2795 $res = $s =~ s/(.+)/xyz$ovtaint/r; 2796 $one = $1; 2797 isnt_tainted($s, "$desc: s not tainted"); 2798 is_tainted($res, "$desc: res tainted"); 2799 isnt_tainted($one, "$desc: \$1 not tainted"); 2800 is($s, 'abcd', "$desc: s value"); 2801 is($res, 'xyzhi', "$desc: res value"); 2802 is($one, 'abcd', "$desc: \$1 value"); 2803 2804 $desc = "substitution /r with whole replacement overloaded and clean"; 2805 $s = 'abcd'; 2806 $res = $s =~ s/(.+)/$ovclean/r; 2807 $one = $1; 2808 isnt_tainted($s, "$desc: s not tainted"); 2809 isnt_tainted($res, "$desc: res not tainted"); 2810 isnt_tainted($one, "$desc: \$1 not tainted"); 2811 is($s, 'abcd', "$desc: s value"); 2812 is($res, 'hello', "$desc: res value"); 2813 is($one, 'abcd', "$desc: \$1 value"); 2814 2815 $desc = "substitution /r with whole replacement overloaded and tainted"; 2816 $s = 'abcd'; 2817 $res = $s =~ s/(.+)/$ovtaint/r; 2818 $one = $1; 2819 isnt_tainted($s, "$desc: s not tainted"); 2820 is_tainted($res, "$desc: res tainted"); 2821 isnt_tainted($one, "$desc: \$1 not tainted"); 2822 is($s, 'abcd', "$desc: s value"); 2823 is($res, 'hi', "$desc: res value"); 2824 is($one, 'abcd', "$desc: \$1 value"); 2825 2826 $desc = "substitution /g with partial replacement overloaded and clean"; 2827 $s = 'abcd'; 2828 $res = $s =~ s/(.)/x$ovclean/g; 2829 $one = $1; 2830 isnt_tainted($s, "$desc: s not tainted"); 2831 isnt_tainted($res, "$desc: res not tainted"); 2832 isnt_tainted($one, "$desc: \$1 not tainted"); 2833 is($s, 'xhello' x 4, "$desc: s value"); 2834 is($res, 4, "$desc: res value"); 2835 is($one, 'd', "$desc: \$1 value"); 2836 2837 $desc = "substitution /g with partial replacement overloaded and tainted"; 2838 $s = 'abcd'; 2839 $res = $s =~ s/(.)/x$ovtaint/g; 2840 $one = $1; 2841 is_tainted($s, "$desc: s tainted"); 2842 isnt_tainted($res, "$desc: res not tainted"); 2843 isnt_tainted($one, "$desc: \$1 not tainted"); 2844 is($s, 'xhi' x 4, "$desc: s value"); 2845 is($res, 4, "$desc: res value"); 2846 is($one, 'd', "$desc: \$1 value"); 2847 2848 $desc = "substitution /g with whole replacement overloaded and clean"; 2849 $s = 'abcd'; 2850 $res = $s =~ s/(.)/$ovclean/g; 2851 $one = $1; 2852 isnt_tainted($s, "$desc: s not tainted"); 2853 isnt_tainted($res, "$desc: res not tainted"); 2854 isnt_tainted($one, "$desc: \$1 not tainted"); 2855 is($s, 'hello' x 4, "$desc: s value"); 2856 is($res, 4, "$desc: res value"); 2857 is($one, 'd', "$desc: \$1 value"); 2858 2859 $desc = "substitution /g with whole replacement overloaded and tainted"; 2860 $s = 'abcd'; 2861 $res = $s =~ s/(.)/$ovtaint/g; 2862 $one = $1; 2863 is_tainted($s, "$desc: s tainted"); 2864 isnt_tainted($res, "$desc: res not tainted"); 2865 isnt_tainted($one, "$desc: \$1 not tainted"); 2866 is($s, 'hi' x 4, "$desc: s value"); 2867 is($res, 4, "$desc: res value"); 2868 is($one, 'd', "$desc: \$1 value"); 2869 2870 $desc = "substitution /ge with partial replacement overloaded and clean"; 2871 $s = 'abcd'; 2872 $res = $s =~ s/(.)/"x".$ovclean/ge; 2873 $one = $1; 2874 isnt_tainted($s, "$desc: s not tainted"); 2875 isnt_tainted($res, "$desc: res not tainted"); 2876 isnt_tainted($one, "$desc: \$1 not tainted"); 2877 is($s, 'xhello' x 4, "$desc: s value"); 2878 is($res, 4, "$desc: res value"); 2879 is($one, 'd', "$desc: \$1 value"); 2880 2881 $desc = "substitution /ge with partial replacement overloaded and tainted"; 2882 $s = 'abcd'; 2883 $res = $s =~ s/(.)/"x".$ovtaint/ge; 2884 $one = $1; 2885 is_tainted($s, "$desc: s tainted"); 2886 isnt_tainted($res, "$desc: res not tainted"); 2887 isnt_tainted($one, "$desc: \$1 not tainted"); 2888 is($s, 'xhi' x 4, "$desc: s value"); 2889 is($res, 4, "$desc: res value"); 2890 is($one, 'd', "$desc: \$1 value"); 2891 2892 $desc = "substitution /ge with whole replacement overloaded and clean"; 2893 $s = 'abcd'; 2894 $res = $s =~ s/(.)/$ovclean/ge; 2895 $one = $1; 2896 isnt_tainted($s, "$desc: s not tainted"); 2897 isnt_tainted($res, "$desc: res not tainted"); 2898 isnt_tainted($one, "$desc: \$1 not tainted"); 2899 is($s, 'hello' x 4, "$desc: s value"); 2900 is($res, 4, "$desc: res value"); 2901 is($one, 'd', "$desc: \$1 value"); 2902 2903 $desc = "substitution /ge with whole replacement overloaded and tainted"; 2904 $s = 'abcd'; 2905 $res = $s =~ s/(.)/$ovtaint/ge; 2906 $one = $1; 2907 is_tainted($s, "$desc: s tainted"); 2908 isnt_tainted($res, "$desc: res not tainted"); 2909 isnt_tainted($one, "$desc: \$1 not tainted"); 2910 is($s, 'hi' x 4, "$desc: s value"); 2911 is($res, 4, "$desc: res value"); 2912 is($one, 'd', "$desc: \$1 value"); 2913} 2914 2915# RT #132385 2916# It was trying to taint a boolean return from s/// (e.g. PL_sv_yes) 2917# and was thus crashing with 'Modification of a read-only value'. 2918 2919{ 2920 my $s = "abcd" . $TAINT; 2921 ok(!!($s =~ s/a/x/g), "RT #132385"); 2922} 2923 2924# RT #134409 2925# When the last substitution added both taint and utf8, adding taint 2926# magic to the result also triggered a byte-to-utf8 recalulation of the 2927# existing pos() magic, which had not yet been reset, resulting in a panic 2928# about pos() being off the end of the string. 2929{ 2930 my $utf8_taint = substr($^X,0,0); 2931 utf8::upgrade($utf8_taint); 2932 2933 my %map = ( 2934 'UTF8' => "$utf8_taint", 2935 'PLAIN' => '', 2936 ); 2937 2938 2939 my $v = "PLAIN UTF8"; 2940 my $c = eval { $v =~ s/(\w+)/$map{$1}/g; }; 2941 is($c, 2, "RT #134409") 2942 or diag("\$@ = [$@]"); 2943} 2944 2945{ 2946 # check that each param is independent taint-wise. 2947 use feature 'signatures'; 2948 use experimental 'signatures'; 2949 2950 sub taint_sig1($a, $b, $c) { 2951 isnt_tainted($a, 'taint_sig1: $a'); 2952 is_tainted ($b, 'taint_sig1: $b'); 2953 isnt_tainted($c, 'taint_sig1: $c'); 2954 } 2955 taint_sig1(1, $TAINT, 3); 2956 2957 sub taint_sig2($a, $b = $TAINT, $c = 3) { 2958 isnt_tainted($a, 'taint_sig2: $a'); 2959 is_tainted ($b, 'taint_sig2: $b'); 2960 isnt_tainted($c, 'taint_sig2: $c'); 2961 } 2962 taint_sig2(1); 2963 2964 sub taint_sig3($a, $b = 2, $c = $TAINT) { 2965 is_tainted ($a, 'taint_sig3: $a'); 2966 isnt_tainted($b, 'taint_sig3: $b'); 2967 is_tainted ($c, 'taint_sig3: $c'); 2968 } 2969 taint_sig3($TAINT); 2970} 2971 2972{ 2973 # GH 19478: panic on s///gre with tainted utf8 strings 2974 my $u = "\x{10469}"; 2975 my $r1 = ("foo$TAINT" =~ s/./"$u"/gre); 2976 is($r1, "$u$u$u", 'tainted string with utf8 s/.//gre'); 2977 my $r2 = ("foo$TAINT" =~ s/.*/"${u}"/gre); 2978 is($r2, "$u$u", 'tainted string with utf8 s/.*//gre'); 2979 my $r3 = ("foo$TAINT" =~ s/.+/"${u}"/gre); 2980 is($r3, $u, 'tainted string with utf8 s/.+//gre'); 2981 my $r4 = ("$u$TAINT" =~ s/./""/gre); 2982 is($r4, '', 'tainted utf8 string with s///gre'); 2983} 2984 2985# This may bomb out with the alarm signal so keep it last 2986SKIP: { 2987 skip "No alarm()" unless $Config{d_alarm}; 2988 # Test from RT #41831] 2989 # [PATCH] Bug & fix: hang when using study + taint mode (perl 5.6.1, 5.8.x) 2990 2991 my $DATA = <<'END' . $TAINT; 2992line1 is here 2993line2 is here 2994line3 is here 2995line4 is here 2996 2997END 2998 2999 #study $DATA; 3000 3001 ## don't set $SIG{ALRM}, since we'd never get to a user-level handler as 3002 ## perl is stuck in a regexp infinite loop! 3003 3004 alarm(10); 3005 3006 if ($DATA =~ /^line2.*line4/m) { 3007 fail("Should not be a match") 3008 } else { 3009 pass("Match on tainted multiline data should fail promptly"); 3010 } 3011 3012 alarm(0); 3013} 3014__END__ 3015# Keep the previous test last 3016