X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4937f588b80a1b766e4edd8d2f246e3b72ffb7b8..6091bd4ca4a4a4c9b6f8cadddb53c19b96748a04:/t/test.pl diff --git a/t/test.pl b/t/test.pl index c452c38..79e6e25 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 +# Do not rely on features found only in more modern Perls here, as some CPAN +# distributions copy this file and must 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 # @@ -53,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; @@ -104,6 +106,12 @@ 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/ } @_; @@ -157,6 +165,13 @@ sub skip_all_without_config { } } +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') { @@ -176,6 +191,13 @@ sub find_git_or_skip { } $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`; @@ -262,6 +284,12 @@ sub _qq { return defined $x ? '"' . display ($x) . '"' : 'undef'; }; +# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file. +# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!"). +my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*"; +eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }' + if !defined &re::is_regexp; + # keys are the codes \n etc map to, values are 2 char strings such as \n my %backslash_escape; foreach my $x (split //, 'nrtfa\\\'"') { @@ -274,20 +302,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($chars_template, $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, which on EBCDIC aren't - # necessarily the same ones as on ASCII platforms, but - # are small ordinals, nonetheless - 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; @@ -413,13 +447,26 @@ sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- sub like_yn ($$$@) { 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 = $_[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 '$_[1]'\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); @@ -448,7 +495,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; @@ -462,10 +523,11 @@ sub skip_if_miniperl { } sub skip_without_dynamic_extension { - my ($extension) = @_; - skip("no dynamic loading on miniperl, no $extension") if is_miniperl(); - return if &_have_dynamic_extension; - skip("$extension was not built"); + 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 { @@ -548,7 +610,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) @@ -557,7 +619,8 @@ USE_OK # progs => [ multi-liner (avoid quotes) ] # progfile => perl script # stdin => string to feed the stdin (or undef to redirect from /dev/null) -# stderr => redirect stderr to stdout +# 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 @@ -589,7 +652,7 @@ sub _create_runperl { # Create the string to qx in runperl(). $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; } unless ($args{nolib}) { - $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS + $runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS } if ($args{switches}) { local $Level = 2; @@ -600,14 +663,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" ); @@ -665,7 +736,12 @@ sub _create_runperl { # Create the string to qx in runperl(). if (defined $args{args}) { $runperl = _quote_args($runperl, $args{args}); } - $runperl = $runperl . ' 2>&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; @@ -674,6 +750,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'; @@ -718,7 +795,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; } @@ -783,7 +860,7 @@ sub unlink_all { if( -f $file ){ _print_stderr "# Couldn't unlink '$file': $!\n"; }else{ - ++$count; + $count = $count + 1; # don't use ++ } } $count; @@ -854,11 +931,41 @@ sub tempfile { die "Can't find temporary file name starting \"tmp$$\""; } -# This is the temporary file for _fresh_perl +# 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 my $tmpfile = tempfile(); -sub _fresh_perl { - my($prog, $action, $expect, $runperl_args, $name) = @_; +sub fresh_perl { + my($prog, $runperl_args) = @_; + + # Run 'runperl' with the complete perl program contained in '$prog', and + # arguments in the hash referred to by '$runperl_args'. The results are + # returned, with $? set to the exit code. Unless overridden, stderr is + # redirected to stdout. + + die sprintf "Third argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})" + unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH'; # Given the choice of the mis-parsable {} # (we want an anon hash, but a borked lexer might think that it's a block) @@ -871,12 +978,14 @@ sub _fresh_perl { $runperl_args->{progfile} ||= $tmpfile; $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; - open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!"; + binmode TEST, ':utf8' if $runperl_args->{wide_chars}; print TEST $prog; close TEST or die "Cannot close $tmpfile: $!"; my $results = runperl(%$runperl_args); - my $status = $?; + my $status = $?; # Not necessary to save this, but it makes it clear to + # future maintainers. # Clean up the results into something a bit more predictable. $results =~ s/\n+$//; @@ -895,6 +1004,17 @@ sub _fresh_perl { $results =~ s/\n\n/\n/g; } + $? = $status; + return $results; +} + + +sub _fresh_perl { + my($prog, $action, $expect, $runperl_args, $name) = @_; + + my $results = fresh_perl($prog, $runperl_args); + my $status = $?; + # Use the first line of the program as a name if none was given unless( $name ) { ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; @@ -953,13 +1073,15 @@ 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): +# The first line of the code to run may be a command line switch such as -wE +# or -0777 (alphanumerics only; only one cluster, beginning with a minus is +# allowed). Later lines may contain (note the '# ' on each): # # TODO reason for todo # # SKIP reason for skip # # SKIP ?code to test if this should be skipped @@ -1019,7 +1141,7 @@ sub setup_multiple_progs { my $found; while (<$fh>) { if (/^__END__/) { - ++$found; + $found = $found + 1; # don't use ++ last; } } @@ -1141,6 +1263,7 @@ sub run_multiple_progs { open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; print $fh q{ BEGIN { + push @INC, '.'; open STDERR, '>&', STDOUT or die "Can't dup STDOUT->STDERR: $!;"; } @@ -1362,7 +1485,7 @@ sub class_ok { # Written so as to count as one test local $Level = $Level + 1; if( ref $class ) { - ok( 0, "$class is a refrence, not a class name" ); + ok( 0, "$class is a reference, not a class name" ); } else { isa_ok($class, $isa, $class_name); @@ -1500,10 +1623,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'); @@ -1514,8 +1654,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; } @@ -1602,57 +1742,4 @@ WATCHDOG_VIA_ALARM: } } -# 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. - -sub native_to_latin1($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $output = ""; - for my $i (0 .. length($string) - 1) { - $output .= chr(ord_native_to_latin1(ord(substr($string, $i, 1)))); - } - # Preserve utf8ness of input onto the output, even if it didn't need to be - # utf8 - utf8::upgrade($output) if utf8::is_utf8($string); - - return $output; -} - -sub latin1_to_native($) { - my $string = shift; - - return $string if ord('^') == 94; # ASCII, Latin1 - my $output = ""; - for my $i (0 .. length($string) - 1) { - $output .= chr(ord_latin1_to_native(ord(substr($string, $i, 1)))); - } - # Preserve utf8ness of input onto the output, even if it didn't need to be - # utf8 - utf8::upgrade($output) if utf8::is_utf8($string); - - return $output; -} - -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('^') == 94; # ASCII, Latin1 - return utf8::unicode_to_native($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('^') == 94; # ASCII, Latin1 - return utf8::native_to_unicode($ord); -} - 1;