1# 2# t/test.pl - most of Test::More functionality without the fuss 3 4 5# NOTE: 6# 7# Increment ($x++) has a certain amount of cleverness for things like 8# 9# $x = 'zz'; 10# $x++; # $x eq 'aaa'; 11# 12# stands more chance of breaking than just a simple 13# 14# $x = $x + 1 15# 16# In this file, we use the latter "Baby Perl" approach, and increment 17# will be worked over by t/op/inc.t 18 19$Level = 1; 20my $test = 1; 21my $planned; 22my $noplan; 23my $Perl; # Safer version of $^X set by which_perl() 24 25$TODO = 0; 26$NO_ENDING = 0; 27 28# Use this instead of print to avoid interference while testing globals. 29sub _print { 30 local($\, $", $,) = (undef, ' ', ''); 31 print STDOUT @_; 32} 33 34sub _print_stderr { 35 local($\, $", $,) = (undef, ' ', ''); 36 print STDERR @_; 37} 38 39sub plan { 40 my $n; 41 if (@_ == 1) { 42 $n = shift; 43 if ($n eq 'no_plan') { 44 undef $n; 45 $noplan = 1; 46 } 47 } else { 48 my %plan = @_; 49 $n = $plan{tests}; 50 } 51 _print "1..$n\n" unless $noplan; 52 $planned = $n; 53} 54 55END { 56 my $ran = $test - 1; 57 if (!$NO_ENDING) { 58 if (defined $planned && $planned != $ran) { 59 _print_stderr 60 "# Looks like you planned $planned tests but ran $ran.\n"; 61 } elsif ($noplan) { 62 _print "1..$ran\n"; 63 } 64 } 65} 66 67# Use this instead of "print STDERR" when outputing failure diagnostic 68# messages 69sub _diag { 70 return unless @_; 71 my @mess = map { /^#/ ? "$_\n" : "# $_\n" } 72 map { split /\n/ } @_; 73 $TODO ? _print(@mess) : _print_stderr(@mess); 74} 75 76sub diag { 77 _diag(@_); 78} 79 80sub skip_all { 81 if (@_) { 82 _print "1..0 # Skip @_\n"; 83 } else { 84 _print "1..0\n"; 85 } 86 exit(0); 87} 88 89sub _ok { 90 my ($pass, $where, $name, @mess) = @_; 91 # Do not try to microoptimize by factoring out the "not ". 92 # VMS will avenge. 93 my $out; 94 if ($name) { 95 # escape out '#' or it will interfere with '# skip' and such 96 $name =~ s/#/\\#/g; 97 $out = $pass ? "ok $test - $name" : "not ok $test - $name"; 98 } else { 99 $out = $pass ? "ok $test" : "not ok $test"; 100 } 101 102 $out = $out . " # TODO $TODO" if $TODO; 103 _print "$out\n"; 104 105 unless ($pass) { 106 _diag "# Failed $where\n"; 107 } 108 109 # Ensure that the message is properly escaped. 110 _diag @mess; 111 112 $test = $test + 1; # don't use ++ 113 114 return $pass; 115} 116 117sub _where { 118 my @caller = caller($Level); 119 return "at $caller[1] line $caller[2]"; 120} 121 122# DON'T use this for matches. Use like() instead. 123sub ok ($@) { 124 my ($pass, $name, @mess) = @_; 125 _ok($pass, _where(), $name, @mess); 126} 127 128sub _q { 129 my $x = shift; 130 return 'undef' unless defined $x; 131 my $q = $x; 132 $q =~ s/\\/\\\\/g; 133 $q =~ s/'/\\'/g; 134 return "'$q'"; 135} 136 137sub _qq { 138 my $x = shift; 139 return defined $x ? '"' . display ($x) . '"' : 'undef'; 140}; 141 142# keys are the codes \n etc map to, values are 2 char strings such as \n 143my %backslash_escape; 144foreach my $x (split //, 'nrtfa\\\'"') { 145 $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; 146} 147# A way to display scalars containing control characters and Unicode. 148# Trying to avoid setting $_, or relying on local $_ to work. 149sub display { 150 my @result; 151 foreach my $x (@_) { 152 if (defined $x and not ref $x) { 153 my $y = ''; 154 foreach my $c (unpack("U*", $x)) { 155 if ($c > 255) { 156 $y = $y . sprintf "\\x{%x}", $c; 157 } elsif ($backslash_escape{$c}) { 158 $y = $y . $backslash_escape{$c}; 159 } else { 160 my $z = chr $c; # Maybe we can get away with a literal... 161 if ($z =~ /[[:^print:]]/) { 162 163 # Use octal for characters traditionally expressed as 164 # such: the low controls 165 if ($c <= 037) { 166 $z = sprintf "\\%03o", $c; 167 } else { 168 $z = sprintf "\\x{%x}", $c; 169 } 170 } 171 $y = $y . $z; 172 } 173 } 174 $x = $y; 175 } 176 return $x unless wantarray; 177 push @result, $x; 178 } 179 return @result; 180} 181 182sub is ($$@) { 183 my ($got, $expected, $name, @mess) = @_; 184 185 my $pass; 186 if( !defined $got || !defined $expected ) { 187 # undef only matches undef 188 $pass = !defined $got && !defined $expected; 189 } 190 else { 191 $pass = $got eq $expected; 192 } 193 194 unless ($pass) { 195 unshift(@mess, "# got "._qq($got)."\n", 196 "# expected "._qq($expected)."\n"); 197 } 198 _ok($pass, _where(), $name, @mess); 199} 200 201sub isnt ($$@) { 202 my ($got, $isnt, $name, @mess) = @_; 203 204 my $pass; 205 if( !defined $got || !defined $isnt ) { 206 # undef only matches undef 207 $pass = defined $got || defined $isnt; 208 } 209 else { 210 $pass = $got ne $isnt; 211 } 212 213 unless( $pass ) { 214 unshift(@mess, "# it should not be "._qq($got)."\n", 215 "# but it is.\n"); 216 } 217 _ok($pass, _where(), $name, @mess); 218} 219 220sub cmp_ok ($$$@) { 221 my($got, $type, $expected, $name, @mess) = @_; 222 223 my $pass; 224 { 225 local $^W = 0; 226 local($@,$!); # don't interfere with $@ 227 # eval() sometimes resets $! 228 $pass = eval "\$got $type \$expected"; 229 } 230 unless ($pass) { 231 # It seems Irix long doubles can have 2147483648 and 2147483648 232 # that stringify to the same thing but are acutally numerically 233 # different. Display the numbers if $type isn't a string operator, 234 # and the numbers are stringwise the same. 235 # (all string operators have alphabetic names, so tr/a-z// is true) 236 # This will also show numbers for some uneeded cases, but will 237 # definately be helpful for things such as == and <= that fail 238 if ($got eq $expected and $type !~ tr/a-z//) { 239 unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; 240 } 241 unshift(@mess, "# got "._qq($got)."\n", 242 "# expected $type "._qq($expected)."\n"); 243 } 244 _ok($pass, _where(), $name, @mess); 245} 246 247# Check that $got is within $range of $expected 248# if $range is 0, then check it's exact 249# else if $expected is 0, then $range is an absolute value 250# otherwise $range is a fractional error. 251# Here $range must be numeric, >= 0 252# Non numeric ranges might be a useful future extension. (eg %) 253sub within ($$$@) { 254 my ($got, $expected, $range, $name, @mess) = @_; 255 my $pass; 256 if (!defined $got or !defined $expected or !defined $range) { 257 # This is a fail, but doesn't need extra diagnostics 258 } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { 259 # This is a fail 260 unshift @mess, "# got, expected and range must be numeric\n"; 261 } elsif ($range < 0) { 262 # This is also a fail 263 unshift @mess, "# range must not be negative\n"; 264 } elsif ($range == 0) { 265 # Within 0 is == 266 $pass = $got == $expected; 267 } elsif ($expected == 0) { 268 # If expected is 0, treat range as absolute 269 $pass = ($got <= $range) && ($got >= - $range); 270 } else { 271 my $diff = $got - $expected; 272 $pass = abs ($diff / $expected) < $range; 273 } 274 unless ($pass) { 275 if ($got eq $expected) { 276 unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; 277 } 278 unshift@mess, "# got "._qq($got)."\n", 279 "# expected "._qq($expected)." (within "._qq($range).")\n"; 280 } 281 _ok($pass, _where(), $name, @mess); 282} 283 284# Note: this isn't quite as fancy as Test::More::like(). 285 286sub like ($$@) { like_yn (0,@_) }; # 0 for - 287sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- 288 289sub like_yn ($$$@) { 290 my ($flip, $got, $expected, $name, @mess) = @_; 291 my $pass; 292 $pass = $got =~ /$expected/ if !$flip; 293 $pass = $got !~ /$expected/ if $flip; 294 unless ($pass) { 295 unshift(@mess, "# got '$got'\n", 296 $flip 297 ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); 298 } 299 local $Level = $Level + 1; 300 _ok($pass, _where(), $name, @mess); 301} 302 303sub pass { 304 _ok(1, '', @_); 305} 306 307sub fail { 308 _ok(0, _where(), @_); 309} 310 311sub curr_test { 312 $test = shift if @_; 313 return $test; 314} 315 316sub next_test { 317 my $retval = $test; 318 $test = $test + 1; # don't use ++ 319 $retval; 320} 321 322# Note: can't pass multipart messages since we try to 323# be compatible with Test::More::skip(). 324sub skip { 325 my $why = shift; 326 my $n = @_ ? shift : 1; 327 for (1..$n) { 328 _print "ok $test # skip $why\n"; 329 $test = $test + 1; 330 } 331 local $^W = 0; 332 last SKIP; 333} 334 335sub todo_skip { 336 my $why = shift; 337 my $n = @_ ? shift : 1; 338 339 for (1..$n) { 340 _print "not ok $test # TODO & SKIP $why\n"; 341 $test = $test + 1; 342 } 343 local $^W = 0; 344 last TODO; 345} 346 347sub eq_array { 348 my ($ra, $rb) = @_; 349 return 0 unless $#$ra == $#$rb; 350 for my $i (0..$#$ra) { 351 next if !defined $ra->[$i] && !defined $rb->[$i]; 352 return 0 if !defined $ra->[$i]; 353 return 0 if !defined $rb->[$i]; 354 return 0 unless $ra->[$i] eq $rb->[$i]; 355 } 356 return 1; 357} 358 359sub eq_hash { 360 my ($orig, $suspect) = @_; 361 my $fail; 362 while (my ($key, $value) = each %$suspect) { 363 # Force a hash recompute if this perl's internals can cache the hash key. 364 $key = "" . $key; 365 if (exists $orig->{$key}) { 366 if ($orig->{$key} ne $value) { 367 _print "# key ", _qq($key), " was ", _qq($orig->{$key}), 368 " now ", _qq($value), "\n"; 369 $fail = 1; 370 } 371 } else { 372 _print "# key ", _qq($key), " is ", _qq($value), 373 ", not in original.\n"; 374 $fail = 1; 375 } 376 } 377 foreach (keys %$orig) { 378 # Force a hash recompute if this perl's internals can cache the hash key. 379 $_ = "" . $_; 380 next if (exists $suspect->{$_}); 381 _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; 382 $fail = 1; 383 } 384 !$fail; 385} 386 387sub require_ok ($) { 388 my ($require) = @_; 389 eval <<REQUIRE_OK; 390require $require; 391REQUIRE_OK 392 _ok(!$@, _where(), "require $require"); 393} 394 395sub use_ok ($) { 396 my ($use) = @_; 397 eval <<USE_OK; 398use $use; 399USE_OK 400 _ok(!$@, _where(), "use $use"); 401} 402 403# runperl - Runs a separate perl interpreter. 404# Arguments : 405# switches => [ command-line switches ] 406# nolib => 1 # don't use -I../lib (included by default) 407# prog => one-liner (avoid quotes) 408# progs => [ multi-liner (avoid quotes) ] 409# progfile => perl script 410# stdin => string to feed the stdin 411# stderr => redirect stderr to stdout 412# args => [ command-line arguments to the perl program ] 413# verbose => print the command line 414 415my $is_mswin = $^O eq 'MSWin32'; 416my $is_netware = $^O eq 'NetWare'; 417my $is_vms = $^O eq 'VMS'; 418my $is_cygwin = $^O eq 'cygwin'; 419 420sub _quote_args { 421 my ($runperl, $args) = @_; 422 423 foreach (@$args) { 424 # In VMS protect with doublequotes because otherwise 425 # DCL will lowercase -- unless already doublequoted. 426 $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; 427 $runperl = $runperl . ' ' . $_; 428 } 429 return $runperl; 430} 431 432sub _create_runperl { # Create the string to qx in runperl(). 433 my %args = @_; 434 my $runperl = which_perl(); 435 if ($runperl =~ m/\s/) { 436 $runperl = qq{"$runperl"}; 437 } 438 #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind 439 if ($ENV{PERL_RUNPERL_DEBUG}) { 440 $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; 441 } 442 unless ($args{nolib}) { 443 $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS 444 } 445 if ($args{switches}) { 446 local $Level = 2; 447 die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() 448 unless ref $args{switches} eq "ARRAY"; 449 $runperl = _quote_args($runperl, $args{switches}); 450 } 451 if (defined $args{prog}) { 452 die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() 453 if defined $args{progs}; 454 $args{progs} = [$args{prog}] 455 } 456 if (defined $args{progs}) { 457 die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() 458 unless ref $args{progs} eq "ARRAY"; 459 foreach my $prog (@{$args{progs}}) { 460 if ($is_mswin || $is_netware || $is_vms) { 461 $runperl = $runperl . qq ( -e "$prog" ); 462 } 463 else { 464 $runperl = $runperl . qq ( -e '$prog' ); 465 } 466 } 467 } elsif (defined $args{progfile}) { 468 $runperl = $runperl . qq( "$args{progfile}"); 469 } else { 470 # You probaby didn't want to be sucking in from the upstream stdin 471 die "test.pl:runperl(): none of prog, progs, progfile, args, " 472 . " switches or stdin specified" 473 unless defined $args{args} or defined $args{switches} 474 or defined $args{stdin}; 475 } 476 if (defined $args{stdin}) { 477 # so we don't try to put literal newlines and crs onto the 478 # command line. 479 $args{stdin} =~ s/\n/\\n/g; 480 $args{stdin} =~ s/\r/\\r/g; 481 482 if ($is_mswin || $is_netware || $is_vms) { 483 $runperl = qq{$Perl -e "print qq(} . 484 $args{stdin} . q{)" | } . $runperl; 485 } 486 else { 487 $runperl = qq{$Perl -e 'print qq(} . 488 $args{stdin} . q{)' | } . $runperl; 489 } 490 } 491 if (defined $args{args}) { 492 $runperl = _quote_args($runperl, $args{args}); 493 } 494 $runperl = $runperl . ' 2>&1' if $args{stderr}; 495 if ($args{verbose}) { 496 my $runperldisplay = $runperl; 497 $runperldisplay =~ s/\n/\n\#/g; 498 _print_stderr "# $runperldisplay\n"; 499 } 500 return $runperl; 501} 502 503sub runperl { 504 die "test.pl:runperl() does not take a hashref" 505 if ref $_[0] and ref $_[0] eq 'HASH'; 506 my $runperl = &_create_runperl; 507 my $result; 508 509 my $tainted = ${^TAINT}; 510 my %args = @_; 511 exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; 512 513 if ($tainted) { 514 # We will assume that if you're running under -T, you really mean to 515 # run a fresh perl, so we'll brute force launder everything for you 516 my $sep; 517 518 if (! eval 'require Config; 1') { 519 warn "test.pl had problems loading Config: $@"; 520 $sep = ':'; 521 } else { 522 $sep = $Config::Config{path_sep}; 523 } 524 525 my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); 526 local @ENV{@keys} = (); 527 # Untaint, plus take out . and empty string: 528 local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); 529 $ENV{PATH} =~ /(.*)/s; 530 local $ENV{PATH} = 531 join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and 532 ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } 533 split quotemeta ($sep), $1; 534 $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin 535 536 $runperl =~ /(.*)/s; 537 $runperl = $1; 538 539 $result = `$runperl`; 540 } else { 541 $result = `$runperl`; 542 } 543 $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these 544 return $result; 545} 546 547*run_perl = \&runperl; # Nice alias. 548 549sub DIE { 550 _print_stderr "# @_\n"; 551 exit 1; 552} 553 554# A somewhat safer version of the sometimes wrong $^X. 555sub which_perl { 556 unless (defined $Perl) { 557 $Perl = $^X; 558 559 # VMS should have 'perl' aliased properly 560 return $Perl if $^O eq 'VMS'; 561 562 my $exe; 563 if (! eval 'require Config; 1') { 564 warn "test.pl had problems loading Config: $@"; 565 $exe = ''; 566 } else { 567 $exe = $Config::Config{_exe}; 568 } 569 $exe = '' unless defined $exe; 570 571 # This doesn't absolutize the path: beware of future chdirs(). 572 # We could do File::Spec->abs2rel() but that does getcwd()s, 573 # which is a bit heavyweight to do here. 574 575 if ($Perl =~ /^perl\Q$exe\E$/i) { 576 my $perl = "perl$exe"; 577 if (! eval 'require File::Spec; 1') { 578 warn "test.pl had problems loading File::Spec: $@"; 579 $Perl = "./$perl"; 580 } else { 581 $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); 582 } 583 } 584 585 # Build up the name of the executable file from the name of 586 # the command. 587 588 if ($Perl !~ /\Q$exe\E$/i) { 589 $Perl = $Perl . $exe; 590 } 591 592 warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; 593 594 # For subcommands to use. 595 $ENV{PERLEXE} = $Perl; 596 } 597 return $Perl; 598} 599 600sub unlink_all { 601 foreach my $file (@_) { 602 1 while unlink $file; 603 _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; 604 } 605} 606 607my %tmpfiles; 608END { unlink_all keys %tmpfiles } 609 610# A regexp that matches the tempfile names 611$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; 612 613# Avoid ++, avoid ranges, avoid split // 614my @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); 615sub tempfile { 616 my $count = 0; 617 do { 618 my $temp = $count; 619 my $try = "tmp$$"; 620 do { 621 $try = $try . $letters[$temp % 26]; 622 $temp = int ($temp / 26); 623 } while $temp; 624 # Need to note all the file names we allocated, as a second request may 625 # come before the first is created. 626 if (!-e $try && !$tmpfiles{$try}) { 627 # We have a winner 628 $tmpfiles{$try} = 1; 629 return $try; 630 } 631 $count = $count + 1; 632 } while $count < 26 * 26; 633 die "Can't find temporary file name starting 'tmp$$'"; 634} 635 636# This is the temporary file for _fresh_perl 637my $tmpfile = tempfile(); 638 639# 640# _fresh_perl 641# 642# The $resolve must be a subref that tests the first argument 643# for success, or returns the definition of success (e.g. the 644# expected scalar) if given no arguments. 645# 646 647sub _fresh_perl { 648 my($prog, $resolve, $runperl_args, $name) = @_; 649 650 # Given the choice of the mis-parsable {} 651 # (we want an anon hash, but a borked lexer might think that it's a block) 652 # or relying on taking a reference to a lexical 653 # (\ might be mis-parsed, and the reference counting on the pad may go 654 # awry) 655 # it feels like the least-worse thing is to assume that auto-vivification 656 # works. At least, this is only going to be a run-time failure, so won't 657 # affect tests using this file but not this function. 658 $runperl_args->{progfile} = $tmpfile; 659 $runperl_args->{stderr} = 1; 660 661 open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; 662 663 # VMS adjustments 664 if( $^O eq 'VMS' ) { 665 $prog =~ s#/dev/null#NL:#; 666 667 # VMS file locking 668 $prog =~ s{if \(-e _ and -f _ and -r _\)} 669 {if (-e _ and -f _)} 670 } 671 672 print TEST $prog; 673 close TEST or die "Cannot close $tmpfile: $!"; 674 675 my $results = runperl(%$runperl_args); 676 my $status = $?; 677 678 # Clean up the results into something a bit more predictable. 679 $results =~ s/\n+$//; 680 $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; 681 $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; 682 683 # bison says 'parse error' instead of 'syntax error', 684 # various yaccs may or may not capitalize 'syntax'. 685 $results =~ s/^(syntax|parse) error/syntax error/mig; 686 687 if ($^O eq 'VMS') { 688 # some tests will trigger VMS messages that won't be expected 689 $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; 690 691 # pipes double these sometimes 692 $results =~ s/\n\n/\n/g; 693 } 694 695 my $pass = $resolve->($results); 696 unless ($pass) { 697 _diag "# PROG: \n$prog\n"; 698 _diag "# EXPECTED:\n", $resolve->(), "\n"; 699 _diag "# GOT:\n$results\n"; 700 _diag "# STATUS: $status\n"; 701 } 702 703 # Use the first line of the program as a name if none was given 704 unless( $name ) { 705 ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; 706 $name = $name . '...' if length $first_line > length $name; 707 } 708 709 _ok($pass, _where(), "fresh_perl - $name"); 710} 711 712# 713# fresh_perl_is 714# 715# Combination of run_perl() and is(). 716# 717 718sub fresh_perl_is { 719 my($prog, $expected, $runperl_args, $name) = @_; 720 721 # _fresh_perl() is going to clip the trailing newlines off the result. 722 # This will make it so the test author doesn't have to know that. 723 $expected =~ s/\n+$//; 724 725 local $Level = 2; 726 _fresh_perl($prog, 727 sub { @_ ? $_[0] eq $expected : $expected }, 728 $runperl_args, $name); 729} 730 731# 732# fresh_perl_like 733# 734# Combination of run_perl() and like(). 735# 736 737sub fresh_perl_like { 738 my($prog, $expected, $runperl_args, $name) = @_; 739 local $Level = 2; 740 _fresh_perl($prog, 741 sub { @_ ? $_[0] =~ $expected : $expected }, 742 $runperl_args, $name); 743} 744 745sub can_ok ($@) { 746 my($proto, @methods) = @_; 747 my $class = ref $proto || $proto; 748 749 unless( @methods ) { 750 return _ok( 0, _where(), "$class->can(...)" ); 751 } 752 753 my @nok = (); 754 foreach my $method (@methods) { 755 local($!, $@); # don't interfere with caller's $@ 756 # eval sometimes resets $! 757 eval { $proto->can($method) } || push @nok, $method; 758 } 759 760 my $name; 761 $name = @methods == 1 ? "$class->can('$methods[0]')" 762 : "$class->can(...)"; 763 764 _ok( !@nok, _where(), $name ); 765} 766 767sub isa_ok ($$;$) { 768 my($object, $class, $obj_name) = @_; 769 770 my $diag; 771 $obj_name = 'The object' unless defined $obj_name; 772 my $name = "$obj_name isa $class"; 773 if( !defined $object ) { 774 $diag = "$obj_name isn't defined"; 775 } 776 elsif( !ref $object ) { 777 $diag = "$obj_name isn't a reference"; 778 } 779 else { 780 # We can't use UNIVERSAL::isa because we want to honor isa() overrides 781 local($@, $!); # eval sometimes resets $! 782 my $rslt = eval { $object->isa($class) }; 783 if( $@ ) { 784 if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { 785 if( !UNIVERSAL::isa($object, $class) ) { 786 my $ref = ref $object; 787 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 788 } 789 } else { 790 die <<WHOA; 791WHOA! I tried to call ->isa on your object and got some weird error. 792This should never happen. Please contact the author immediately. 793Here's the error. 794$@ 795WHOA 796 } 797 } 798 elsif( !$rslt ) { 799 my $ref = ref $object; 800 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 801 } 802 } 803 804 _ok( !$diag, _where(), $name ); 805} 806 807# Set a watchdog to timeout the entire test file 808# NOTE: If the test file uses 'threads', then call the watchdog() function 809# _AFTER_ the 'threads' module is loaded. 810sub watchdog ($) 811{ 812 my $timeout = shift; 813 my $timeout_msg = 'Test process timed out - terminating'; 814 815 my $pid_to_kill = $$; # PID for this process 816 817 # Don't use a watchdog process if 'threads' is loaded - 818 # use a watchdog thread instead 819 if (! $threads::threads) { 820 821 # On Windows and VMS, try launching a watchdog process 822 # using system(1, ...) (see perlport.pod) 823 if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { 824 # On Windows, try to get the 'real' PID 825 if ($^O eq 'MSWin32') { 826 eval { require Win32; }; 827 if (defined(&Win32::GetCurrentProcessId)) { 828 $pid_to_kill = Win32::GetCurrentProcessId(); 829 } 830 } 831 832 # If we still have a fake PID, we can't use this method at all 833 return if ($pid_to_kill <= 0); 834 835 # Launch watchdog process 836 my $watchdog; 837 eval { 838 local $SIG{'__WARN__'} = sub { 839 _diag("Watchdog warning: $_[0]"); 840 }; 841 my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; 842 my $cmd = _create_runperl( prog => "sleep($timeout);" . 843 "warn qq/# $timeout_msg" . '\n/;' . 844 "kill($sig, $pid_to_kill);"); 845 $watchdog = system(1, $cmd); 846 }; 847 if ($@ || ($watchdog <= 0)) { 848 _diag('Failed to start watchdog'); 849 _diag($@) if $@; 850 undef($watchdog); 851 return; 852 } 853 854 # Add END block to parent to terminate and 855 # clean up watchdog process 856 eval "END { local \$! = 0; local \$? = 0; 857 wait() if kill('KILL', $watchdog); };"; 858 return; 859 } 860 861 # Try using fork() to generate a watchdog process 862 my $watchdog; 863 eval { $watchdog = fork() }; 864 if (defined($watchdog)) { 865 if ($watchdog) { # Parent process 866 # Add END block to parent to terminate and 867 # clean up watchdog process 868 eval "END { local \$! = 0; local \$? = 0; 869 wait() if kill('KILL', $watchdog); };"; 870 return; 871 } 872 873 ### Watchdog process code 874 875 # Load POSIX if available 876 eval { require POSIX; }; 877 878 # Execute the timeout 879 sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 880 sleep(2); 881 882 # Kill test process if still running 883 if (kill(0, $pid_to_kill)) { 884 _diag($timeout_msg); 885 kill('KILL', $pid_to_kill); 886 } 887 888 # Don't execute END block (added at beginning of this file) 889 $NO_ENDING = 1; 890 891 # Terminate ourself (i.e., the watchdog) 892 POSIX::_exit(1) if (defined(&POSIX::_exit)); 893 exit(1); 894 } 895 896 # fork() failed - fall through and try using a thread 897 } 898 899 # Use a watchdog thread because either 'threads' is loaded, 900 # or fork() failed 901 if (eval 'require threads; 1') { 902 threads->create(sub { 903 # Load POSIX if available 904 eval { require POSIX; }; 905 906 # Execute the timeout 907 my $time_left = $timeout; 908 do { 909 $time_left = $time_left - sleep($time_left); 910 } while ($time_left > 0); 911 912 # Kill the parent (and ourself) 913 select(STDERR); $| = 1; 914 _diag($timeout_msg); 915 POSIX::_exit(1) if (defined(&POSIX::_exit)); 916 my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; 917 kill($sig, $pid_to_kill); 918 })->detach(); 919 return; 920 } 921 922 # If everything above fails, then just use an alarm timeout 923 if (eval { alarm($timeout); 1; }) { 924 # Load POSIX if available 925 eval { require POSIX; }; 926 927 # Alarm handler will do the actual 'killing' 928 $SIG{'ALRM'} = sub { 929 select(STDERR); $| = 1; 930 _diag($timeout_msg); 931 POSIX::_exit(1) if (defined(&POSIX::_exit)); 932 my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; 933 kill($sig, $pid_to_kill); 934 }; 935 } 936} 937 9381; 939