[win32] merge changes#982,984 from maintbranch

p4raw-link: @984 on //depot/maint-5.004/perl: aaffd3c27a04135bbc287616252cc5830b7c5543
p4raw-link: @982 on //depot/maint-5.004/perl: c5ed518aab0e5c6006080a87273e79a1b8e0d48b

p4raw-id: //depot/win32/perl@997

10 files changed, 147 insertions, 37 deletions

diff --git a/gv.c b/gv.c
index 5d65d60e64..b48e4d8ede 100644
--- a/gv.c
+++ b/gv.c
@@ -712,7 +712,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
     case '!':
 	if(len > 1)
 	    break;
-	if(sv_type == SVt_PVHV) {
+	if(sv_type > SVt_PV) {
 	    HV* stash = gv_stashpvn("Errno",5,FALSE);
 	    if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 		dSP;
@@ -721,7 +721,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
 		SPAGAIN;
 		stash = gv_stashpvn("Errno",5,FALSE);
 		if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
-		    croak("%! is not avaliable on this machine");
+		    croak("Can't use %%! because Errno.pm is not avaliable");
 	    }
 	}
 	goto magicalize;
diff --git a/lib/English.pm b/lib/English.pm
index bbb6bd7b28..1cbacd11f8 100644
--- a/lib/English.pm
+++ b/lib/English.pm
@@ -137,8 +137,8 @@ sub import {
 # Error status.
 
 	*CHILD_ERROR				= *?	;
-	*OS_ERROR				= *!	;
-	    *ERRNO				= *!	;
+	*OS_ERROR				= \$!	;
+	    *ERRNO				= \$!	;
 	*EXTENDED_OS_ERROR			= *^E	;
 	*EVAL_ERROR				= *@	;
 
diff --git a/perl.c b/perl.c
index f4338b165e..dbe06dd933 100644
--- a/perl.c
+++ b/perl.c
@@ -937,6 +937,9 @@ print \"  \\@INC:\\n    @INC\\n\";");
 #endif
 
     init_predump_symbols();
+    /* init_postdump_symbols not currently designed to be called */
+    /* more than once (ENV isn't cleared first, for example)	 */
+    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
     if (!do_undump)
 	init_postdump_symbols(argc,argv,env);
 
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 617879852c..28a3ba152d 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2998,9 +2998,10 @@ function, or use this relation:
 =item sleep
 
 Causes the script to sleep for EXPR seconds, or forever if no EXPR.
-May be interrupted by sending the process a SIGALRM.  Returns the
-number of seconds actually slept.  You probably cannot mix alarm() and
-sleep() calls, because sleep() is often implemented using alarm().
+May be interrupted if the process receives a signal such as SIGALRM.
+Returns the number of seconds actually slept.  You probably cannot
+mix alarm() and sleep() calls, because sleep() is often implemented
+using alarm().
 
 On some older systems, it may sleep up to a full second less than what
 you requested, depending on how it counts seconds.  Most modern systems
@@ -3038,9 +3039,10 @@ specified, it gives the name of a subroutine that returns an integer
 less than, equal to, or greater than 0, depending on how the elements
 of the array are to be ordered.  (The C<E<lt>=E<gt>> and C<cmp>
 operators are extremely useful in such routines.)  SUBNAME may be a
-scalar variable name, in which case the value provides the name of the
-subroutine to use.  In place of a SUBNAME, you can provide a BLOCK as
-an anonymous, in-line sort subroutine.
+scalar variable name (unsubscripted), in which case the value provides
+the name of (or a reference to) the actual subroutine to use.  In place
+of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort
+subroutine.
 
 In the interests of efficiency the normal calling code for subroutines is
 bypassed, with the following effects: the subroutine may not be a
@@ -3676,7 +3678,7 @@ signals and core dumps.
 	# forked, so the errno value is not visible in the parent.
 	printf "command failed: %s\n", ($! || "Unknown system() error");
     }
-    elsif ($rc > 0x80) {
+    elsif (($rc & 0xff) == 0) {
 	$rc >>= 8;
 	print "ran with non-zero exit status $rc\n";
     }
diff --git a/t/io/pipe.t b/t/io/pipe.t
index 0387e556ca..4a7cb7a423 100755
--- a/t/io/pipe.t
+++ b/t/io/pipe.t
@@ -13,7 +13,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..10\n";
+print "1..12\n";
 
 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
 print PIPE "Xk 1\n";
@@ -25,6 +25,7 @@ if (open(PIPE, "-|")) {
 	s/^not //;
 	print;
     }
+    close PIPE;        # avoid zombies which disrupt test 12
 }
 else {
     print STDOUT "not ok 3\n";
@@ -40,6 +41,7 @@ if ($pid = fork) {
 	y/A-Z/a-z/;
 	print;
     }
+    close READER;     # avoid zombies which disrupt test 12
 }
 else {
     die "Couldn't fork" unless defined $pid;
@@ -66,11 +68,13 @@ sleep 1;
 print "ok 8\n";
 
 # VMS doesn't like spawning subprocesses that are still connected to
-# STDOUT.  Someone should modify tests #9 and #10 to work with VMS.
+# STDOUT.  Someone should modify tests #9 to #12 to work with VMS.
 
 if ($^O eq 'VMS') {
     print "ok 9\n";
     print "ok 10\n";
+    print "ok 11\n";
+    print "ok 12\n";
     exit;
 }
 
@@ -109,3 +113,21 @@ elsif ($? == 0) {
 else {
     print "ok 10\n";
 }
+
+# check that status for the correct process is collected
+my $zombie = fork or exit 37;
+my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
+$SIG{ALRM} = sub { return };
+alarm(1);
+my $close = close FH;
+if ($? == 13*256 && ! length $close && ! $!) {
+    print "ok 11\n";
+} else {
+    print "not ok 11\n# close $close\$?=$?   \$!=", $!+0, ":$!\n";
+};
+my $wait = wait;
+if ($? == 37*256 && $wait == $zombie && ! $!) {
+    print "ok 12\n";
+} else {
+    print "not ok 12\n# pid=$wait   \$?=$?   \$!=", $!+0, ":$!\n";
+}
diff --git a/t/op/exec.t b/t/op/exec.t
index 7dfcd6177f..506fc09fbd 100755
--- a/t/op/exec.t
+++ b/t/op/exec.t
@@ -6,6 +6,7 @@ $| = 1;				# flush stdout
 
 if ($^O eq 'MSWin32') {
     print "# exec is unsupported on Win32\n";
+    # XXX the system tests could be written to use ./perl and so work on Win32
     print "1..0\n";
     exit(0);
 }
@@ -16,6 +17,7 @@ print "not ok 1\n" if system "echo ok \\1";	# shell interpreted
 print "not ok 2\n" if system "echo ok 2";	# split and directly called
 print "not ok 3\n" if system "echo", "ok", "3"; # directly called
 
+# these should probably be rewritten to match the examples in perlfunc.pod
 if (system "true") {print "not ok 4\n";} else {print "ok 4\n";}
 
 if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; }
diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t
index f3f6e3ce4c..73b8a8f351 100755
--- a/t/op/ipcsem.t
+++ b/t/op/ipcsem.t
@@ -30,12 +30,15 @@ BEGIN {
 	print "1..0\n";
 	exit;
     }
+
+    use strict;
+
     my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth}));
     my %done = ();
     my %define = ();
 
     sub process_file {
-	my($file) = @_;
+	my($file,$level) = @_;
 
 	return unless defined $file;
 
@@ -51,40 +54,55 @@ BEGIN {
 	return if exists $done{$path};
 	$done{$path} = 1;
 
-	unless(defined $path) {
+	if(not defined $path and $level == 0) {
 	    warn "Cannot find '$file'";
 	    return;
 	}
 
+	local(*F);
 	open(F,$path) or return;
+        $level = 1 unless defined $level;
+	my $indent = " " x $level;
+	print "#$indent open $path\n";
 	while(<F>) {
 	    s#/\*.*(\*/|$)##;
 
-	    process_file($mm,$1)
-		    if /^#\s*include\s*[<"]([^>"]+)[>"]/;
+	    if ( /^#\s*include\s*[<"]([^>"]+)[>"]/ ) {
+	        print "#${indent} include $1\n";
+		process_file($1,$level+1);
+	        print "#${indent} done include $1\n";
+	        print "#${indent} back in $path\n";
+	    }
 
 	    s/(?:\([^)]*\)\s*)//;
 
-	    $define{$1} = $2
-		if /^#\s*define\s+(\w+)\s+((0x)?\d+|\w+)/;
+	    if ( /^#\s*define\s+(\w+)\s+(\w+)/ ) {
+	        print "#${indent} define $1 $2\n";
+		$define{$1} = $2;
+	    }
        }
        close(F);
+       print "#$indent close $path\n";
     }
 
     process_file("sys/sem.h");
     process_file("sys/ipc.h");
     process_file("sys/stat.h");
 
-    foreach $d (@define) {
+    foreach my $d (@define) {
 	while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) {
 	    $define{$d} = exists $define{$define{$d}}
 		    ? $define{$define{$d}} : undef;
 	}
 	unless(defined $define{$d}) {
-	    print "0..0\n";
+	    print "# $d undefined\n";
+	    print "1..0\n";
 	    exit;
-	};
-	${ $d } = eval $define{$d};
+	}
+	{
+	    no strict 'refs';
+	    ${ $d } = eval $define{$d};
+        }
     }
 }
 
diff --git a/util.c b/util.c
index 22af92170b..2db504a10d 100644
--- a/util.c
+++ b/util.c
@@ -2086,6 +2086,7 @@ my_pclose(PerlIO *ptr)
     int status;
     SV **svp;
     int pid;
+    int pid2;
     bool close_failed;
     int saved_errno;
 #ifdef VMS
@@ -2120,8 +2121,8 @@ my_pclose(PerlIO *ptr)
     rsignal_save(SIGINT, SIG_IGN, &istat);
     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
     do {
-	pid = wait4pid(pid, &status, 0);
-    } while (pid == -1 && errno == EINTR);
+	pid2 = wait4pid(pid, &status, 0);
+    } while (pid2 == -1 && errno == EINTR);
     rsignal_restore(SIGHUP, &hstat);
     rsignal_restore(SIGINT, &istat);
     rsignal_restore(SIGQUIT, &qstat);
@@ -2129,7 +2130,7 @@ my_pclose(PerlIO *ptr)
 	SETERRNO(saved_errno, saved_vaxc_errno);
 	return -1;
     }
-    return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
+    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
 #endif /* !DOSISH */
 
diff --git a/utils/h2ph.PL b/utils/h2ph.PL
index 2c685e0383..730c2259e7 100644
--- a/utils/h2ph.PL
+++ b/utils/h2ph.PL
@@ -38,7 +38,9 @@ use Config;
 use File::Path qw(mkpath);
 use Getopt::Std;
 
-getopts('Dd:rlh');
+getopts('Dd:rlha');
+die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
+@inc_dirs = inc_dirs() if $opt_a;
 
 my $Exit = 0;
 
@@ -82,6 +84,14 @@ while (defined ($file = next_file())) {
 	    $dir = $1;
 	    mkpath "$Dest_dir/$dir";
 	}
+
+	if ($opt_a) { # automagic mode:  locate header file in @inc_dirs
+	    foreach (@inc_dirs) {
+		chdir $_;
+		last if -f $file;
+	    }
+	}
+
 	open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
 	open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
     }
@@ -240,6 +250,9 @@ while (defined ($file = next_file())) {
 	}
     }
     print OUT "1;\n";
+
+    $is_converted{$file} = 1;
+    queue_includes_from($file) if ($opt_a);
 }
 
 exit $Exit;
@@ -380,7 +393,9 @@ sub next_file
             } else {
                 print STDERR "Skipping directory `$file'\n";
             }
-	} else {
+        } elsif ($opt_a) {
+            return $file;
+        } else {
             print STDERR "Skipping `$file':  not a file or directory\n";
         }
     }
@@ -402,11 +417,8 @@ sub expand_glob
 
             # expand_glob() is going to be called until $ARGV[0] isn't a
             # directory; so push directories, and unshift everything else.
-            if (-d "$directory/$_") {
-		push    @ARGV, "$directory/$_";
-	    } else {
-		unshift @ARGV, "$directory/$_";
-	    }
+            if (-d "$directory/$_") { push    @ARGV, "$directory/$_" }
+            else                    { unshift @ARGV, "$directory/$_" }
         }
     closedir DIR;
 }
@@ -431,12 +443,13 @@ sub link_if_possible
             unlink "$Dest_dir/$dirlink" or
                 print STDERR "Could not remove link $Dest_dir/$dirlink:  $!\n";
         }
+
         if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
             print "Linking $target -> $Dest_dir/$dirlink\n";
 
             # Make sure that the link _links_ to something:
             if (! -e "$Dest_dir/$target") {
-                mkdir("$Dest_dir/$target", 0755) or
+                mkpath("$Dest_dir/$target", 0755) or
                     print STDERR "Could not create $Dest_dir/$target/\n";
             }
         } else {
@@ -446,6 +459,41 @@ sub link_if_possible
 }
 
 
+# Push all #included files in $file onto our stack, except for STDIN
+# and files we've already processed.
+sub queue_includes_from
+{
+    my ($file)    = @_;
+    my $line;
+
+    return if ($file eq "-");
+
+    open HEADER, $file or return;
+        while (defined($line = <HEADER>)) {
+            while (/\\$/) { # Handle continuation lines
+                chop $line;
+                $line .= <HEADER>;
+            }
+
+            if ($line =~ /^#\s*include\s+<(.*?)>/) {
+                push(@ARGV, $1) unless $is_converted{$1};
+            }
+        }
+    close HEADER;
+}
+
+
+# Determine include directories; $Config{usrinc} should be enough for (all
+# non-GCC?) C compilers, but gcc uses an additional include directory.
+sub inc_dirs
+{
+    my $from_gcc    = `$Config{cc} -v 2>&1`;
+    $from_gcc       =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
+
+    length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
+}
+
+
 1;
 
 ##############################################################################
@@ -457,7 +505,7 @@ h2ph - convert .h C header files to .ph Perl header files
 
 =head1 SYNOPSIS
 
-B<h2ph [-d destination directory] [-r] [-l] [headerfiles]>
+B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
 
 =head1 DESCRIPTION
 
@@ -490,7 +538,15 @@ beneath the default Perl library location (C<$Config{'installsitsearch'}>).
 =item -r
 
 Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
-on all files in those directories (and their subdirectories, etc.).
+on all files in those directories (and their subdirectories, etc.).  B<-r>
+and B<-a> are mutually exclusive.
+
+=item -a
+
+Run automagically; convert B<headerfiles>, as well as any B<.h> files
+which they include.  This option will search for B<.h> files in all
+directories which your C compiler ordinarily uses.  B<-a> and B<-r> are
+mutually exclusive.
 
 =item -l
 
@@ -511,6 +567,11 @@ you will see the slightly more helpful
 
 However, the B<.ph> files almost double in size when built using B<-h>.
 
+=item -D
+
+Include the code from the B<.h> file as a comment in the B<.ph> file.
+This is primarily used for debugging I<h2ph>.
+
 =back
 
 =head1 ENVIRONMENT
diff --git a/utils/h2xs.PL b/utils/h2xs.PL
index 800329103a..97d3ceded3 100644
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -486,6 +486,7 @@ sub AUTOLOAD {
 
     my \$constname;
     (\$constname = \$AUTOLOAD) =~ s/.*:://;
+    croak "&$module::constant not defined" if \$constname eq 'constant';
     my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
     if (\$! != 0) {
 	if (\$! =~ /Invalid/) {
@@ -496,7 +497,7 @@ sub AUTOLOAD {
 		croak "Your vendor has not defined $module macro \$constname";
 	}
     }
-    eval "sub \$AUTOLOAD { \$val }";
+    *\$AUTOLOAD = sub () { \$val };
     goto &\$AUTOLOAD;
 }