X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4937f588b80a1b766e4edd8d2f246e3b72ffb7b8..649716a8e8da01843c160e26bdb22e402b02d47b:/t/test.pl diff --git a/t/test.pl b/t/test.pl index c452c38..13db432 100644 --- a/t/test.pl +++ b/t/test.pl @@ -53,6 +53,7 @@ sub plan { } } else { my %plan = @_; + $plan{skip_all} and skip_all($plan{skip_all}); $n = $plan{tests}; } _print "1..$n\n" unless $noplan; @@ -176,6 +177,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`; @@ -413,6 +421,14 @@ 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; @@ -548,7 +564,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 +573,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 @@ -606,8 +623,16 @@ sub _create_runperl { # Create the string to qx in runperl(). 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 +690,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; @@ -718,7 +748,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; } @@ -854,6 +884,28 @@ sub tempfile { 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 my $tmpfile = tempfile(); @@ -953,7 +1005,8 @@ 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. @@ -1514,8 +1567,14 @@ 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); };"; + # Win32 watchdog is launched by cmd.exe shell, so use process group + # kill, otherwise the watchdog is never killed and harness waits + # every time for the timeout, #121395 + eval( $is_mswin ? + "END { local \$! = 0; local \$? = 0; + wait() if kill('-KILL', $watchdog); };" + : "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"); return; } @@ -1602,57 +1661,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;