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