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