X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=7d1a90bb9f5010881f41f3518a6fa2bddd01db1e;hb=d47e1c27dd43d7b79216c58864a5e539f612e974;hp=1562854056818c040715bc16c6a602ecb591e855;hpb=485f531e502dcba5ee00641e3b64706a16e1b995;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/test.pl b/t/test.pl index 1562854..7d1a90b 100644 --- a/t/test.pl +++ b/t/test.pl @@ -20,10 +20,22 @@ $Level = 1; my $test = 1; my $planned; my $noplan; +my $Perl; # Safer version of $^X set by which_perl() $TODO = 0; $NO_ENDING = 0; +# Use this instead of print to avoid interference while testing globals. +sub _print { + local($\, $", $,) = (undef, ' ', ''); + print STDOUT @_; +} + +sub _print_stderr { + local($\, $", $,) = (undef, ' ', ''); + print STDERR @_; +} + sub plan { my $n; if (@_ == 1) { @@ -36,7 +48,7 @@ sub plan { my %plan = @_; $n = $plan{tests}; } - print STDOUT "1..$n\n" unless $noplan; + _print "1..$n\n" unless $noplan; $planned = $n; } @@ -44,10 +56,10 @@ END { my $ran = $test - 1; if (!$NO_ENDING) { if (defined $planned && $planned != $ran) { - print STDERR + _print_stderr "# Looks like you planned $planned tests but ran $ran.\n"; } elsif ($noplan) { - print "1..$ran\n"; + _print "1..$ran\n"; } } } @@ -58,9 +70,7 @@ sub _diag { return unless @_; my @mess = map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; - my $fh = $TODO ? *STDOUT : *STDERR; - print $fh @mess; - + $TODO ? _print(@mess) : _print_stderr(@mess); } sub diag { @@ -69,9 +79,9 @@ sub diag { sub skip_all { if (@_) { - print STDOUT "1..0 # Skipped: @_\n"; + _print "1..0 # Skip @_\n"; } else { - print STDOUT "1..0\n"; + _print "1..0\n"; } exit(0); } @@ -89,8 +99,8 @@ sub _ok { $out = $pass ? "ok $test" : "not ok $test"; } - $out .= " # TODO $TODO" if $TODO; - print STDOUT "$out\n"; + $out = $out . " # TODO $TODO" if $TODO; + _print "$out\n"; unless ($pass) { _diag "# Failed $where\n"; @@ -143,13 +153,13 @@ sub display { my $y = ''; foreach my $c (unpack("U*", $x)) { if ($c > 255) { - $y .= sprintf "\\x{%x}", $c; + $y = $y . sprintf "\\x{%x}", $c; } elsif ($backslash_escape{$c}) { - $y .= $backslash_escape{$c}; + $y = $y . $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; - $y .= $z; + $y = $y . $z; } } $x = $y; @@ -173,8 +183,8 @@ sub is ($$@) { } unless ($pass) { - unshift(@mess, "# got "._q($got)."\n", - "# expected "._q($expected)."\n"); + unshift(@mess, "# got "._qq($got)."\n", + "# expected "._qq($expected)."\n"); } _ok($pass, _where(), $name, @mess); } @@ -192,7 +202,7 @@ sub isnt ($$@) { } unless( $pass ) { - unshift(@mess, "# it should not be "._q($got)."\n", + unshift(@mess, "# it should not be "._qq($got)."\n", "# but it is.\n"); } _ok($pass, _where(), $name, @mess); @@ -219,8 +229,8 @@ sub cmp_ok ($$$@) { if ($got eq $expected and $type !~ tr/a-z//) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } - unshift(@mess, "# got "._q($got)."\n", - "# expected $type "._q($expected)."\n"); + unshift(@mess, "# got "._qq($got)."\n", + "# expected $type "._qq($expected)."\n"); } _ok($pass, _where(), $name, @mess); } @@ -256,8 +266,8 @@ sub within ($$$@) { if ($got eq $expected) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } - unshift@mess, "# got "._q($got)."\n", - "# expected "._q($expected)." (within "._q($range).")\n"; + unshift@mess, "# got "._qq($got)."\n", + "# expected "._qq($expected)." (within "._qq($range).")\n"; } _ok($pass, _where(), $name, @mess); } @@ -274,9 +284,10 @@ sub like_yn ($$$@) { $pass = $got !~ /$expected/ if $flip; unless ($pass) { unshift(@mess, "# got '$got'\n", - "# expected /$expected/\n"); + $flip + ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); } - local $Level = 2; + local $Level = $Level + 1; _ok($pass, _where(), $name, @mess); } @@ -294,7 +305,9 @@ sub curr_test { } sub next_test { + my $retval = $test; $test = $test + 1; # don't use ++ + $retval; } # Note: can't pass multipart messages since we try to @@ -303,7 +316,7 @@ sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "ok $test # skip: $why\n"; + _print "ok $test # skip $why\n"; $test = $test + 1; } local $^W = 0; @@ -315,7 +328,7 @@ sub todo_skip { my $n = @_ ? shift : 1; for (1..$n) { - print STDOUT "not ok $test # TODO & SKIP: $why\n"; + _print "not ok $test # TODO & SKIP $why\n"; $test = $test + 1; } local $^W = 0; @@ -342,12 +355,12 @@ sub eq_hash { $key = "" . $key; if (exists $orig->{$key}) { if ($orig->{$key} ne $value) { - print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}), + _print "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; } } else { - print STDOUT "# key ", _qq($key), " is ", _qq($value), + _print "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; $fail = 1; } @@ -356,7 +369,7 @@ sub eq_hash { # Force a hash recompute if this perl's internals can cache the hash key. $_ = "" . $_; next if (exists $suspect->{$_}); - print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; + _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; $fail = 1; } !$fail; @@ -392,8 +405,8 @@ USE_OK my $is_mswin = $^O eq 'MSWin32'; my $is_netware = $^O eq 'NetWare'; -my $is_macos = $^O eq 'MacOS'; my $is_vms = $^O eq 'VMS'; +my $is_cygwin = $^O eq 'cygwin'; sub _quote_args { my ($runperl, $args) = @_; @@ -402,32 +415,29 @@ sub _quote_args { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; - $$runperl .= ' ' . $_; + $runperl = $runperl . ' ' . $_; } + return $runperl; } sub _create_runperl { # Create the string to qx in runperl(). my %args = @_; - my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; + my $runperl = which_perl(); + if ($runperl =~ m/\s/) { + $runperl = qq{"$runperl"}; + } #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind if ($ENV{PERL_RUNPERL_DEBUG}) { $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; } unless ($args{nolib}) { - if ($is_macos) { - $runperl .= ' -I::lib'; - # Use UNIX style error messages instead of MPW style. - $runperl .= ' -MMac::err=unix' if $args{stderr}; - } - else { - $runperl .= ' "-I../lib"'; # doublequotes because of VMS - } + $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS } if ($args{switches}) { local $Level = 2; die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() unless ref $args{switches} eq "ARRAY"; - _quote_args(\$runperl, $args{switches}); + $runperl = _quote_args($runperl, $args{switches}); } if (defined $args{prog}) { die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() @@ -439,14 +449,14 @@ sub _create_runperl { # Create the string to qx in runperl(). unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { if ($is_mswin || $is_netware || $is_vms) { - $runperl .= qq ( -e "$prog" ); + $runperl = $runperl . qq ( -e "$prog" ); } else { - $runperl .= qq ( -e '$prog' ); + $runperl = $runperl . qq ( -e '$prog' ); } } } elsif (defined $args{progfile}) { - $runperl .= qq( "$args{progfile}"); + $runperl = $runperl . qq( "$args{progfile}"); } else { # You probaby didn't want to be sucking in from the upstream stdin die "test.pl:runperl(): none of prog, progs, progfile, args, " @@ -461,36 +471,22 @@ sub _create_runperl { # Create the string to qx in runperl(). $args{stdin} =~ s/\r/\\r/g; if ($is_mswin || $is_netware || $is_vms) { - $runperl = qq{$^X -e "print qq(} . + $runperl = qq{$Perl -e "print qq(} . $args{stdin} . q{)" | } . $runperl; } - elsif ($is_macos) { - # MacOS can only do two processes under MPW at once; - # the test itself is one; we can't do two more, so - # write to temp file - my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; - if ($args{verbose}) { - my $stdindisplay = $stdin; - $stdindisplay =~ s/\n/\n\#/g; - print STDERR "# $stdindisplay\n"; - } - `$stdin`; - $runperl .= q{ < teststdin }; - } else { - $runperl = qq{$^X -e 'print qq(} . + $runperl = qq{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } } if (defined $args{args}) { - _quote_args(\$runperl, $args{args}); + $runperl = _quote_args($runperl, $args{args}); } - $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; - $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; + $runperl = $runperl . ' 2>&1' if $args{stderr}; if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; - print STDERR "# $runperldisplay\n"; + _print_stderr "# $runperldisplay\n"; } return $runperl; } @@ -510,22 +506,23 @@ sub runperl { # run a fresh perl, so we'll brute force launder everything for you my $sep; - eval "require Config; Config->import"; - if ($@) { + if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $sep = ':'; } else { - $sep = $Config{path_sep}; + $sep = $Config::Config{path_sep}; } my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); local @ENV{@keys} = (); # Untaint, plus take out . and empty string: + local $ENV{'DCL$PATH'} = $1 if $is_vms && ($ENV{'DCL$PATH'} =~ /(.*)/s); $ENV{PATH} =~ /(.*)/s; local $ENV{PATH} = - join $sep, grep { $_ ne "" and $_ ne "." and - ($is_mswin or !(stat && (stat _)[2]&0022)) } + join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and + ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } split quotemeta ($sep), $1; + $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin $runperl =~ /(.*)/s; $runperl = $1; @@ -541,12 +538,11 @@ sub runperl { *run_perl = \&runperl; # Nice alias. sub DIE { - print STDERR "# @_\n"; + _print_stderr "# @_\n"; exit 1; } # A somewhat safer version of the sometimes wrong $^X. -my $Perl; sub which_perl { unless (defined $Perl) { $Perl = $^X; @@ -555,12 +551,11 @@ sub which_perl { return $Perl if $^O eq 'VMS'; my $exe; - eval "require Config; Config->import"; - if ($@) { + if (! eval 'require Config; 1') { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { - $exe = $Config{_exe}; + $exe = $Config::Config{_exe}; } $exe = '' unless defined $exe; @@ -570,8 +565,7 @@ sub which_perl { if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; - eval "require File::Spec"; - if ($@) { + if (! eval 'require File::Spec; 1') { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { @@ -583,7 +577,7 @@ sub which_perl { # the command. if ($Perl !~ /\Q$exe\E$/i) { - $Perl .= $exe; + $Perl = $Perl . $exe; } warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; @@ -597,14 +591,41 @@ sub which_perl { sub unlink_all { foreach my $file (@_) { 1 while unlink $file; - print STDERR "# Couldn't unlink '$file': $!\n" if -f $file; - } + _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; + } +} + +my %tmpfiles; +END { unlink_all keys %tmpfiles } + +# A regexp that matches the tempfile names +$::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); +sub tempfile { + my $count = 0; + do { + my $temp = $count; + my $try = "tmp$$"; + do { + $try = $try . $letters[$temp % 26]; + $temp = int ($temp / 26); + } while $temp; + # 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}) { + # 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$$'"; } - -my $tmpfile = "misctmp000"; -1 while -f ++$tmpfile; -END { unlink_all $tmpfile } +# This is the temporary file for _fresh_perl +my $tmpfile = tempfile(); # # _fresh_perl @@ -617,7 +638,14 @@ END { unlink_all $tmpfile } sub _fresh_perl { my($prog, $resolve, $runperl_args, $name) = @_; - $runperl_args ||= {}; + # Given the choice of the mis-parsable {} + # (we want an anon hash, but a borked lexer might think that it's a block) + # or relying on taking a reference to a lexical + # (\ might be mis-parsed, and the reference counting on the pad may go + # awry) + # 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; @@ -639,9 +667,9 @@ sub _fresh_perl { my $status = $?; # Clean up the results into something a bit more predictable. - $results =~ s/\n+$//; - $results =~ s/at\s+misctmp\d+\s+line/at - line/g; - $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; + $results =~ s/\n+$//; + $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; + $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. @@ -666,7 +694,7 @@ sub _fresh_perl { # Use the first line of the program as a name if none was given unless( $name ) { ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; - $name .= '...' if length $first_line > length $name; + $name = $name . '...' if length $first_line > length $name; } _ok($pass, _where(), "fresh_perl - $name"); @@ -680,6 +708,11 @@ sub _fresh_perl { sub fresh_perl_is { my($prog, $expected, $runperl_args, $name) = @_; + + # _fresh_perl() is going to clip the trailing newlines off the result. + # This will make it so the test author doesn't have to know that. + $expected =~ s/\n+$//; + local $Level = 2; _fresh_perl($prog, sub { @_ ? $_[0] eq $expected : $expected }, @@ -764,4 +797,135 @@ WHOA _ok( !$diag, _where(), $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. +sub watchdog ($) +{ + my $timeout = shift; + my $timeout_msg = 'Test process timed out - terminating'; + + my $pid_to_kill = $$; # PID for this process + + # Don't use a watchdog process if 'threads' is loaded - + # use a watchdog thread instead + if (! $threads::threads) { + + # On Windows and VMS, try launching a watchdog process + # using system(1, ...) (see perlport.pod) + if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { + # On Windows, try to get the 'real' PID + if ($^O eq 'MSWin32') { + eval { require Win32; }; + if (defined(&Win32::GetCurrentProcessId)) { + $pid_to_kill = Win32::GetCurrentProcessId(); + } + } + + # If we still have a fake PID, we can't use this method at all + return if ($pid_to_kill <= 0); + + # Launch watchdog process + my $watchdog; + eval { + local $SIG{'__WARN__'} = sub { + _diag("Watchdog warning: $_[0]"); + }; + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + my $cmd = _create_runperl( prog => "sleep($timeout);" . + "warn qq/# $timeout_msg" . '\n/;' . + "kill($sig, $pid_to_kill);"); + $watchdog = system(1, $cmd); + }; + if ($@ || ($watchdog <= 0)) { + _diag('Failed to start watchdog'); + _diag($@) if $@; + undef($watchdog); + return; + } + + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + # Try using fork() to generate a watchdog process + my $watchdog; + eval { $watchdog = fork() }; + if (defined($watchdog)) { + if ($watchdog) { # Parent process + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + ### Watchdog process code + + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 + sleep(2); + + # Kill test process if still running + if (kill(0, $pid_to_kill)) { + _diag($timeout_msg); + kill('KILL', $pid_to_kill); + } + + # Don't execute END block (added at beginning of this file) + $NO_ENDING = 1; + + # Terminate ourself (i.e., the watchdog) + POSIX::_exit(1) if (defined(&POSIX::_exit)); + exit(1); + } + + # fork() failed - fall through and try using a thread + } + + # Use a watchdog thread because either 'threads' is loaded, + # or fork() failed + if (eval 'require threads; 1') { + threads->create(sub { + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + my $time_left = $timeout; + do { + $time_left = $time_left - sleep($time_left); + } while ($time_left > 0); + + # Kill the parent (and ourself) + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + })->detach(); + return; + } + + # If everything above fails, then just use an alarm timeout + if (eval { alarm($timeout); 1; }) { + # Load POSIX if available + eval { require POSIX; }; + + # Alarm handler will do the actual 'killing' + $SIG{'ALRM'} = sub { + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + }; + } +} + 1;