1# 2# t/test.pl - most of Test::More functionality without the fuss 3 4 5# NOTE: 6# 7# Do not rely on features found only in more modern Perls here, as some CPAN 8# distributions copy this file and must operate on older Perls. Similarly, keep 9# things, simple as this may be run under fairly broken circumstances. For 10# example, increment ($x++) has a certain amount of cleverness for things like 11# 12# $x = 'zz'; 13# $x++; # $x eq 'aaa'; 14# 15# This stands more chance of breaking than just a simple 16# 17# $x = $x + 1 18# 19# In this file, we use the latter "Baby Perl" approach, and increment 20# will be worked over by t/op/inc.t 21 22$| = 1; 23our $Level = 1; 24my $test = 1; 25my $planned; 26my $noplan; 27my $Perl; # Safer version of $^X set by which_perl() 28 29# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC 30$::IS_ASCII = ord 'A' == 65; 31$::IS_EBCDIC = ord 'A' == 193; 32 33# This is 'our' to enable harness to account for TODO-ed tests in 34# overall grade of PASS or FAIL 35our $TODO = 0; 36our $NO_ENDING = 0; 37our $Tests_Are_Passing = 1; 38 39# Use this instead of print to avoid interference while testing globals. 40sub _print { 41 local($\, $", $,) = (undef, ' ', ''); 42 print STDOUT @_; 43} 44 45sub _print_stderr { 46 local($\, $", $,) = (undef, ' ', ''); 47 print STDERR @_; 48} 49 50sub plan { 51 my $n; 52 if (@_ == 1) { 53 $n = shift; 54 if ($n eq 'no_plan') { 55 undef $n; 56 $noplan = 1; 57 } 58 } else { 59 my %plan = @_; 60 $plan{skip_all} and skip_all($plan{skip_all}); 61 $n = $plan{tests}; 62 } 63 _print "1..$n\n" unless $noplan; 64 $planned = $n; 65} 66 67 68# Set the plan at the end. See Test::More::done_testing. 69sub done_testing { 70 my $n = $test - 1; 71 $n = shift if @_; 72 73 _print "1..$n\n"; 74 $planned = $n; 75} 76 77 78END { 79 my $ran = $test - 1; 80 if (!$NO_ENDING) { 81 if (defined $planned && $planned != $ran) { 82 _print_stderr 83 "# Looks like you planned $planned tests but ran $ran.\n"; 84 } elsif ($noplan) { 85 _print "1..$ran\n"; 86 } 87 } 88} 89 90sub _diag { 91 return unless @_; 92 my @mess = _comment(@_); 93 $TODO ? _print(@mess) : _print_stderr(@mess); 94} 95 96# Use this instead of "print STDERR" when outputting failure diagnostic 97# messages 98sub diag { 99 _diag(@_); 100} 101 102# Use this instead of "print" when outputting informational messages 103sub note { 104 return unless @_; 105 _print( _comment(@_) ); 106} 107 108sub is_miniperl { 109 return !defined &DynaLoader::boot_DynaLoader; 110} 111 112sub set_up_inc { 113 # Don’t clobber @INC under miniperl 114 @INC = () unless is_miniperl; 115 unshift @INC, @_; 116} 117 118sub _comment { 119 return map { /^#/ ? "$_\n" : "# $_\n" } 120 map { split /\n/ } @_; 121} 122 123sub _have_dynamic_extension { 124 my $extension = shift; 125 unless (eval {require Config; 1}) { 126 warn "test.pl had problems loading Config: $@"; 127 return 1; 128 } 129 $extension =~ s!::!/!g; 130 return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); 131} 132 133sub skip_all { 134 if (@_) { 135 _print "1..0 # Skip @_\n"; 136 } else { 137 _print "1..0\n"; 138 } 139 exit(0); 140} 141 142sub skip_all_if_miniperl { 143 skip_all(@_) if is_miniperl(); 144} 145 146sub skip_all_without_dynamic_extension { 147 my ($extension) = @_; 148 skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); 149 return if &_have_dynamic_extension; 150 skip_all("$extension was not built"); 151} 152 153sub skip_all_without_perlio { 154 skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); 155} 156 157sub skip_all_without_config { 158 unless (eval {require Config; 1}) { 159 warn "test.pl had problems loading Config: $@"; 160 return; 161 } 162 foreach (@_) { 163 next if $Config::Config{$_}; 164 my $key = $_; # Need to copy, before trying to modify. 165 $key =~ s/^use//; 166 $key =~ s/^d_//; 167 skip_all("no $key"); 168 } 169} 170 171sub skip_all_without_unicode_tables { # (but only under miniperl) 172 if (is_miniperl()) { 173 skip_all_if_miniperl("Unicode tables not built yet") 174 unless eval 'require "unicore/UCD.pl"'; 175 } 176} 177 178sub find_git_or_skip { 179 my ($source_dir, $reason); 180 181 if ( $ENV{CONTINUOUS_INTEGRATION} && $ENV{WORKSPACE} ) { 182 $source_dir = $ENV{WORKSPACE}; 183 if ( -d "${source_dir}/.git" ) { 184 $ENV{GIT_DIR} = "${source_dir}/.git"; 185 return $source_dir; 186 } 187 } 188 189 if (-d '.git') { 190 $source_dir = '.'; 191 } elsif (-l 'MANIFEST' && -l 'AUTHORS') { 192 my $where = readlink 'MANIFEST'; 193 die "Can't readling MANIFEST: $!" unless defined $where; 194 die "Confusing symlink target for MANIFEST, '$where'" 195 unless $where =~ s!/MANIFEST\z!!; 196 if (-d "$where/.git") { 197 # Looks like we are in a symlink tree 198 if (exists $ENV{GIT_DIR}) { 199 diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); 200 } else { 201 note("Found source tree at $where, setting \$ENV{GIT_DIR}"); 202 $ENV{GIT_DIR} = "$where/.git"; 203 } 204 $source_dir = $where; 205 } 206 } elsif (exists $ENV{GIT_DIR}) { 207 my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; 208 my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; 209 chomp $out; 210 if($out eq $commit) { 211 $source_dir = '.' 212 } 213 } 214 if ($ENV{'PERL_BUILD_PACKAGING'}) { 215 $reason = 'PERL_BUILD_PACKAGING is set'; 216 } elsif ($source_dir) { 217 my $version_string = `git --version`; 218 if (defined $version_string 219 && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { 220 return $source_dir if eval "v$1 ge v1.5.0"; 221 # If you have earlier than 1.5.0 and it works, change this test 222 $reason = "in git checkout, but git version '$1$2' too old"; 223 } else { 224 $reason = "in git checkout, but cannot run git"; 225 } 226 } else { 227 $reason = 'not being run from a git checkout'; 228 } 229 skip_all($reason) if $_[0] && $_[0] eq 'all'; 230 skip($reason, @_); 231} 232 233sub BAIL_OUT { 234 my ($reason) = @_; 235 _print("Bail out! $reason\n"); 236 exit 255; 237} 238 239sub _ok { 240 my ($pass, $where, $name, @mess) = @_; 241 # Do not try to microoptimize by factoring out the "not ". 242 # VMS will avenge. 243 my $out; 244 if ($name) { 245 # escape out '#' or it will interfere with '# skip' and such 246 $name =~ s/#/\\#/g; 247 $out = $pass ? "ok $test - $name" : "not ok $test - $name"; 248 } else { 249 $out = $pass ? "ok $test" : "not ok $test"; 250 } 251 252 if ($TODO) { 253 $out = $out . " # TODO $TODO"; 254 } else { 255 $Tests_Are_Passing = 0 unless $pass; 256 } 257 258 _print "$out\n"; 259 260 if ($pass) { 261 note @mess; # Ensure that the message is properly escaped. 262 } 263 else { 264 my $msg = "# Failed test $test - "; 265 $msg.= "$name " if $name; 266 $msg .= "$where\n"; 267 _diag $msg; 268 _diag @mess; 269 } 270 271 $test = $test + 1; # don't use ++ 272 273 return $pass; 274} 275 276sub _where { 277 my @caller = caller($Level); 278 return "at $caller[1] line $caller[2]"; 279} 280 281# DON'T use this for matches. Use like() instead. 282sub ok ($@) { 283 my ($pass, $name, @mess) = @_; 284 _ok($pass, _where(), $name, @mess); 285} 286 287sub _q { 288 my $x = shift; 289 return 'undef' unless defined $x; 290 my $q = $x; 291 $q =~ s/\\/\\\\/g; 292 $q =~ s/'/\\'/g; 293 return "'$q'"; 294} 295 296sub _qq { 297 my $x = shift; 298 return defined $x ? '"' . display ($x) . '"' : 'undef'; 299}; 300 301# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file. 302# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!"). 303my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*"; 304eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }' 305 if !defined &re::is_regexp; 306 307# keys are the codes \n etc map to, values are 2 char strings such as \n 308my %backslash_escape; 309foreach my $x (split //, 'enrtfa\\\'"') { 310 $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; 311} 312# A way to display scalars containing control characters and Unicode. 313# Trying to avoid setting $_, or relying on local $_ to work. 314sub display { 315 my @result; 316 foreach my $x (@_) { 317 if (defined $x and not ref $x) { 318 my $y = ''; 319 foreach my $c (unpack($chars_template, $x)) { 320 if ($c > 255) { 321 $y = $y . sprintf "\\x{%x}", $c; 322 } elsif ($backslash_escape{$c}) { 323 $y = $y . $backslash_escape{$c}; 324 } elsif ($c < ord " ") { 325 # Use octal for characters with small ordinals that are 326 # traditionally expressed as octal: the controls below 327 # space, which on EBCDIC are almost all the controls, but 328 # on ASCII don't include DEL nor the C1 controls. 329 $y = $y . sprintf "\\%03o", $c; 330 } elsif (chr $c =~ /[[:print:]]/a) { 331 $y = $y . chr $c; 332 } 333 else { 334 $y = $y . sprintf "\\x%02X", $c; 335 } 336 } 337 $x = $y; 338 } 339 return $x unless wantarray; 340 push @result, $x; 341 } 342 return @result; 343} 344 345sub is ($$@) { 346 my ($got, $expected, $name, @mess) = @_; 347 348 my $pass; 349 if( !defined $got || !defined $expected ) { 350 # undef only matches undef 351 $pass = !defined $got && !defined $expected; 352 } 353 else { 354 $pass = $got eq $expected; 355 } 356 357 unless ($pass) { 358 unshift(@mess, "# got "._qq($got)."\n", 359 "# expected "._qq($expected)."\n"); 360 } 361 _ok($pass, _where(), $name, @mess); 362} 363 364sub isnt ($$@) { 365 my ($got, $isnt, $name, @mess) = @_; 366 367 my $pass; 368 if( !defined $got || !defined $isnt ) { 369 # undef only matches undef 370 $pass = defined $got || defined $isnt; 371 } 372 else { 373 $pass = $got ne $isnt; 374 } 375 376 unless( $pass ) { 377 unshift(@mess, "# it should not be "._qq($got)."\n", 378 "# but it is.\n"); 379 } 380 _ok($pass, _where(), $name, @mess); 381} 382 383sub cmp_ok ($$$@) { 384 my($got, $type, $expected, $name, @mess) = @_; 385 386 my $pass; 387 { 388 local $^W = 0; 389 local($@,$!); # don't interfere with $@ 390 # eval() sometimes resets $! 391 $pass = eval "\$got $type \$expected"; 392 } 393 unless ($pass) { 394 # It seems Irix long doubles can have 2147483648 and 2147483648 395 # that stringify to the same thing but are actually numerically 396 # different. Display the numbers if $type isn't a string operator, 397 # and the numbers are stringwise the same. 398 # (all string operators have alphabetic names, so tr/a-z// is true) 399 # This will also show numbers for some unneeded cases, but will 400 # definitely be helpful for things such as == and <= that fail 401 if ($got eq $expected and $type !~ tr/a-z//) { 402 unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; 403 } 404 unshift(@mess, "# got "._qq($got)."\n", 405 "# expected $type "._qq($expected)."\n"); 406 } 407 _ok($pass, _where(), $name, @mess); 408} 409 410# Check that $got is within $range of $expected 411# if $range is 0, then check it's exact 412# else if $expected is 0, then $range is an absolute value 413# otherwise $range is a fractional error. 414# Here $range must be numeric, >= 0 415# Non numeric ranges might be a useful future extension. (eg %) 416sub within ($$$@) { 417 my ($got, $expected, $range, $name, @mess) = @_; 418 my $pass; 419 if (!defined $got or !defined $expected or !defined $range) { 420 # This is a fail, but doesn't need extra diagnostics 421 } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { 422 # This is a fail 423 unshift @mess, "# got, expected and range must be numeric\n"; 424 } elsif ($range < 0) { 425 # This is also a fail 426 unshift @mess, "# range must not be negative\n"; 427 } elsif ($range == 0) { 428 # Within 0 is == 429 $pass = $got == $expected; 430 } elsif ($expected == 0) { 431 # If expected is 0, treat range as absolute 432 $pass = ($got <= $range) && ($got >= - $range); 433 } else { 434 my $diff = $got - $expected; 435 $pass = abs ($diff / $expected) < $range; 436 } 437 unless ($pass) { 438 if ($got eq $expected) { 439 unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; 440 } 441 unshift@mess, "# got "._qq($got)."\n", 442 "# expected "._qq($expected)." (within "._qq($range).")\n"; 443 } 444 _ok($pass, _where(), $name, @mess); 445} 446 447# Note: this isn't quite as fancy as Test::More::like(). 448 449sub like ($$@) { like_yn (0,@_) }; # 0 for - 450sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- 451 452sub like_yn ($$$@) { 453 my ($flip, undef, $expected, $name, @mess) = @_; 454 455 # We just accept like(..., qr/.../), not like(..., '...'), and 456 # definitely not like(..., '/.../') like 457 # Test::Builder::maybe_regex() does. 458 unless (re::is_regexp($expected)) { 459 die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string"; 460 } 461 462 my $pass; 463 $pass = $_[1] =~ /$expected/ if !$flip; 464 $pass = $_[1] !~ /$expected/ if $flip; 465 my $display_got = $_[1]; 466 $display_got = display($display_got); 467 my $display_expected = $expected; 468 $display_expected = display($display_expected); 469 unless ($pass) { 470 unshift(@mess, "# got '$display_got'\n", 471 $flip 472 ? "# expected !~ /$display_expected/\n" 473 : "# expected /$display_expected/\n"); 474 } 475 local $Level = $Level + 1; 476 _ok($pass, _where(), $name, @mess); 477} 478 479sub pass { 480 _ok(1, '', @_); 481} 482 483sub fail { 484 _ok(0, _where(), @_); 485} 486 487sub curr_test { 488 $test = shift if @_; 489 return $test; 490} 491 492sub next_test { 493 my $retval = $test; 494 $test = $test + 1; # don't use ++ 495 $retval; 496} 497 498# Note: can't pass multipart messages since we try to 499# be compatible with Test::More::skip(). 500sub skip { 501 my $why = shift; 502 my $n = @_ ? shift : 1; 503 my $bad_swap; 504 my $both_zero; 505 { 506 local $^W = 0; 507 $bad_swap = $why > 0 && $n == 0; 508 $both_zero = $why == 0 && $n == 0; 509 } 510 if ($bad_swap || $both_zero || @_) { 511 my $arg = "'$why', '$n'"; 512 if (@_) { 513 $arg .= join(", ", '', map { qq['$_'] } @_); 514 } 515 die qq[$0: expected skip(why, count), got skip($arg)\n]; 516 } 517 for (1..$n) { 518 _print "ok $test # skip $why\n"; 519 $test = $test + 1; 520 } 521 local $^W = 0; 522 last SKIP; 523} 524 525sub skip_if_miniperl { 526 skip(@_) if is_miniperl(); 527} 528 529sub skip_without_dynamic_extension { 530 my $extension = shift; 531 skip("no dynamic loading on miniperl, no extension $extension", @_) 532 if is_miniperl(); 533 return if &_have_dynamic_extension($extension); 534 skip("extension $extension was not built", @_); 535} 536 537sub todo_skip { 538 my $why = shift; 539 my $n = @_ ? shift : 1; 540 541 for (1..$n) { 542 _print "not ok $test # TODO & SKIP $why\n"; 543 $test = $test + 1; 544 } 545 local $^W = 0; 546 last TODO; 547} 548 549sub eq_array { 550 my ($ra, $rb) = @_; 551 return 0 unless $#$ra == $#$rb; 552 for my $i (0..$#$ra) { 553 next if !defined $ra->[$i] && !defined $rb->[$i]; 554 return 0 if !defined $ra->[$i]; 555 return 0 if !defined $rb->[$i]; 556 return 0 unless $ra->[$i] eq $rb->[$i]; 557 } 558 return 1; 559} 560 561sub eq_hash { 562 my ($orig, $suspect) = @_; 563 my $fail; 564 while (my ($key, $value) = each %$suspect) { 565 # Force a hash recompute if this perl's internals can cache the hash key. 566 $key = "" . $key; 567 if (exists $orig->{$key}) { 568 if ( 569 defined $orig->{$key} != defined $value 570 || (defined $value && $orig->{$key} ne $value) 571 ) { 572 _print "# key ", _qq($key), " was ", _qq($orig->{$key}), 573 " now ", _qq($value), "\n"; 574 $fail = 1; 575 } 576 } else { 577 _print "# key ", _qq($key), " is ", _qq($value), 578 ", not in original.\n"; 579 $fail = 1; 580 } 581 } 582 foreach (keys %$orig) { 583 # Force a hash recompute if this perl's internals can cache the hash key. 584 $_ = "" . $_; 585 next if (exists $suspect->{$_}); 586 _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; 587 $fail = 1; 588 } 589 !$fail; 590} 591 592# We only provide a subset of the Test::More functionality. 593sub require_ok ($) { 594 my ($require) = @_; 595 if ($require =~ tr/[A-Za-z0-9:.]//c) { 596 fail("Invalid character in \"$require\", passed to require_ok"); 597 } else { 598 eval <<REQUIRE_OK; 599require $require; 600REQUIRE_OK 601 is($@, '', _where(), "require $require"); 602 } 603} 604 605sub use_ok ($) { 606 my ($use) = @_; 607 if ($use =~ tr/[A-Za-z0-9:.]//c) { 608 fail("Invalid character in \"$use\", passed to use"); 609 } else { 610 eval <<USE_OK; 611use $use; 612USE_OK 613 is($@, '', _where(), "use $use"); 614 } 615} 616 617# runperl, run_perl - Runs a separate perl interpreter and returns its output. 618# Arguments : 619# switches => [ command-line switches ] 620# nolib => 1 # don't use -I../lib (included by default) 621# non_portable => Don't warn if a one liner contains quotes 622# prog => one-liner (avoid quotes) 623# progs => [ multi-liner (avoid quotes) ] 624# progfile => perl script 625# stdin => string to feed the stdin (or undef to redirect from /dev/null) 626# stderr => If 'devnull' suppresses stderr, if other TRUE value redirect 627# stderr to stdout 628# args => [ command-line arguments to the perl program ] 629# verbose => print the command line 630 631my $is_mswin = $^O eq 'MSWin32'; 632my $is_netware = $^O eq 'NetWare'; 633my $is_vms = $^O eq 'VMS'; 634my $is_cygwin = $^O eq 'cygwin'; 635 636sub _quote_args { 637 my ($runperl, $args) = @_; 638 639 foreach (@$args) { 640 # In VMS protect with doublequotes because otherwise 641 # DCL will lowercase -- unless already doublequoted. 642 $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; 643 $runperl = $runperl . ' ' . $_; 644 } 645 return $runperl; 646} 647 648sub _create_runperl { # Create the string to qx in runperl(). 649 my %args = @_; 650 my $runperl = which_perl(); 651 if ($runperl =~ m/\s/) { 652 $runperl = qq{"$runperl"}; 653 } 654 #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind 655 if ($ENV{PERL_RUNPERL_DEBUG}) { 656 $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; 657 } 658 unless ($args{nolib}) { 659 $runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS 660 } 661 if ($args{switches}) { 662 local $Level = 2; 663 die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() 664 unless ref $args{switches} eq "ARRAY"; 665 $runperl = _quote_args($runperl, $args{switches}); 666 } 667 if (defined $args{prog}) { 668 die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() 669 if defined $args{progs}; 670 $args{progs} = [split /\n/, $args{prog}, -1] 671 } 672 if (defined $args{progs}) { 673 die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() 674 unless ref $args{progs} eq "ARRAY"; 675 foreach my $prog (@{$args{progs}}) { 676 if (!$args{non_portable}) { 677 if ($prog =~ tr/'"//) { 678 warn "quotes in prog >>$prog<< are not portable"; 679 } 680 if ($prog =~ /^([<>|]|2>)/) { 681 warn "Initial $1 in prog >>$prog<< is not portable"; 682 } 683 if ($prog =~ /&\z/) { 684 warn "Trailing & in prog >>$prog<< is not portable"; 685 } 686 } 687 if ($is_mswin || $is_netware || $is_vms) { 688 $runperl = $runperl . qq ( -e "$prog" ); 689 } 690 else { 691 $runperl = $runperl . qq ( -e '$prog' ); 692 } 693 } 694 } elsif (defined $args{progfile}) { 695 $runperl = $runperl . qq( "$args{progfile}"); 696 } else { 697 # You probably didn't want to be sucking in from the upstream stdin 698 die "test.pl:runperl(): none of prog, progs, progfile, args, " 699 . " switches or stdin specified" 700 unless defined $args{args} or defined $args{switches} 701 or defined $args{stdin}; 702 } 703 if (defined $args{stdin}) { 704 # so we don't try to put literal newlines and crs onto the 705 # command line. 706 $args{stdin} =~ s/\n/\\n/g; 707 $args{stdin} =~ s/\r/\\r/g; 708 709 if ($is_mswin || $is_netware || $is_vms) { 710 $runperl = qq{$Perl -e "print qq(} . 711 $args{stdin} . q{)" | } . $runperl; 712 } 713 else { 714 $runperl = qq{$Perl -e 'print qq(} . 715 $args{stdin} . q{)' | } . $runperl; 716 } 717 } elsif (exists $args{stdin}) { 718 # Using the pipe construction above can cause fun on systems which use 719 # ksh as /bin/sh, as ksh does pipes differently (with one less process) 720 # With sh, for the command line 'perl -e 'print qq()' | perl -e ...' 721 # the sh process forks two children, which use exec to start the two 722 # perl processes. The parent shell process persists for the duration of 723 # the pipeline, and the second perl process starts with no children. 724 # With ksh (and zsh), the shell saves a process by forking a child for 725 # just the first perl process, and execing itself to start the second. 726 # This means that the second perl process starts with one child which 727 # it didn't create. This causes "fun" when if the tests assume that 728 # wait (or waitpid) will only return information about processes 729 # started within the test. 730 # They also cause fun on VMS, where the pipe implementation returns 731 # the exit code of the process at the front of the pipeline, not the 732 # end. This messes up any test using OPTION FATAL. 733 # Hence it's useful to have a way to make STDIN be at eof without 734 # needing a pipeline, so that the fork tests have a sane environment 735 # without these surprises. 736 737 # /dev/null appears to be surprisingly portable. 738 $runperl = $runperl . ($is_mswin ? ' <nul' : ' </dev/null'); 739 } 740 if (defined $args{args}) { 741 $runperl = _quote_args($runperl, $args{args}); 742 } 743 if (exists $args{stderr} && $args{stderr} eq 'devnull') { 744 $runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null'); 745 } 746 elsif ($args{stderr}) { 747 $runperl = $runperl . ' 2>&1'; 748 } 749 if ($args{verbose}) { 750 my $runperldisplay = $runperl; 751 $runperldisplay =~ s/\n/\n\#/g; 752 _print_stderr "# $runperldisplay\n"; 753 } 754 return $runperl; 755} 756 757# usage: 758# $ENV{PATH} =~ /(.*)/s; 759# local $ENV{PATH} = untaint_path($1); 760sub untaint_path { 761 my $path = shift; 762 my $sep; 763 764 if (! eval {require Config; 1}) { 765 warn "test.pl had problems loading Config: $@"; 766 $sep = ':'; 767 } else { 768 $sep = $Config::Config{path_sep}; 769 } 770 771 $path = 772 join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and 773 ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } 774 split quotemeta ($sep), $1; 775 if ($is_cygwin) { # Must have /bin under Cygwin 776 if (length $path) { 777 $path = $path . $sep; 778 } 779 $path = $path . '/bin'; 780 } 781 782 $path; 783} 784 785# sub run_perl {} is alias to below 786# Since this uses backticks to run, it is subject to the rules of the shell. 787# Locale settings may pose a problem, depending on the program being run. 788sub runperl { 789 die "test.pl:runperl() does not take a hashref" 790 if ref $_[0] and ref $_[0] eq 'HASH'; 791 my $runperl = &_create_runperl; 792 my $result; 793 794 my $tainted = ${^TAINT}; 795 my %args = @_; 796 exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; 797 798 if ($tainted) { 799 # We will assume that if you're running under -T, you really mean to 800 # run a fresh perl, so we'll brute force launder everything for you 801 my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); 802 local @ENV{@keys} = (); 803 # Untaint, plus take out . and empty string: 804 local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); 805 $ENV{PATH} =~ /(.*)/s; 806 local $ENV{PATH} = untaint_path($1); 807 $runperl =~ /(.*)/s; 808 $runperl = $1; 809 810 $result = `$runperl`; 811 } else { 812 $result = `$runperl`; 813 } 814 $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these 815 return $result; 816} 817 818# Nice alias 819*run_perl = *run_perl = \&runperl; # shut up "used only once" warning 820 821sub DIE { 822 _print_stderr "# @_\n"; 823 exit 1; 824} 825 826# A somewhat safer version of the sometimes wrong $^X. 827sub which_perl { 828 unless (defined $Perl) { 829 $Perl = $^X; 830 831 # VMS should have 'perl' aliased properly 832 return $Perl if $is_vms; 833 834 my $exe; 835 if (! eval {require Config; 1}) { 836 warn "test.pl had problems loading Config: $@"; 837 $exe = ''; 838 } else { 839 $exe = $Config::Config{_exe}; 840 } 841 $exe = '' unless defined $exe; 842 843 # This doesn't absolutize the path: beware of future chdirs(). 844 # We could do File::Spec->abs2rel() but that does getcwd()s, 845 # which is a bit heavyweight to do here. 846 847 if ($Perl =~ /^perl\Q$exe\E$/i) { 848 my $perl = "perl$exe"; 849 if (! eval {require File::Spec; 1}) { 850 warn "test.pl had problems loading File::Spec: $@"; 851 $Perl = "./$perl"; 852 } else { 853 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); 854 } 855 } 856 857 # Build up the name of the executable file from the name of 858 # the command. 859 860 if ($Perl !~ /\Q$exe\E$/i) { 861 $Perl = $Perl . $exe; 862 } 863 864 warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; 865 866 # For subcommands to use. 867 $ENV{PERLEXE} = $Perl; 868 } 869 return $Perl; 870} 871 872sub unlink_all { 873 my $count = 0; 874 foreach my $file (@_) { 875 1 while unlink $file; 876 if( -f $file ){ 877 _print_stderr "# Couldn't unlink '$file': $!\n"; 878 }else{ 879 $count = $count + 1; # don't use ++ 880 } 881 } 882 $count; 883} 884 885# _num_to_alpha - Returns a string of letters representing a positive integer. 886# Arguments : 887# number to convert 888# maximum number of letters 889 890# returns undef if the number is negative 891# returns undef if the number of letters is greater than the maximum wanted 892 893# _num_to_alpha( 0) eq 'A'; 894# _num_to_alpha( 1) eq 'B'; 895# _num_to_alpha(25) eq 'Z'; 896# _num_to_alpha(26) eq 'AA'; 897# _num_to_alpha(27) eq 'AB'; 898 899my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); 900 901# Avoid ++ -- ranges split negative numbers 902sub _num_to_alpha{ 903 my($num,$max_char) = @_; 904 return unless $num >= 0; 905 my $alpha = ''; 906 my $char_count = 0; 907 $max_char = 0 if $max_char < 0; 908 909 while( 1 ){ 910 $alpha = $letters[ $num % 26 ] . $alpha; 911 $num = int( $num / 26 ); 912 last if $num == 0; 913 $num = $num - 1; 914 915 # char limit 916 next unless $max_char; 917 $char_count = $char_count + 1; 918 return if $char_count == $max_char; 919 } 920 return $alpha; 921} 922 923my %tmpfiles; 924END { unlink_all keys %tmpfiles } 925 926# A regexp that matches the tempfile names 927$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; 928 929# Avoid ++, avoid ranges, avoid split // 930my $tempfile_count = 0; 931sub tempfile { 932 while(1){ 933 my $try = (-d "t" ? "t/" : "")."tmp$$"; 934 my $alpha = _num_to_alpha($tempfile_count,2); 935 last unless defined $alpha; 936 $try = $try . $alpha; 937 $tempfile_count = $tempfile_count + 1; 938 939 # Need to note all the file names we allocated, as a second request may 940 # come before the first is created. 941 if (!$tmpfiles{$try} && !-e $try) { 942 # We have a winner 943 $tmpfiles{$try} = 1; 944 return $try; 945 } 946 } 947 die "Can't find temporary file name starting \"tmp$$\""; 948} 949 950# register_tempfile - Adds a list of files to be removed at the end of the current test file 951# Arguments : 952# a list of files to be removed later 953 954# returns a count of how many file names were actually added 955 956# Reuses %tmpfiles so that tempfile() will also skip any files added here 957# even if the file doesn't exist yet. 958 959sub register_tempfile { 960 my $count = 0; 961 for( @_ ){ 962 if( $tmpfiles{$_} ){ 963 _print_stderr "# Temporary file '$_' already added\n"; 964 }else{ 965 $tmpfiles{$_} = 1; 966 $count = $count + 1; 967 } 968 } 969 return $count; 970} 971 972# This is the temporary file for fresh_perl 973my $tmpfile = tempfile(); 974 975sub fresh_perl { 976 my($prog, $runperl_args) = @_; 977 978 # Run 'runperl' with the complete perl program contained in '$prog', and 979 # arguments in the hash referred to by '$runperl_args'. The results are 980 # returned, with $? set to the exit code. Unless overridden, stderr is 981 # redirected to stdout. 982 # 983 # Placing the program in a file bypasses various sh vagaries 984 985 die sprintf "Second argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})" 986 unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH'; 987 988 # Given the choice of the mis-parsable {} 989 # (we want an anon hash, but a borked lexer might think that it's a block) 990 # or relying on taking a reference to a lexical 991 # (\ might be mis-parsed, and the reference counting on the pad may go 992 # awry) 993 # it feels like the least-worse thing is to assume that auto-vivification 994 # works. At least, this is only going to be a run-time failure, so won't 995 # affect tests using this file but not this function. 996 $runperl_args->{progfile} ||= $tmpfile; 997 $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; 998 999 open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!"; 1000 binmode TEST, ':utf8' if $runperl_args->{wide_chars}; 1001 print TEST $prog; 1002 close TEST or die "Cannot close $tmpfile: $!"; 1003 1004 my $results = runperl(%$runperl_args); 1005 my $status = $?; # Not necessary to save this, but it makes it clear to 1006 # future maintainers. 1007 1008 # Clean up the results into something a bit more predictable. 1009 $results =~ s/\n+$//; 1010 $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; 1011 $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; 1012 1013 # bison says 'parse error' instead of 'syntax error', 1014 # various yaccs may or may not capitalize 'syntax'. 1015 $results =~ s/^(syntax|parse) error/syntax error/mig; 1016 1017 if ($is_vms) { 1018 # some tests will trigger VMS messages that won't be expected 1019 $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; 1020 1021 # pipes double these sometimes 1022 $results =~ s/\n\n/\n/g; 1023 } 1024 1025 $? = $status; 1026 return $results; 1027} 1028 1029 1030sub _fresh_perl { 1031 my($prog, $action, $expect, $runperl_args, $name) = @_; 1032 1033 my $results = fresh_perl($prog, $runperl_args); 1034 my $status = $?; 1035 1036 # Use the first line of the program as a name if none was given 1037 unless( $name ) { 1038 (my $first_line, $name) = $prog =~ /^((.{1,50}).*)/; 1039 $name = $name . '...' if length $first_line > length $name; 1040 } 1041 1042 # Historically this was implemented using a closure, but then that means 1043 # that the tests for closures avoid using this code. Given that there 1044 # are exactly two callers, doing exactly two things, the simpler approach 1045 # feels like a better trade off. 1046 my $pass; 1047 if ($action eq 'eq') { 1048 $pass = is($results, $expect, $name); 1049 } elsif ($action eq '=~') { 1050 $pass = like($results, $expect, $name); 1051 } else { 1052 die "_fresh_perl can't process action '$action'"; 1053 } 1054 1055 unless ($pass) { 1056 _diag "# PROG: \n$prog\n"; 1057 _diag "# STATUS: $status\n"; 1058 } 1059 1060 return $pass; 1061} 1062 1063# 1064# fresh_perl_is 1065# 1066# Combination of run_perl() and is(). 1067# 1068 1069sub fresh_perl_is { 1070 my($prog, $expected, $runperl_args, $name) = @_; 1071 1072 # _fresh_perl() is going to clip the trailing newlines off the result. 1073 # This will make it so the test author doesn't have to know that. 1074 $expected =~ s/\n+$//; 1075 1076 local $Level = 2; 1077 _fresh_perl($prog, 'eq', $expected, $runperl_args, $name); 1078} 1079 1080# 1081# fresh_perl_like 1082# 1083# Combination of run_perl() and like(). 1084# 1085 1086sub fresh_perl_like { 1087 my($prog, $expected, $runperl_args, $name) = @_; 1088 local $Level = 2; 1089 _fresh_perl($prog, '=~', $expected, $runperl_args, $name); 1090} 1091 1092# Many tests use the same format in __DATA__ or external files to specify a 1093# sequence of (fresh) tests to run, extra files they may temporarily need, and 1094# what the expected output is. Putting it here allows common code to serve 1095# these multiple tests. 1096# 1097# Each program is source code to run followed by an "EXPECT" line, followed 1098# by the expected output. 1099# 1100# The first line of the code to run may be a command line switch such as -wE 1101# or -0777 (alphanumerics only; only one cluster, beginning with a minus is 1102# allowed). Later lines may contain (note the '# ' on each): 1103# # TODO reason for todo 1104# # SKIP reason for skip 1105# # SKIP ?code to test if this should be skipped 1106# # NAME name of the test (as with ok($ok, $name)) 1107# 1108# The expected output may contain: 1109# OPTION list of options 1110# OPTIONS list of options 1111# 1112# The possible options for OPTION may be: 1113# regex - the expected output is a regular expression 1114# random - all lines match but in any order 1115# fatal - the code will fail fatally (croak, die) 1116# nonfatal - the code is not expected to fail fatally 1117# 1118# If the actual output contains a line "SKIPPED" the test will be 1119# skipped. 1120# 1121# If the actual output contains a line "PREFIX", any output starting with that 1122# line will be ignored when comparing with the expected output 1123# 1124# If the global variable $FATAL is true then OPTION fatal is the 1125# default. 1126 1127our $FATAL; 1128sub _setup_one_file { 1129 my $fh = shift; 1130 # Store the filename as a program that started at line 0. 1131 # Real files count lines starting at line 1. 1132 my @these = (0, shift); 1133 my ($lineno, $current); 1134 while (<$fh>) { 1135 if ($_ eq "########\n") { 1136 if (defined $current) { 1137 push @these, $lineno, $current; 1138 } 1139 undef $current; 1140 } else { 1141 if (!defined $current) { 1142 $lineno = $.; 1143 } 1144 $current .= $_; 1145 } 1146 } 1147 if (defined $current) { 1148 push @these, $lineno, $current; 1149 } 1150 ((scalar @these) / 2 - 1, @these); 1151} 1152 1153sub setup_multiple_progs { 1154 my ($tests, @prgs); 1155 foreach my $file (@_) { 1156 next if $file =~ /(?:~|\.orig|,v)$/; 1157 next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); 1158 next if -d $file; 1159 1160 open my $fh, '<', $file or die "Cannot open $file: $!\n" ; 1161 my $found; 1162 while (<$fh>) { 1163 if (/^__END__/) { 1164 $found = $found + 1; # don't use ++ 1165 last; 1166 } 1167 } 1168 # This is an internal error, and should never happen. All bar one of 1169 # the files had an __END__ marker to signal the end of their preamble, 1170 # although for some it wasn't technically necessary as they have no 1171 # tests. It might be possible to process files without an __END__ by 1172 # seeking back to the start and treating the whole file as tests, but 1173 # it's simpler and more reliable just to make the rule that all files 1174 # must have __END__ in. This should never fail - a file without an 1175 # __END__ should not have been checked in, because the regression tests 1176 # would not have passed. 1177 die "Could not find '__END__' in $file" 1178 unless $found; 1179 1180 my ($t, @p) = _setup_one_file($fh, $file); 1181 $tests += $t; 1182 push @prgs, @p; 1183 1184 close $fh 1185 or die "Cannot close $file: $!\n"; 1186 } 1187 return ($tests, @prgs); 1188} 1189 1190sub run_multiple_progs { 1191 my $up = shift; 1192 my @prgs; 1193 if ($up) { 1194 # The tests in lib run in a temporary subdirectory of t, and always 1195 # pass in a list of "programs" to run 1196 @prgs = @_; 1197 } else { 1198 # The tests below t run in t and pass in a file handle. In theory we 1199 # can pass (caller)[1] as the second argument to report errors with 1200 # the filename of our caller, as the handle is always DATA. However, 1201 # line numbers in DATA count from the __END__ token, so will be wrong. 1202 # Which is more confusing than not providing line numbers. So, for now, 1203 # don't provide line numbers. No obvious clean solution - one hack 1204 # would be to seek DATA back to the start and read to the __END__ token, 1205 # but that feels almost like we should just open $0 instead. 1206 1207 # Not going to rely on undef in list assignment. 1208 my $dummy; 1209 ($dummy, @prgs) = _setup_one_file(shift); 1210 } 1211 1212 my $tmpfile = tempfile(); 1213 1214 my $count_failures = 0; 1215 my ($file, $line); 1216 PROGRAM: 1217 while (defined ($line = shift @prgs)) { 1218 $_ = shift @prgs; 1219 unless ($line) { 1220 $file = $_; 1221 if (defined $file) { 1222 print "# From $file\n"; 1223 } 1224 next; 1225 } 1226 my $switch = ""; 1227 my @temps ; 1228 my @temp_path; 1229 if (s/^(\s*-\w+)//) { 1230 $switch = $1; 1231 } 1232 my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); 1233 1234 my %reason; 1235 foreach my $what (qw(skip todo)) { 1236 $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; 1237 # If the SKIP reason starts ? then it's taken as a code snippet to 1238 # evaluate. This provides the flexibility to have conditional SKIPs 1239 if ($reason{$what} && $reason{$what} =~ s/^\?//) { 1240 my $temp = eval $reason{$what}; 1241 if ($@) { 1242 die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; 1243 } 1244 $reason{$what} = $temp; 1245 } 1246 } 1247 1248 my $name = ''; 1249 if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { 1250 $name = $1; 1251 } elsif (defined $file) { 1252 $name = "test from $file at line $line"; 1253 } 1254 1255 if ($reason{skip}) { 1256 SKIP: 1257 { 1258 skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); 1259 } 1260 next PROGRAM; 1261 } 1262 1263 if ($prog =~ /--FILE--/) { 1264 my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; 1265 shift @files ; 1266 die "Internal error: test $_ didn't split into pairs, got " . 1267 scalar(@files) . "[" . join("%%%%", @files) ."]\n" 1268 if @files % 2; 1269 while (@files > 2) { 1270 my $filename = shift @files; 1271 my $code = shift @files; 1272 push @temps, $filename; 1273 if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { 1274 require File::Path; 1275 File::Path::mkpath($1); 1276 push(@temp_path, $1); 1277 } 1278 open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; 1279 print $fh $code; 1280 close $fh or die "Cannot close $filename: $!\n"; 1281 } 1282 shift @files; 1283 $prog = shift @files; 1284 } 1285 1286 open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; 1287 print $fh q{ 1288 BEGIN { 1289 push @INC, '.'; 1290 open STDERR, '>&', STDOUT 1291 or die "Can't dup STDOUT->STDERR: $!;"; 1292 } 1293 }; 1294 print $fh "\n#line 1\n"; # So the line numbers don't get messed up. 1295 print $fh $prog,"\n"; 1296 close $fh or die "Cannot close $tmpfile: $!"; 1297 my $results = runperl( stderr => 1, progfile => $tmpfile, 1298 stdin => undef, $up 1299 ? (switches => ["-I$up/lib", $switch], nolib => 1) 1300 : (switches => [$switch]) 1301 ); 1302 my $status = $?; 1303 $results =~ s/\n+$//; 1304 # allow expected output to be written as if $prog is on STDIN 1305 $results =~ s/$::tempfile_regexp/-/g; 1306 if ($^O eq 'VMS') { 1307 # some tests will trigger VMS messages that won't be expected 1308 $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; 1309 1310 # pipes double these sometimes 1311 $results =~ s/\n\n/\n/g; 1312 } 1313 # bison says 'parse error' instead of 'syntax error', 1314 # various yaccs may or may not capitalize 'syntax'. 1315 $results =~ s/^(syntax|parse) error/syntax error/mig; 1316 # allow all tests to run when there are leaks 1317 $results =~ s/Scalars leaked: \d+\n//g; 1318 1319 $expected =~ s/\n+$//; 1320 my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; 1321 # any special options? (OPTIONS foo bar zap) 1322 my $option_regex = 0; 1323 my $option_random = 0; 1324 my $fatal = $FATAL; 1325 if ($expected =~ s/^OPTIONS? (.+)(?:\n|\Z)//) { 1326 foreach my $option (split(' ', $1)) { 1327 if ($option eq 'regex') { # allow regular expressions 1328 $option_regex = 1; 1329 } 1330 elsif ($option eq 'random') { # all lines match, but in any order 1331 $option_random = 1; 1332 } 1333 elsif ($option eq 'fatal') { # perl should fail 1334 $fatal = 1; 1335 } 1336 elsif ($option eq 'nonfatal') { 1337 # used to turn off default fatal 1338 $fatal = 0; 1339 } 1340 else { 1341 die "$0: Unknown OPTION '$option'\n"; 1342 } 1343 } 1344 } 1345 die "$0: can't have OPTION regex and random\n" 1346 if $option_regex + $option_random > 1; 1347 my $ok = 0; 1348 if ($results =~ s/^SKIPPED\n//) { 1349 print "$results\n" ; 1350 $ok = 1; 1351 } 1352 else { 1353 if ($option_random) { 1354 my @got = sort split "\n", $results; 1355 my @expected = sort split "\n", $expected; 1356 1357 $ok = "@got" eq "@expected"; 1358 } 1359 elsif ($option_regex) { 1360 $ok = $results =~ /^$expected/; 1361 } 1362 elsif ($prefix) { 1363 $ok = $results =~ /^\Q$expected/; 1364 } 1365 else { 1366 $ok = $results eq $expected; 1367 } 1368 1369 if ($ok && $fatal && !($status >> 8)) { 1370 $ok = 0; 1371 } 1372 } 1373 1374 local $::TODO = $reason{todo}; 1375 1376 unless ($ok) { 1377 my $err_line = ''; 1378 $err_line .= "FILE: $file ; line $line\n" if defined $file; 1379 $err_line .= "PROG: $switch\n$prog\n" . 1380 "EXPECTED:\n$expected\n"; 1381 $err_line .= "EXIT STATUS: != 0\n" if $fatal; 1382 $err_line .= "GOT:\n$results\n"; 1383 $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; 1384 if ($::TODO) { 1385 $err_line =~ s/^/# /mg; 1386 print $err_line; # Harness can't filter it out from STDERR. 1387 } 1388 else { 1389 print STDERR $err_line; 1390 ++$count_failures; 1391 die "PERL_TEST_ABORT_FIRST_FAILURE set Test Failure" 1392 if $ENV{PERL_TEST_ABORT_FIRST_FAILURE}; 1393 } 1394 } 1395 1396 if (defined $file) { 1397 _ok($ok, "at $file line $line", $name); 1398 } else { 1399 # We don't have file and line number data for the test, so report 1400 # errors as coming from our caller. 1401 local $Level = $Level + 1; 1402 ok($ok, $name); 1403 } 1404 1405 foreach (@temps) { 1406 unlink $_ if $_; 1407 } 1408 foreach (@temp_path) { 1409 File::Path::rmtree $_ if -d $_; 1410 } 1411 } 1412 1413 if ( $count_failures ) { 1414 print STDERR <<'EOS'; 1415# 1416# Note: 'run_multiple_progs' run has one or more failures 1417# you can consider setting the environment variable 1418# PERL_TEST_ABORT_FIRST_FAILURE=1 before running the test 1419# to stop on the first error. 1420# 1421EOS 1422 } 1423 1424 1425 return; 1426} 1427 1428sub can_ok ($@) { 1429 my($proto, @methods) = @_; 1430 my $class = ref $proto || $proto; 1431 1432 unless( @methods ) { 1433 return _ok( 0, _where(), "$class->can(...)" ); 1434 } 1435 1436 my @nok = (); 1437 foreach my $method (@methods) { 1438 local($!, $@); # don't interfere with caller's $@ 1439 # eval sometimes resets $! 1440 eval { $proto->can($method) } || push @nok, $method; 1441 } 1442 1443 my $name; 1444 $name = @methods == 1 ? "$class->can('$methods[0]')" 1445 : "$class->can(...)"; 1446 1447 _ok( !@nok, _where(), $name ); 1448} 1449 1450 1451# Call $class->new( @$args ); and run the result through object_ok. 1452# See Test::More::new_ok 1453sub new_ok { 1454 my($class, $args, $obj_name) = @_; 1455 $args ||= []; 1456 $obj_name = "The object" unless defined $obj_name; 1457 1458 local $Level = $Level + 1; 1459 1460 my $obj; 1461 my $ok = eval { $obj = $class->new(@$args); 1 }; 1462 my $error = $@; 1463 1464 if($ok) { 1465 object_ok($obj, $class, $obj_name); 1466 } 1467 else { 1468 ok( 0, "new() died" ); 1469 diag("Error was: $@"); 1470 } 1471 1472 return $obj; 1473 1474} 1475 1476 1477sub isa_ok ($$;$) { 1478 my($object, $class, $obj_name) = @_; 1479 1480 my $diag; 1481 $obj_name = 'The object' unless defined $obj_name; 1482 my $name = "$obj_name isa $class"; 1483 if( !defined $object ) { 1484 $diag = "$obj_name isn't defined"; 1485 } 1486 else { 1487 my $whatami = ref $object ? 'object' : 'class'; 1488 1489 # We can't use UNIVERSAL::isa because we want to honor isa() overrides 1490 local($@, $!); # eval sometimes resets $! 1491 my $rslt = eval { $object->isa($class) }; 1492 my $error = $@; # in case something else blows away $@ 1493 1494 if( $error ) { 1495 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { 1496 # It's an unblessed reference 1497 $obj_name = 'The reference' unless defined $obj_name; 1498 if( !UNIVERSAL::isa($object, $class) ) { 1499 my $ref = ref $object; 1500 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 1501 } 1502 } 1503 elsif( $error =~ /Can't call method "isa" without a package/ ) { 1504 # It's something that can't even be a class 1505 $obj_name = 'The thing' unless defined $obj_name; 1506 $diag = "$obj_name isn't a class or reference"; 1507 } 1508 else { 1509 die <<WHOA; 1510WHOA! I tried to call ->isa on your object and got some weird error. 1511This should never happen. Please contact the author immediately. 1512Here's the error. 1513$@ 1514WHOA 1515 } 1516 } 1517 elsif( !$rslt ) { 1518 $obj_name = "The $whatami" unless defined $obj_name; 1519 my $ref = ref $object; 1520 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 1521 } 1522 } 1523 1524 _ok( !$diag, _where(), $name ); 1525} 1526 1527 1528sub class_ok { 1529 my($class, $isa, $class_name) = @_; 1530 1531 # Written so as to count as one test 1532 local $Level = $Level + 1; 1533 if( ref $class ) { 1534 ok( 0, "$class is a reference, not a class name" ); 1535 } 1536 else { 1537 isa_ok($class, $isa, $class_name); 1538 } 1539} 1540 1541 1542sub object_ok { 1543 my($obj, $isa, $obj_name) = @_; 1544 1545 local $Level = $Level + 1; 1546 if( !ref $obj ) { 1547 ok( 0, "$obj is not a reference" ); 1548 } 1549 else { 1550 isa_ok($obj, $isa, $obj_name); 1551 } 1552} 1553 1554 1555# Purposefully avoiding a closure. 1556sub __capture { 1557 push @::__capture, join "", @_; 1558} 1559 1560sub capture_warnings { 1561 my $code = shift; 1562 1563 local @::__capture; 1564 local $SIG {__WARN__} = \&__capture; 1565 local $Level = 1; 1566 &$code; 1567 return @::__capture; 1568} 1569 1570# This will generate a variable number of tests. 1571# Use done_testing() instead of a fixed plan. 1572sub warnings_like { 1573 my ($code, $expect, $name) = @_; 1574 local $Level = $Level + 1; 1575 1576 my @w = capture_warnings($code); 1577 1578 cmp_ok(scalar @w, '==', scalar @$expect, $name); 1579 foreach my $e (@$expect) { 1580 if (ref $e) { 1581 like(shift @w, $e, $name); 1582 } else { 1583 is(shift @w, $e, $name); 1584 } 1585 } 1586 if (@w) { 1587 diag("Saw these additional warnings:"); 1588 diag($_) foreach @w; 1589 } 1590} 1591 1592sub _fail_excess_warnings { 1593 my($expect, $got, $name) = @_; 1594 local $Level = $Level + 1; 1595 # This will fail, and produce diagnostics 1596 is($expect, scalar @$got, $name); 1597 diag("Saw these warnings:"); 1598 diag($_) foreach @$got; 1599} 1600 1601sub warning_is { 1602 my ($code, $expect, $name) = @_; 1603 die sprintf "Expect must be a string or undef, not a %s reference", ref $expect 1604 if ref $expect; 1605 local $Level = $Level + 1; 1606 my @w = capture_warnings($code); 1607 if (@w > 1) { 1608 _fail_excess_warnings(0 + defined $expect, \@w, $name); 1609 } else { 1610 is($w[0], $expect, $name); 1611 } 1612} 1613 1614sub warning_like { 1615 my ($code, $expect, $name) = @_; 1616 die sprintf "Expect must be a regexp object" 1617 unless ref $expect eq 'Regexp'; 1618 local $Level = $Level + 1; 1619 my @w = capture_warnings($code); 1620 if (@w > 1) { 1621 _fail_excess_warnings(0 + defined $expect, \@w, $name); 1622 } else { 1623 like($w[0], $expect, $name); 1624 } 1625} 1626 1627# Set a watchdog to timeout the entire test file 1628# NOTE: If the test file uses 'threads', then call the watchdog() function 1629# _AFTER_ the 'threads' module is loaded. 1630sub watchdog ($;$) 1631{ 1632 my $timeout = shift; 1633 my $method = shift || ""; 1634 my $timeout_msg = 'Test process timed out - terminating'; 1635 1636 # Valgrind slows perl way down so give it more time before dying. 1637 $timeout *= 10 if $ENV{PERL_VALGRIND}; 1638 1639 my $pid_to_kill = $$; # PID for this process 1640 1641 if ($method eq "alarm") { 1642 goto WATCHDOG_VIA_ALARM; 1643 } 1644 1645 # shut up use only once warning 1646 my $threads_on = $threads::threads && $threads::threads; 1647 1648 # Don't use a watchdog process if 'threads' is loaded - 1649 # use a watchdog thread instead 1650 if (!$threads_on || $method eq "process") { 1651 1652 # On Windows and VMS, try launching a watchdog process 1653 # using system(1, ...) (see perlport.pod) 1654 if ($is_mswin || $is_vms) { 1655 # On Windows, try to get the 'real' PID 1656 if ($is_mswin) { 1657 eval { require Win32; }; 1658 if (defined(&Win32::GetCurrentProcessId)) { 1659 $pid_to_kill = Win32::GetCurrentProcessId(); 1660 } 1661 } 1662 1663 # If we still have a fake PID, we can't use this method at all 1664 return if ($pid_to_kill <= 0); 1665 1666 # Launch watchdog process 1667 my $watchdog; 1668 eval { 1669 local $SIG{'__WARN__'} = sub { 1670 _diag("Watchdog warning: $_[0]"); 1671 }; 1672 my $sig = $is_vms ? 'TERM' : 'KILL'; 1673 my $prog = "sleep($timeout);" . 1674 "warn qq/# $timeout_msg" . '\n/;' . 1675 "kill(q/$sig/, $pid_to_kill);"; 1676 1677 # If we're in taint mode PATH will be tainted 1678 $ENV{PATH} =~ /(.*)/s; 1679 local $ENV{PATH} = untaint_path($1); 1680 1681 # On Windows use the indirect object plus LIST form to guarantee 1682 # that perl is launched directly rather than via the shell (see 1683 # perlfunc.pod), and ensure that the LIST has multiple elements 1684 # since the indirect object plus COMMANDSTRING form seems to 1685 # hang (see perl #121283). Don't do this on VMS, which doesn't 1686 # support the LIST form at all. 1687 if ($is_mswin) { 1688 my $runperl = which_perl(); 1689 $runperl =~ /(.*)/; 1690 $runperl = $1; 1691 if ($runperl =~ m/\s/) { 1692 $runperl = qq{"$runperl"}; 1693 } 1694 $watchdog = system({ $runperl } 1, $runperl, '-e', $prog); 1695 } 1696 else { 1697 my $cmd = _create_runperl(prog => $prog); 1698 $watchdog = system(1, $cmd); 1699 } 1700 }; 1701 if ($@ || ($watchdog <= 0)) { 1702 _diag('Failed to start watchdog'); 1703 _diag($@) if $@; 1704 undef($watchdog); 1705 return; 1706 } 1707 1708 # Add END block to parent to terminate and 1709 # clean up watchdog process 1710 eval("END { local \$! = 0; local \$? = 0; 1711 wait() if kill('KILL', $watchdog); };"); 1712 return; 1713 } 1714 1715 # Try using fork() to generate a watchdog process 1716 my $watchdog; 1717 eval { $watchdog = fork() }; 1718 if (defined($watchdog)) { 1719 if ($watchdog) { # Parent process 1720 # Add END block to parent to terminate and 1721 # clean up watchdog process 1722 eval "END { local \$! = 0; local \$? = 0; 1723 wait() if kill('KILL', $watchdog); };"; 1724 return; 1725 } 1726 1727 ### Watchdog process code 1728 1729 # Load POSIX if available 1730 eval { require POSIX; }; 1731 1732 # Execute the timeout 1733 sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 1734 sleep(2); 1735 1736 # Kill test process if still running 1737 if (kill(0, $pid_to_kill)) { 1738 _diag($timeout_msg); 1739 kill('KILL', $pid_to_kill); 1740 if ($is_cygwin) { 1741 # sometimes the above isn't enough on cygwin 1742 sleep 1; # wait a little, it might have worked after all 1743 system("/bin/kill -f $pid_to_kill") if kill(0, $pid_to_kill); 1744 } 1745 } 1746 1747 # Don't execute END block (added at beginning of this file) 1748 $NO_ENDING = 1; 1749 1750 # Terminate ourself (i.e., the watchdog) 1751 POSIX::_exit(1) if (defined(&POSIX::_exit)); 1752 exit(1); 1753 } 1754 1755 # fork() failed - fall through and try using a thread 1756 } 1757 1758 # Use a watchdog thread because either 'threads' is loaded, 1759 # or fork() failed 1760 if (eval {require threads; 1}) { 1761 'threads'->create(sub { 1762 # Load POSIX if available 1763 eval { require POSIX; }; 1764 1765 # Execute the timeout 1766 my $time_left = $timeout; 1767 do { 1768 $time_left = $time_left - sleep($time_left); 1769 } while ($time_left > 0); 1770 1771 # Kill the parent (and ourself) 1772 select(STDERR); $| = 1; 1773 _diag($timeout_msg); 1774 POSIX::_exit(1) if (defined(&POSIX::_exit)); 1775 my $sig = $is_vms ? 'TERM' : 'KILL'; 1776 kill($sig, $pid_to_kill); 1777 })->detach(); 1778 return; 1779 } 1780 1781 # If everything above fails, then just use an alarm timeout 1782WATCHDOG_VIA_ALARM: 1783 if (eval { alarm($timeout); 1; }) { 1784 # Load POSIX if available 1785 eval { require POSIX; }; 1786 1787 # Alarm handler will do the actual 'killing' 1788 $SIG{'ALRM'} = sub { 1789 select(STDERR); $| = 1; 1790 _diag($timeout_msg); 1791 POSIX::_exit(1) if (defined(&POSIX::_exit)); 1792 my $sig = $is_vms ? 'TERM' : 'KILL'; 1793 kill($sig, $pid_to_kill); 1794 }; 1795 } 1796} 1797 1798# Orphaned Docker or Linux containers do not necessarily attach to PID 1. They might attach to 0 instead. 1799sub is_linux_container { 1800 1801 if ($^O eq 'linux' && open my $fh, '<', '/proc/1/cgroup') { 1802 while(<$fh>) { 1803 if (m{^\d+:pids:(.*)} && $1 ne '/init.scope') { 1804 return 1; 1805 } 1806 } 1807 } 1808 1809 return 0; 1810} 1811 18121; 1813