X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Ftest.pl;h=32c4a374e5dfeaca47821909207f4c5b2e5f6b40;hb=0e945d0082cb70df3b6da49ba9241db5ee15f208;hp=d697f77789c518b95c68c2986586e1bc0d5e9e25;hpb=44826442183f4168cc7d203064d184977258d097;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/test.pl b/t/test.pl
index d697f77..32c4a37 100644
--- a/t/test.pl
+++ b/t/test.pl
@@ -20,6 +20,7 @@ $Level = 1;
 my $test = 1;
 my $planned;
 my $noplan;
+my $Perl;       # Safer version of $^X set by which_perl()
 
 $TODO = 0;
 $NO_ENDING = 0;
@@ -78,7 +79,7 @@ sub diag {
 
 sub skip_all {
     if (@_) {
-	_print "1..0 # Skipped: @_\n";
+        _print "1..0 # Skip @_\n";
     } else {
 	_print "1..0\n";
     }
@@ -315,7 +316,7 @@ sub skip {
     my $why = shift;
     my $n    = @_ ? shift : 1;
     for (1..$n) {
-        _print "ok $test # skip: $why\n";
+        _print "ok $test # skip $why\n";
         $test = $test + 1;
     }
     local $^W = 0;
@@ -327,7 +328,7 @@ sub todo_skip {
     my $n   = @_ ? shift : 1;
 
     for (1..$n) {
-        _print "not ok $test # TODO & SKIP: $why\n";
+        _print "not ok $test # TODO & SKIP $why\n";
         $test = $test + 1;
     }
     local $^W = 0;
@@ -421,7 +422,10 @@ sub _quote_args {
 
 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";
@@ -474,14 +478,14 @@ 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; };
+	    my $stdin = qq{$Perl -e 'print qq(} . $args{stdin} . qq{)' > teststdin; };
 	    if ($args{verbose}) {
 		my $stdindisplay = $stdin;
 		$stdindisplay =~ s/\n/\n\#/g;
@@ -491,7 +495,7 @@ sub _create_runperl { # Create the string to qx in runperl().
 	    $runperl .= q{ < teststdin };
 	}
 	else {
-	    $runperl = qq{$^X -e 'print qq(} .
+	    $runperl = qq{$Perl -e 'print qq(} .
 		$args{stdin} . q{)' | } . $runperl;
 	}
     }
@@ -523,12 +527,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);
@@ -561,7 +564,6 @@ sub DIE {
 }
 
 # A somewhat safer version of the sometimes wrong $^X.
-my $Perl;
 sub which_perl {
     unless (defined $Perl) {
 	$Perl = $^X;
@@ -570,12 +572,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;
 
@@ -585,8 +586,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 {
@@ -616,10 +616,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
@@ -655,8 +682,8 @@ sub _fresh_perl {
 
     # 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/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'.
@@ -780,6 +807,8 @@ WHOA
 }
 
 # 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;
@@ -787,96 +816,123 @@ sub watchdog ($)
 
     my $pid_to_kill = $$;   # PID for this process
 
-    # 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();
+    # 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 {};
-            $watchdog = system(1, $^X, '-e', "sleep($timeout);" .
-                                             "kill('KILL', $pid_to_kill);");
-        };
+            # 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';
+                $watchdog = system(1, which_perl(), '-e',
+                                                    "sleep($timeout);" .
+                                                    "warn('# $timeout_msg\n');" .
+                                                    "kill($sig, $pid_to_kill);");
+            };
+            if ($@ || ($watchdog <= 0)) {
+                _diag('Failed to start watchdog');
+                _diag($@) if $@;
+                undef($watchdog);
+                return;
+            }
 
-        # If the above worked, add END block to parent
-        #   to clean up watchdog process
-        if (! $@ && ($watchdog > 0)) {
-            eval "END { kill('KILL', $watchdog); }";
+            # Add END block to parent to terminate and
+            #   clean up watchdog process
+            eval "END { local \$! = 0; local \$? = 0;
+                        wait() if kill('KILL', $watchdog); };";
+            return;
         }
-        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
 
-    # 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 clean up watchdog process
-            eval "END { kill('KILL', $watchdog); }";
-            return;
-        }
+            # Load POSIX if available
+            eval { require POSIX; };
 
-        ### Watchdog process code
+            # Execute the timeout
+            sleep($timeout - 2) if ($timeout > 2);   # Workaround for perlbug #49073
+            sleep(2);
 
-        # Load POSIX if available
-        eval { require POSIX; };
+            # Kill test process if still running
+            if (kill(0, $pid_to_kill)) {
+                _diag($timeout_msg);
+                kill('KILL', $pid_to_kill);
+            }
 
-        # Execute the timeout
-        sleep($timeout - 2) if ($timeout > 2);   # Workaround for perlbug #49073
-        sleep(2);
+            # Don't execute END block (added at beginning of this file)
+            $NO_ENDING = 1;
 
-        # Kill test process if still running
-        if (kill(0, $pid_to_kill)) {
-            _diag($timeout_msg);
-            kill('KILL', $pid_to_kill);
+            # Terminate ourself (i.e., the watchdog)
+            POSIX::_exit(1) if (defined(&POSIX::_exit));
+            exit(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
     }
 
-    # fork() failed - try a thread
-    if (eval { require threads; }) {
+    # 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
-                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;
     }
 
-    # Threads failed, too - try use alarm()
-
-    # Try to set the timeout
+    # 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));
-            kill('KILL', $pid_to_kill);
+            my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
+            kill($sig, $pid_to_kill);
         };
     }
 }