X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=830223677b74f9348af4e3fc9e256fa3cef8691a;hb=3fd969f44926f311e1c67d9470a9e936f7af2d73;hp=3aeb843c975aca4db400fe4f55e36e49f74235d2;hpb=2d4a14fe014e68c025e5bc1de990575528c46d6f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/test.pl b/t/test.pl index 3aeb843..8302236 100644 --- a/t/test.pl +++ b/t/test.pl @@ -183,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); } @@ -202,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); @@ -229,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); } @@ -266,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); } @@ -405,7 +405,6 @@ 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'; @@ -431,14 +430,7 @@ sub _create_runperl { # Create the string to qx in runperl(). $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 .= ' "-I../lib"'; # doublequotes because of VMS } if ($args{switches}) { local $Level = 2; @@ -481,19 +473,6 @@ sub _create_runperl { # Create the string to qx in runperl(). $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{$Perl -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{$Perl -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; @@ -502,8 +481,7 @@ sub _create_runperl { # Create the string to qx in runperl(). if (defined $args{args}) { _quote_args(\$runperl, $args{args}); } - $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; - $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; + $runperl .= ' 2>&1' if $args{stderr}; if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; @@ -527,12 +505,11 @@ 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); @@ -573,12 +550,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; @@ -588,8 +564,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 { @@ -619,10 +594,37 @@ sub unlink_all { } } +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 .= $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}++; + 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 @@ -657,9 +659,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'. @@ -698,6 +700,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 }, @@ -816,10 +823,11 @@ sub watchdog ($) local $SIG{'__WARN__'} = sub { _diag("Watchdog warning: $_[0]"); }; + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; $watchdog = system(1, which_perl(), '-e', "sleep($timeout);" . "warn('# $timeout_msg\n');" . - "kill('KILL', $pid_to_kill);"); + "kill($sig, $pid_to_kill);"); }; if ($@ || ($watchdog <= 0)) { _diag('Failed to start watchdog'); @@ -875,19 +883,23 @@ sub watchdog ($) # Use a watchdog thread because either 'threads' is loaded, # or fork() failed - if (eval { require threads; }) { + if (eval 'require threads; 1') { threads->create(sub { # Load POSIX if available eval { require POSIX; }; # Execute the timeout - sleep($timeout); + my $time_left = $timeout; + do { + $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)); - kill('KILL', $pid_to_kill); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); })->detach(); return; } @@ -902,7 +914,8 @@ sub watchdog ($) select(STDERR); $| = 1; _diag($timeout_msg); POSIX::_exit(1) if (defined(&POSIX::_exit)); - kill('KILL', $pid_to_kill); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); }; } }