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