X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ebf2da99b3c7f4f2c8cb1ba474ef47dd8a9deaff..aed13984243c935bb8b73650a63e730cbc85c26a:/t/test.pl diff --git a/t/test.pl b/t/test.pl index 6fc659f..84475ea 100644 --- a/t/test.pl +++ b/t/test.pl @@ -1,17 +1,18 @@ # -# t/test.pl - most of Test::More functionality without the fuss, plus -# has mappings native_to_latin1 and latin1_to_native so that fewer tests -# on non ASCII-ish platforms need to be skipped +# t/test.pl - most of Test::More functionality without the fuss # NOTE: # -# Increment ($x++) has a certain amount of cleverness for things like +# It's best to not features found only in more modern Perls here, as some cpan +# distributions copy this file and operate on older Perls. Similarly keep +# things simple as this may be run under fairly broken circumstances. For +# example, increment ($x++) has a certain amount of cleverness for things like # # $x = 'zz'; # $x++; # $x eq 'aaa'; # -# stands more chance of breaking than just a simple +# This stands more chance of breaking than just a simple # # $x = $x + 1 # @@ -24,6 +25,10 @@ my $planned; my $noplan; my $Perl; # Safer version of $^X set by which_perl() +# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC +$::IS_ASCII = ord 'A' == 65; +$::IS_EBCDIC = ord 'A' == 193; + $TODO = 0; $NO_ENDING = 0; $Tests_Are_Passing = 1; @@ -49,6 +54,7 @@ sub plan { } } else { my %plan = @_; + $plan{skip_all} and skip_all($plan{skip_all}); $n = $plan{tests}; } _print "1..$n\n" unless $noplan; @@ -100,11 +106,27 @@ sub is_miniperl { return !defined &DynaLoader::boot_DynaLoader; } +sub set_up_inc { + # Don’t clobber @INC under miniperl + @INC = () unless is_miniperl; + unshift @INC, @_; +} + sub _comment { return map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; } +sub _have_dynamic_extension { + my $extension = shift; + unless (eval {require Config; 1}) { + warn "test.pl had problems loading Config: $@"; + return 1; + } + $extension =~ s!::!/!g; + return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); +} + sub skip_all { if (@_) { _print "1..0 # Skip @_\n"; @@ -118,6 +140,88 @@ sub skip_all_if_miniperl { skip_all(@_) if is_miniperl(); } +sub skip_all_without_dynamic_extension { + my ($extension) = @_; + skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); + return if &_have_dynamic_extension; + skip_all("$extension was not built"); +} + +sub skip_all_without_perlio { + skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); +} + +sub skip_all_without_config { + unless (eval {require Config; 1}) { + warn "test.pl had problems loading Config: $@"; + return; + } + foreach (@_) { + next if $Config::Config{$_}; + my $key = $_; # Need to copy, before trying to modify. + $key =~ s/^use//; + $key =~ s/^d_//; + skip_all("no $key"); + } +} + +sub skip_all_without_unicode_tables { # (but only under miniperl) + if (is_miniperl()) { + skip_all_if_miniperl("Unicode tables not built yet") + unless eval 'require "unicore/Heavy.pl"'; + } +} + +sub find_git_or_skip { + my ($source_dir, $reason); + if (-d '.git') { + $source_dir = '.'; + } elsif (-l 'MANIFEST' && -l 'AUTHORS') { + my $where = readlink 'MANIFEST'; + die "Can't readling MANIFEST: $!" unless defined $where; + die "Confusing symlink target for MANIFEST, '$where'" + unless $where =~ s!/MANIFEST\z!!; + if (-d "$where/.git") { + # Looks like we are in a symlink tree + if (exists $ENV{GIT_DIR}) { + diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); + } else { + note("Found source tree at $where, setting \$ENV{GIT_DIR}"); + $ENV{GIT_DIR} = "$where/.git"; + } + $source_dir = $where; + } + } elsif (exists $ENV{GIT_DIR}) { + my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; + my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; + chomp $out; + if($out eq $commit) { + $source_dir = '.' + } + } + if ($source_dir) { + my $version_string = `git --version`; + if (defined $version_string + && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { + return $source_dir if eval "v$1 ge v1.5.0"; + # If you have earlier than 1.5.0 and it works, change this test + $reason = "in git checkout, but git version '$1$2' too old"; + } else { + $reason = "in git checkout, but cannot run git"; + } + } else { + $reason = 'not being run from a git checkout'; + } + skip_all($reason) if $_[0] && $_[0] eq 'all'; + skip($reason, @_); +} + +sub BAIL_OUT { + my ($reason) = @_; + _print("Bail out! $reason\n"); + exit 255; +} + sub _ok { my ($pass, $where, $name, @mess) = @_; # Do not try to microoptimize by factoring out the "not ". @@ -143,7 +247,10 @@ sub _ok { note @mess; # Ensure that the message is properly escaped. } else { - _diag "# Failed $where\n"; + my $msg = "# Failed test $test - "; + $msg.= "$name " if $name; + $msg .= "$where\n"; + _diag $msg; _diag @mess; } @@ -189,18 +296,26 @@ sub display { foreach my $x (@_) { if (defined $x and not ref $x) { my $y = ''; - foreach my $c (unpack("U*", $x)) { + foreach my $c (unpack("W*", $x)) { if ($c > 255) { $y = $y . sprintf "\\x{%x}", $c; } elsif ($backslash_escape{$c}) { $y = $y . $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... - if ($z =~ /[[:^print:]]/) { - # Use octal for characters traditionally expressed as - # such: the low controls - if ($c <= 037) { + if ($z !~ /[^[:^print:][:^ascii:]]/) { + # The pattern above is equivalent (by de Morgan's + # laws) to: + # $z !~ /(?[ [:print:] & [:ascii:] ])/ + # or, $z is not an ascii printable character + + # Use octal for characters with small ordinals that + # are traditionally expressed as octal: the controls + # below space, which on EBCDIC are almost all the + # controls, but on ASCII don't include DEL nor the C1 + # controls. + if ($c < ord " ") { $z = sprintf "\\%03o", $c; } else { $z = sprintf "\\x{%x}", $c; @@ -325,14 +440,27 @@ sub like ($$@) { like_yn (0,@_) }; # 0 for - sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- sub like_yn ($$$@) { - my ($flip, $got, $expected, $name, @mess) = @_; + my ($flip, undef, $expected, $name, @mess) = @_; + + # We just accept like(..., qr/.../), not like(..., '...'), and + # definitely not like(..., '/.../') like + # Test::Builder::maybe_regex() does. + unless (re::is_regexp($expected)) { + die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string"; + } + my $pass; - $pass = $got =~ /$expected/ if !$flip; - $pass = $got !~ /$expected/ if $flip; + $pass = $_[1] =~ /$expected/ if !$flip; + $pass = $_[1] !~ /$expected/ if $flip; + my $display_got = $_[1]; + $display_got = display($display_got); + my $display_expected = $expected; + $display_expected = display($display_expected); unless ($pass) { - unshift(@mess, "# got '$got'\n", + unshift(@mess, "# got '$display_got'\n", $flip - ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); + ? "# expected !~ /$display_expected/\n" + : "# expected /$display_expected/\n"); } local $Level = $Level + 1; _ok($pass, _where(), $name, @mess); @@ -361,7 +489,21 @@ sub next_test { # be compatible with Test::More::skip(). sub skip { my $why = shift; - my $n = @_ ? shift : 1; + my $n = @_ ? shift : 1; + my $bad_swap; + my $both_zero; + { + local $^W = 0; + $bad_swap = $why > 0 && $n == 0; + $both_zero = $why == 0 && $n == 0; + } + if ($bad_swap || $both_zero || @_) { + my $arg = "'$why', '$n'"; + if (@_) { + $arg .= join(", ", '', map { qq['$_'] } @_); + } + die qq[$0: expected skip(why, count), got skip($arg)\n]; + } for (1..$n) { _print "ok $test # skip $why\n"; $test = $test + 1; @@ -374,6 +516,14 @@ sub skip_if_miniperl { skip(@_) if is_miniperl(); } +sub skip_without_dynamic_extension { + my $extension = shift; + skip("no dynamic loading on miniperl, no extension $extension", @_) + if is_miniperl(); + return if &_have_dynamic_extension($extension); + skip("extension $extension was not built", @_); +} + sub todo_skip { my $why = shift; my $n = @_ ? shift : 1; @@ -405,7 +555,10 @@ sub eq_hash { # Force a hash recompute if this perl's internals can cache the hash key. $key = "" . $key; if (exists $orig->{$key}) { - if ($orig->{$key} ne $value) { + if ( + defined $orig->{$key} != defined $value + || (defined $value && $orig->{$key} ne $value) + ) { _print "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; @@ -451,7 +604,7 @@ USE_OK } } -# runperl - Runs a separate perl interpreter. +# runperl - Runs a separate perl interpreter and returns its output. # Arguments : # switches => [ command-line switches ] # nolib => 1 # don't use -I../lib (included by default) @@ -459,8 +612,9 @@ USE_OK # prog => one-liner (avoid quotes) # progs => [ multi-liner (avoid quotes) ] # progfile => perl script -# stdin => string to feed the stdin -# stderr => redirect stderr to stdout +# stdin => string to feed the stdin (or undef to redirect from /dev/null) +# stderr => If 'devnull' suppresses stderr, if other TRUE value redirect +# stderr to stdout # args => [ command-line arguments to the perl program ] # verbose => print the command line @@ -503,14 +657,22 @@ sub _create_runperl { # Create the string to qx in runperl(). if (defined $args{prog}) { die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() if defined $args{progs}; - $args{progs} = [$args{prog}] + $args{progs} = [split /\n/, $args{prog}, -1] } if (defined $args{progs}) { die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { - if ($prog =~ tr/'"// && !$args{non_portable}) { - warn "quotes in prog >>$prog<< are not portable"; + if (!$args{non_portable}) { + if ($prog =~ tr/'"//) { + warn "quotes in prog >>$prog<< are not portable"; + } + if ($prog =~ /^([<>|]|2>)/) { + warn "Initial $1 in prog >>$prog<< is not portable"; + } + if ($prog =~ /&\z/) { + warn "Trailing & in prog >>$prog<< is not portable"; + } } if ($is_mswin || $is_netware || $is_vms) { $runperl = $runperl . qq ( -e "$prog" ); @@ -542,11 +704,38 @@ sub _create_runperl { # Create the string to qx in runperl(). $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } + } elsif (exists $args{stdin}) { + # Using the pipe construction above can cause fun on systems which use + # ksh as /bin/sh, as ksh does pipes differently (with one less process) + # With sh, for the command line 'perl -e 'print qq()' | perl -e ...' + # the sh process forks two children, which use exec to start the two + # perl processes. The parent shell process persists for the duration of + # the pipeline, and the second perl process starts with no children. + # With ksh (and zsh), the shell saves a process by forking a child for + # just the first perl process, and execing itself to start the second. + # This means that the second perl process starts with one child which + # it didn't create. This causes "fun" when if the tests assume that + # wait (or waitpid) will only return information about processes + # started within the test. + # They also cause fun on VMS, where the pipe implementation returns + # the exit code of the process at the front of the pipeline, not the + # end. This messes up any test using OPTION FATAL. + # Hence it's useful to have a way to make STDIN be at eof without + # needing a pipeline, so that the fork tests have a sane environment + # without these surprises. + + # /dev/null appears to be surprisingly portable. + $runperl = $runperl . ($is_mswin ? ' &1' if $args{stderr}; + if (exists $args{stderr} && $args{stderr} eq 'devnull') { + $runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null'); + } + elsif ($args{stderr}) { + $runperl = $runperl . ' 2>&1'; + } if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; @@ -555,6 +744,7 @@ sub _create_runperl { # Create the string to qx in runperl(). return $runperl; } +# sub run_perl {} is alias to below sub runperl { die "test.pl:runperl() does not take a hashref" if ref $_[0] and ref $_[0] eq 'HASH'; @@ -570,7 +760,7 @@ sub runperl { # run a fresh perl, so we'll brute force launder everything for you my $sep; - if (! eval 'require Config; 1') { + if (! eval {require Config; 1}) { warn "test.pl had problems loading Config: $@"; $sep = ':'; } else { @@ -599,7 +789,7 @@ sub runperl { } else { $result = `$runperl`; } - $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these + $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these return $result; } @@ -620,7 +810,7 @@ sub which_perl { return $Perl if $is_vms; my $exe; - if (! eval 'require Config; 1') { + if (! eval {require Config; 1}) { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { @@ -634,7 +824,7 @@ sub which_perl { if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; - if (! eval 'require File::Spec; 1') { + if (! eval {require File::Spec; 1}) { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { @@ -670,6 +860,44 @@ sub unlink_all { $count; } +# _num_to_alpha - Returns a string of letters representing a positive integer. +# Arguments : +# number to convert +# maximum number of letters + +# returns undef if the number is negative +# returns undef if the number of letters is greater than the maximum wanted + +# _num_to_alpha( 0) eq 'A'; +# _num_to_alpha( 1) eq 'B'; +# _num_to_alpha(25) eq 'Z'; +# _num_to_alpha(26) eq 'AA'; +# _num_to_alpha(27) eq 'AB'; + +my @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); + +# Avoid ++ -- ranges split negative numbers +sub _num_to_alpha{ + my($num,$max_char) = @_; + return unless $num >= 0; + my $alpha = ''; + my $char_count = 0; + $max_char = 0 if $max_char < 0; + + while( 1 ){ + $alpha = $letters[ $num % 26 ] . $alpha; + $num = int( $num / 26 ); + last if $num == 0; + $num = $num - 1; + + # char limit + next unless $max_char; + $char_count = $char_count + 1; + return if $char_count == $max_char; + } + return $alpha; +} + my %tmpfiles; END { unlink_all keys %tmpfiles } @@ -677,26 +905,46 @@ END { unlink_all keys %tmpfiles } $::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; # Avoid ++, avoid ranges, avoid split // -my @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); +my $tempfile_count = 0; sub tempfile { - my $count = 0; - do { - my $temp = $count; + while(1){ my $try = "tmp$$"; - do { - $try = $try . $letters[$temp % 26]; - $temp = int ($temp / 26); - } while $temp; + my $alpha = _num_to_alpha($tempfile_count,2); + last unless defined $alpha; + $try = $try . $alpha; + $tempfile_count = $tempfile_count + 1; + # Need to note all the file names we allocated, as a second request may # come before the first is created. - if (!-e $try && !$tmpfiles{$try}) { + if (!$tmpfiles{$try} && !-e $try) { # We have a winner $tmpfiles{$try} = 1; return $try; } - $count = $count + 1; - } while $count < 26 * 26; - die "Can't find temporary file name starting 'tmp$$'"; + } + die "Can't find temporary file name starting \"tmp$$\""; +} + +# register_tempfile - Adds a list of files to be removed at the end of the current test file +# Arguments : +# a list of files to be removed later + +# returns a count of how many file names were actually added + +# Reuses %tmpfiles so that tempfile() will also skip any files added here +# even if the file doesn't exist yet. + +sub register_tempfile { + my $count = 0; + for( @_ ){ + if( $tmpfiles{$_} ){ + _print_stderr "# Temporary file '$_' already added\n"; + }else{ + $tmpfiles{$_} = 1; + $count = $count + 1; + } + } + return $count; } # This is the temporary file for _fresh_perl @@ -713,20 +961,10 @@ sub _fresh_perl { # it feels like the least-worse thing is to assume that auto-vivification # works. At least, this is only going to be a run-time failure, so won't # affect tests using this file but not this function. - $runperl_args->{progfile} = $tmpfile; - $runperl_args->{stderr} = 1; + $runperl_args->{progfile} ||= $tmpfile; + $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; - - # VMS adjustments - if( $is_vms ) { - $prog =~ s#/dev/null#NL:#; - - # VMS file locking - $prog =~ s{if \(-e _ and -f _ and -r _\)} - {if (-e _ and -f _)} - } - print TEST $prog; close TEST or die "Cannot close $tmpfile: $!"; @@ -808,15 +1046,132 @@ sub fresh_perl_like { # Many tests use the same format in __DATA__ or external files to specify a # sequence of (fresh) tests to run, extra files they may temporarily need, and -# what the expected output is. So have excatly one copy of the code to run that +# what the expected output is. Putting it here allows common code to serve +# these multiple tests. +# +# Each program is source code to run followed by an "EXPECT" line, followed +# by the expected output. +# +# The code to run may begin with a command line switch such as -w or -0777 +# (alphanumerics only), and may contain (note the '# ' on each): +# # TODO reason for todo +# # SKIP reason for skip +# # SKIP ?code to test if this should be skipped +# # NAME name of the test (as with ok($ok, $name)) +# +# The expected output may contain: +# OPTION list of options +# OPTIONS list of options +# +# The possible options for OPTION may be: +# regex - the expected output is a regular expression +# random - all lines match but in any order +# fatal - the code will fail fatally (croak, die) +# +# If the actual output contains a line "SKIPPED" the test will be +# skipped. +# +# If the actual output contains a line "PREFIX", any output starting with that +# line will be ignored when comparing with the expected output +# +# If the global variable $FATAL is true then OPTION fatal is the +# default. + +sub _setup_one_file { + my $fh = shift; + # Store the filename as a program that started at line 0. + # Real files count lines starting at line 1. + my @these = (0, shift); + my ($lineno, $current); + while (<$fh>) { + if ($_ eq "########\n") { + if (defined $current) { + push @these, $lineno, $current; + } + undef $current; + } else { + if (!defined $current) { + $lineno = $.; + } + $current .= $_; + } + } + if (defined $current) { + push @these, $lineno, $current; + } + ((scalar @these) / 2 - 1, @these); +} + +sub setup_multiple_progs { + my ($tests, @prgs); + foreach my $file (@_) { + next if $file =~ /(?:~|\.orig|,v)$/; + next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); + next if -d $file; + + open my $fh, '<', $file or die "Cannot open $file: $!\n" ; + my $found; + while (<$fh>) { + if (/^__END__/) { + ++$found; + last; + } + } + # This is an internal error, and should never happen. All bar one of + # the files had an __END__ marker to signal the end of their preamble, + # although for some it wasn't technically necessary as they have no + # tests. It might be possible to process files without an __END__ by + # seeking back to the start and treating the whole file as tests, but + # it's simpler and more reliable just to make the rule that all files + # must have __END__ in. This should never fail - a file without an + # __END__ should not have been checked in, because the regression tests + # would not have passed. + die "Could not find '__END__' in $file" + unless $found; + + my ($t, @p) = _setup_one_file($fh, $file); + $tests += $t; + push @prgs, @p; + + close $fh + or die "Cannot close $file: $!\n"; + } + return ($tests, @prgs); +} sub run_multiple_progs { - my @prgs = @_; + my $up = shift; + my @prgs; + if ($up) { + # The tests in lib run in a temporary subdirectory of t, and always + # pass in a list of "programs" to run + @prgs = @_; + } else { + # The tests below t run in t and pass in a file handle. In theory we + # can pass (caller)[1] as the second argument to report errors with + # the filename of our caller, as the handle is always DATA. However, + # line numbers in DATA count from the __END__ token, so will be wrong. + # Which is more confusing than not providing line numbers. So, for now, + # don't provide line numbers. No obvious clean solution - one hack + # would be to seek DATA back to the start and read to the __END__ token, + # but that feels almost like we should just open $0 instead. + + # Not going to rely on undef in list assignment. + my $dummy; + ($dummy, @prgs) = _setup_one_file(shift); + } + my $tmpfile = tempfile(); - for (@prgs){ - unless (/\n/) { - print "# From $_\n"; + my ($file, $line); + PROGRAM: + while (defined ($line = shift @prgs)) { + $_ = shift @prgs; + unless ($line) { + $file = $_; + if (defined $file) { + print "# From $file\n"; + } next; } my $switch = ""; @@ -841,8 +1196,21 @@ sub run_multiple_progs { } } + my $name = ''; + if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { + $name = $1; + } + + if ($reason{skip}) { + SKIP: + { + skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); + } + next PROGRAM; + } + if ($prog =~ /--FILE--/) { - my @files = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; shift @files ; die "Internal error: test $_ didn't split into pairs, got " . scalar(@files) . "[" . join("%%%%", @files) ."]\n" @@ -874,8 +1242,11 @@ sub run_multiple_progs { print $fh "\n#line 1\n"; # So the line numbers don't get messed up. print $fh $prog,"\n"; close $fh or die "Cannot close $tmpfile: $!"; - my $results = runperl( switches => ["-I../../lib", $switch], nolib => 1, - stderr => 1, progfile => $tmpfile ); + my $results = runperl( stderr => 1, progfile => $tmpfile, + stdin => undef, $up + ? (switches => ["-I$up/lib", $switch], nolib => 1) + : (switches => [$switch]) + ); my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN @@ -898,6 +1269,7 @@ sub run_multiple_progs { # any special options? (OPTIONS foo bar zap) my $option_regex = 0; my $option_random = 0; + my $fatal = $FATAL; if ($expected =~ s/^OPTIONS? (.+)\n//) { foreach my $option (split(' ', $1)) { if ($option eq 'regex') { # allow regular expressions @@ -906,6 +1278,9 @@ sub run_multiple_progs { elsif ($option eq 'random') { # all lines match, but in any order $option_random = 1; } + elsif ($option eq 'fatal') { # perl should fail + $fatal = 1; + } else { die "$0: Unknown OPTION '$option'\n"; } @@ -918,28 +1293,36 @@ sub run_multiple_progs { print "$results\n" ; $ok = 1; } - elsif ($option_random) { - my @got = sort split "\n", $results; - my @expected = sort split "\n", $expected; - - $ok = "@got" eq "@expected"; - } - elsif ($option_regex) { - $ok = $results =~ /^$expected/; - } - elsif ($prefix) { - $ok = $results =~ /^\Q$expected/; - } else { - $ok = $results eq $expected; + if ($option_random) { + my @got = sort split "\n", $results; + my @expected = sort split "\n", $expected; + + $ok = "@got" eq "@expected"; + } + elsif ($option_regex) { + $ok = $results =~ /^$expected/; + } + elsif ($prefix) { + $ok = $results =~ /^\Q$expected/; + } + else { + $ok = $results eq $expected; + } + + if ($ok && $fatal && !($status >> 8)) { + $ok = 0; + } } local $::TODO = $reason{todo}; unless ($ok) { my $err_line = "PROG: $switch\n$prog\n" . - "EXPECTED:\n$expected\n" . - "GOT:\n$results\n"; + "EXPECTED:\n$expected\n"; + $err_line .= "EXIT STATUS: != 0\n" if $fatal; + $err_line .= "GOT:\n$results\n"; + $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; if ($::TODO) { $err_line =~ s/^/# /mg; print $err_line; # Harness can't filter it out from STDERR. @@ -949,7 +1332,14 @@ sub run_multiple_progs { } } - ok($ok); + if (defined $file) { + _ok($ok, "at $file line $line", $name); + } else { + # We don't have file and line number data for the test, so report + # errors as coming from our caller. + local $Level = $Level + 1; + ok($ok, $name); + } foreach (@temps) { unlink $_ if $_; @@ -983,7 +1373,7 @@ sub can_ok ($@) { } -# Call $class->new( @$args ); and run the result through isa_ok. +# Call $class->new( @$args ); and run the result through object_ok. # See Test::More::new_ok sub new_ok { my($class, $args, $obj_name) = @_; @@ -997,7 +1387,7 @@ sub new_ok { my $error = $@; if($ok) { - isa_ok($obj, $class, $object_name); + object_ok($obj, $class, $object_name); } else { ok( 0, "new() died" ); @@ -1018,20 +1408,29 @@ sub isa_ok ($$;$) { if( !defined $object ) { $diag = "$obj_name isn't defined"; } - elsif( !ref $object ) { - $diag = "$obj_name isn't a reference"; - } else { + my $whatami = ref $object ? 'object' : 'class'; + # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; - if( $@ ) { - if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { + my $error = $@; # in case something else blows away $@ + + if( $error ) { + if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { + # It's an unblessed reference + $obj_name = 'The reference' unless defined $obj_name; if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } - } else { + } + elsif( $error =~ /Can't call method "isa" without a package/ ) { + # It's something that can't even be a class + $obj_name = 'The thing' unless defined $obj_name; + $diag = "$obj_name isn't a class or reference"; + } + else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. @@ -1041,6 +1440,7 @@ WHOA } } elsif( !$rslt ) { + $obj_name = "The $whatami" unless defined $obj_name; my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } @@ -1049,6 +1449,105 @@ WHOA _ok( !$diag, _where(), $name ); } + +sub class_ok { + my($class, $isa, $class_name) = @_; + + # Written so as to count as one test + local $Level = $Level + 1; + if( ref $class ) { + ok( 0, "$class is a reference, not a class name" ); + } + else { + isa_ok($class, $isa, $class_name); + } +} + + +sub object_ok { + my($obj, $isa, $obj_name) = @_; + + local $Level = $Level + 1; + if( !ref $obj ) { + ok( 0, "$obj is not a reference" ); + } + else { + isa_ok($obj, $isa, $obj_name); + } +} + + +# Purposefully avoiding a closure. +sub __capture { + push @::__capture, join "", @_; +} + +sub capture_warnings { + my $code = shift; + + local @::__capture; + local $SIG {__WARN__} = \&__capture; + &$code; + return @::__capture; +} + +# This will generate a variable number of tests. +# Use done_testing() instead of a fixed plan. +sub warnings_like { + my ($code, $expect, $name) = @_; + local $Level = $Level + 1; + + my @w = capture_warnings($code); + + cmp_ok(scalar @w, '==', scalar @$expect, $name); + foreach my $e (@$expect) { + if (ref $e) { + like(shift @w, $e, $name); + } else { + is(shift @w, $e, $name); + } + } + if (@w) { + diag("Saw these additional warnings:"); + diag($_) foreach @w; + } +} + +sub _fail_excess_warnings { + my($expect, $got, $name) = @_; + local $Level = $Level + 1; + # This will fail, and produce diagnostics + is($expect, scalar @$got, $name); + diag("Saw these warnings:"); + diag($_) foreach @$got; +} + +sub warning_is { + my ($code, $expect, $name) = @_; + die sprintf "Expect must be a string or undef, not a %s reference", ref $expect + if ref $expect; + local $Level = $Level + 1; + my @w = capture_warnings($code); + if (@w > 1) { + _fail_excess_warnings(0 + defined $expect, \@w, $name); + } else { + is($w[0], $expect, $name); + } +} + +sub warning_like { + my ($code, $expect, $name) = @_; + die sprintf "Expect must be a regexp object" + unless ref $expect eq 'Regexp'; + local $Level = $Level + 1; + my @w = capture_warnings($code); + if (@w > 1) { + _fail_excess_warnings(0 + defined $expect, \@w, $name); + } else { + like($w[0], $expect, $name); + } +} + # Set a watchdog to timeout the entire test file # NOTE: If the test file uses 'threads', then call the watchdog() function # _AFTER_ the 'threads' module is loaded. @@ -1072,7 +1571,7 @@ sub watchdog ($;$) # Don't use a watchdog process if 'threads' is loaded - # use a watchdog thread instead - if (!$threads_on) { + if (!$threads_on || $method eq "process") { # On Windows and VMS, try launching a watchdog process # using system(1, ...) (see perlport.pod) @@ -1095,10 +1594,27 @@ sub watchdog ($;$) _diag("Watchdog warning: $_[0]"); }; my $sig = $is_vms ? 'TERM' : 'KILL'; - my $cmd = _create_runperl( prog => "sleep($timeout);" . - "warn qq/# $timeout_msg" . '\n/;' . - "kill($sig, $pid_to_kill);"); - $watchdog = system(1, $cmd); + my $prog = "sleep($timeout);" . + "warn qq/# $timeout_msg" . '\n/;' . + "kill(q/$sig/, $pid_to_kill);"; + + # On Windows use the indirect object plus LIST form to guarantee + # that perl is launched directly rather than via the shell (see + # perlfunc.pod), and ensure that the LIST has multiple elements + # since the indirect object plus COMMANDSTRING form seems to + # hang (see perl #121283). Don't do this on VMS, which doesn't + # support the LIST form at all. + if ($is_mswin) { + my $runperl = which_perl(); + if ($runperl =~ m/\s/) { + $runperl = qq{"$runperl"}; + } + $watchdog = system({ $runperl } 1, $runperl, '-e', $prog); + } + else { + my $cmd = _create_runperl(prog => $prog); + $watchdog = system(1, $cmd); + } }; if ($@ || ($watchdog <= 0)) { _diag('Failed to start watchdog'); @@ -1109,8 +1625,8 @@ sub watchdog ($;$) # Add END block to parent to terminate and # clean up watchdog process - eval "END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"; + eval("END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"); return; } @@ -1139,6 +1655,11 @@ sub watchdog ($;$) if (kill(0, $pid_to_kill)) { _diag($timeout_msg); kill('KILL', $pid_to_kill); + if ($is_cygwin) { + # sometimes the above isn't enough on cygwin + sleep 1; # wait a little, it might have worked after all + system("/bin/kill -f $pid_to_kill"); + } } # Don't execute END block (added at beginning of this file) @@ -1154,7 +1675,7 @@ sub watchdog ($;$) # Use a watchdog thread because either 'threads' is loaded, # or fork() failed - if (eval 'require threads; 1') { + if (eval {require threads; 1}) { 'threads'->create(sub { # Load POSIX if available eval { require POSIX; }; @@ -1192,145 +1713,4 @@ WATCHDOG_VIA_ALARM: } } -my $cp_0037 = # EBCDIC code page 0037 - '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x25\x0B\x0C\x0D\x0E\x0F' . - '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . - '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . - '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . - '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . - '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBA\xE0\xBB\xB0\x6D' . - '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . - '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' . - '\x20\x21\x22\x23\x24\x15\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . - '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' . - '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBD\xB4\x9A\x8A\x5F\xCA\xAF\xBC' . - '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . - '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . - '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xAD\xAE\x59' . - '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . - '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; - -my $cp_1047 = # EBCDIC code page 1047 - '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' . - '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . - '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . - '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . - '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . - '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xAD\xE0\xBD\x5F\x6D' . - '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . - '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' . - '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . - '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' . - '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBB\xB4\x9A\x8A\xB0\xCA\xAF\xBC' . - '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . - '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . - '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xBA\xAE\x59' . - '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . - '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; - -my $cp_bc = # EBCDIC code page POSiX-BC - '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' . - '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . - '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . - '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . - '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . - '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBB\xBC\xBD\x6A\x6D' . - '\x4A\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . - '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xFB\x4F\xFD\xFF\x07' . - '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . - '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\x5F' . - '\x41\xAA\xB0\xB1\x9F\xB2\xD0\xB5\x79\xB4\x9A\x8A\xBA\xCA\xAF\xA1' . - '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . - '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . - '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xE0\xFE\xDD\xFC\xAD\xAE\x59' . - '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . - '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xC0\xDE\xDB\xDC\x8D\x8E\xDF'; - -my $straight = # Avoid ranges - '\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F' . - '\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F' . - '\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F' . - '\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F' . - '\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F' . - '\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F' . - '\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F' . - '\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F' . - '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F' . - '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F' . - '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF' . - '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF' . - '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF' . - '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF' . - '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' . - '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF'; - -# The following 2 functions allow tests to work on both EBCDIC and -# ASCII-ish platforms. They convert string scalars between the native -# character set and the set of 256 characters which is usually called -# Latin1. -# -# These routines don't work on UTF-EBCDIC and UTF-8. - -sub native_to_latin1($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $cp; - if (ord('^') == 95) { # EBCDIC 1047 - $cp = \$cp_1047; - } - elsif (ord('^') == 106) { # EBCDIC POSIX-BC - $cp = \$cp_bc; - } - elsif (ord('^') == 176) { # EBCDIC 037 */ - $cp = \$cp_0037; - } - else { - die "Unknown native character set"; - } - - eval '$string =~ tr/' . $$cp . '/' . $straight . '/'; - return $string; -} - -sub latin1_to_native($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $cp; - if (ord('^') == 95) { # EBCDIC 1047 - $cp = \$cp_1047; - } - elsif (ord('^') == 106) { # EBCDIC POSIX-BC - $cp = \$cp_bc; - } - elsif (ord('^') == 176) { # EBCDIC 037 */ - $cp = \$cp_0037; - } - else { - die "Unknown native character set"; - } - - eval '$string =~ tr/' . $straight . '/' . $$cp . '/'; - return $string; -} - -sub ord_latin1_to_native { - # given an input code point, return the platform's native - # equivalent value. Anything above latin1 is itself. - - my $ord = shift; - return $ord if $ord > 255; - return ord latin1_to_native(chr $ord); -} - -sub ord_native_to_latin1 { - # given an input platform code point, return the latin1 equivalent value. - # Anything above latin1 is itself. - - my $ord = shift; - return $ord if $ord > 255; - return ord native_to_latin1(chr $ord); -} - 1;