Well defined $? and introduction of ${^CHILD_ERROR_NATIVE} [PATCH]

Message-ID: <lr8y2cim24.fsf_-_@caliper.activestate.com>

p4raw-id: //depot/perl@24501

12 files changed, 118 insertions, 39 deletions

diff --git a/doio.c b/doio.c
index 224f72d64f..e09ef641bb 100644
--- a/doio.c
+++ b/doio.c
@@ -1046,7 +1046,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
 	    const int status = PerlProc_pclose(IoIFP(io));
 	    if (not_implicit) {
 		STATUS_NATIVE_SET(status);
-		retval = (STATUS_POSIX == 0);
+		retval = (STATUS_UNIX == 0);
 	    }
 	    else {
 		retval = (status != -1);
diff --git a/embedvar.h b/embedvar.h
index 60c5d27a4d..760a53f4fd 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -386,6 +386,7 @@
 #define PL_srand_called		(vTHX->Isrand_called)
 #define PL_stashcache		(vTHX->Istashcache)
 #define PL_statusvalue		(vTHX->Istatusvalue)
+#define PL_statusvalue_posix	(vTHX->Istatusvalue_posix)
 #define PL_statusvalue_vms	(vTHX->Istatusvalue_vms)
 #define PL_stderrgv		(vTHX->Istderrgv)
 #define PL_stdingv		(vTHX->Istdingv)
@@ -693,6 +694,7 @@
 #define PL_Isrand_called	PL_srand_called
 #define PL_Istashcache		PL_stashcache
 #define PL_Istatusvalue		PL_statusvalue
+#define PL_Istatusvalue_posix	PL_statusvalue_posix
 #define PL_Istatusvalue_vms	PL_statusvalue_vms
 #define PL_Istderrgv		PL_stderrgv
 #define PL_Istdingv		PL_stdingv
diff --git a/gv.c b/gv.c
index 7d3eccbf9d..0b31ae999e 100644
--- a/gv.c
+++ b/gv.c
@@ -932,6 +932,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		if (strEQ(name2, "ERSION"))
 		    GvMULTI_on(gv);
 		break;
+            case '\003':        /* $^CHILD_ERROR_NATIVE */
+		if (strEQ(name2, "HILD_ERROR_NATIVE"))
+		    goto magicalize;
+		break;
 	    case '\005':	/* $^ENCODING */
 		if (strEQ(name2, "NCODING"))
 		    goto magicalize;
diff --git a/intrpvar.h b/intrpvar.h
index ab08e054cb..c879e9edd0 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -74,6 +74,8 @@ PERLVAR(Istatusvalue,	I32)		/* $? */
 PERLVAR(Iexit_flags,	U8)		/* was exit() unexpected, etc. */
 #ifdef VMS
 PERLVAR(Istatusvalue_vms,U32)
+#else
+PERLVAR(Istatusvalue_posix,I32)
 #endif
 
 /* shortcuts to various I/O objects */
diff --git a/mg.c b/mg.c
index 359b8ca994..baad04f718 100644
--- a/mg.c
+++ b/mg.c
@@ -581,8 +581,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '\001':		/* ^A */
 	sv_setsv(sv, PL_bodytarget);
 	break;
-    case '\003':		/* ^C */
-	sv_setiv(sv, (IV)PL_minus_c);
+    case '\003':		/* ^C, ^CHILD_ERROR_NATIVE */
+	if (*(mg->mg_ptr+1) == '\0') {
+	    sv_setiv(sv, (IV)PL_minus_c);
+	}
+	else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
+	    sv_setiv(sv, (IV)STATUS_NATIVE);
+        }
 	break;
 
     case '\004':		/* ^D */
@@ -2291,7 +2296,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
 	else
 #endif
-	    STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+	    STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 	break;
     case '!':
         {
diff --git a/perl.c b/perl.c
index 66d5e1dc51..5f38e64363 100644
--- a/perl.c
+++ b/perl.c
@@ -4806,13 +4806,13 @@ Perl_my_failure_exit(pTHX)
 #else
     int exitstatus;
     if (errno & 255)
-	STATUS_POSIX_SET(errno);
+	STATUS_UNIX_SET(errno);
     else {
-	exitstatus = STATUS_POSIX >> 8;
+	exitstatus = STATUS_UNIX >> 8;
 	if (exitstatus & 255)
-	    STATUS_POSIX_SET(exitstatus);
+	    STATUS_UNIX_SET(exitstatus);
 	else
-	    STATUS_POSIX_SET(255);
+	    STATUS_UNIX_SET(255);
     }
 #endif
     my_exit_jump();
diff --git a/perl.h b/perl.h
index cb64a6e0ee..1a2145c0f9 100644
--- a/perl.h
+++ b/perl.h
@@ -2414,6 +2414,7 @@ typedef pthread_key_t	perl_key;
 #  include "netware.h"
 #endif
 
+#define STATUS_UNIX	PL_statusvalue
 #ifdef VMS
 #   define STATUS_NATIVE	PL_statusvalue_vms
 #   define STATUS_NATIVE_EXPORT \
@@ -2430,13 +2431,12 @@ typedef pthread_key_t	perl_key;
 	    else							\
 		PL_statusvalue = (PL_statusvalue_vms & STS$M_SEVERITY) << 8;	\
 	} STMT_END
-#   define STATUS_POSIX	PL_statusvalue
 #   ifdef VMSISH_STATUS
-#	define STATUS_CURRENT	(VMSISH_STATUS ? STATUS_NATIVE : STATUS_POSIX)
+#	define STATUS_CURRENT	(VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX)
 #   else
-#	define STATUS_CURRENT	STATUS_POSIX
+#	define STATUS_CURRENT	STATUS_UNIX
 #   endif
-#   define STATUS_POSIX_SET(n)				\
+#   define STATUS_UNIX_SET(n)				\
 	STMT_START {					\
 	    PL_statusvalue = (n);				\
 	    if (PL_statusvalue != -1) {			\
@@ -2448,19 +2448,55 @@ typedef pthread_key_t	perl_key;
 #   define STATUS_ALL_SUCCESS	(PL_statusvalue = 0, PL_statusvalue_vms = 1)
 #   define STATUS_ALL_FAILURE	(PL_statusvalue = 1, PL_statusvalue_vms = 44)
 #else
-#   define STATUS_NATIVE	STATUS_POSIX
-#   define STATUS_NATIVE_EXPORT	STATUS_POSIX
-#   define STATUS_NATIVE_SET	STATUS_POSIX_SET
-#   define STATUS_POSIX		PL_statusvalue
-#   define STATUS_POSIX_SET(n)		\
+#   define STATUS_NATIVE	PL_statusvalue_posix
+#   define STATUS_NATIVE_EXPORT	STATUS_NATIVE
+#   if defined(WCOREDUMP)
+#       define STATUS_NATIVE_SET(n)                        \
+            STMT_START {                                   \
+                PL_statusvalue_posix = (n);                \
+                if (PL_statusvalue_posix == -1)            \
+                    PL_statusvalue = -1;                   \
+                else {                                     \
+                    PL_statusvalue =                       \
+                        (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) |  \
+                        (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0) | \
+                        (WIFSIGNALED(PL_statusvalue_posix) && WCOREDUMP(PL_statusvalue_posix) ? 0x80 : 0);  \
+                }                                          \
+            } STMT_END
+#   elif defined(WIFEXITED)
+#       define STATUS_NATIVE_SET(n)                        \
+            STMT_START {                                   \
+                PL_statusvalue_posix = (n);                \
+                if (PL_statusvalue_posix == -1)            \
+                    PL_statusvalue = -1;                   \
+                else {                                     \
+                    PL_statusvalue =                       \
+                        (WIFEXITED(PL_statusvalue_posix) ? (WEXITSTATUS(PL_statusvalue_posix) << 8) : 0) |  \
+                        (WIFSIGNALED(PL_statusvalue_posix) ? (WTERMSIG(PL_statusvalue_posix) & 0x7F) : 0);  \
+                }                                          \
+            } STMT_END
+#   else
+#       define STATUS_NATIVE_SET(n)                        \
+            STMT_START {                                   \
+                PL_statusvalue_posix = (n);                \
+                if (PL_statusvalue_posix == -1)            \
+                    PL_statusvalue = -1;                   \
+                else {                                     \
+                    PL_statusvalue =                       \
+                        PL_statusvalue_posix & 0xFFFF;     \
+                }                                          \
+            } STMT_END
+#   endif
+#   define STATUS_UNIX_SET(n)		\
 	STMT_START {			\
 	    PL_statusvalue = (n);		\
+            PL_statusvalue_posix = PL_statusvalue;       \
 	    if (PL_statusvalue != -1)	\
 		PL_statusvalue &= 0xFFFF;	\
 	} STMT_END
-#   define STATUS_CURRENT STATUS_POSIX
-#   define STATUS_ALL_SUCCESS	(PL_statusvalue = 0)
-#   define STATUS_ALL_FAILURE	(PL_statusvalue = 1)
+#   define STATUS_CURRENT STATUS_UNIX
+#   define STATUS_ALL_SUCCESS	(PL_statusvalue = 0, PL_statusvalue_posix = 0)
+#   define STATUS_ALL_FAILURE	(PL_statusvalue = 1, PL_statusvalue_posix = 1)
 #endif
 
 /* flags in PL_exit_flags for nature of exit() */
diff --git a/perlapi.h b/perlapi.h
index 6ae40a2efe..46177d26aa 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -551,6 +551,8 @@ END_EXTERN_C
 #define PL_stashcache		(*Perl_Istashcache_ptr(aTHX))
 #undef  PL_statusvalue
 #define PL_statusvalue		(*Perl_Istatusvalue_ptr(aTHX))
+#undef  PL_statusvalue_posix
+#define PL_statusvalue_posix	(*Perl_Istatusvalue_posix_ptr(aTHX))
 #undef  PL_statusvalue_vms
 #define PL_statusvalue_vms	(*Perl_Istatusvalue_vms_ptr(aTHX))
 #undef  PL_stderrgv
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index a428b5f655..5414e324d4 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -782,7 +782,8 @@ program exits with non-zero status.  (If the only problem was that the
 program exited non-zero, C<$!> will be set to C<0>.)  Closing a pipe
 also waits for the process executing on the pipe to complete, in case you
 want to look at the output of the pipe afterwards, and
-implicitly puts the exit status value of that command into C<$?>.
+implicitly puts the exit status value of that command into C<$?> and
+C<${^CHILD_ERROR_NATIVE}>.
 
 Prematurely closing the read end of a pipe (i.e. before the process
 writing to it at the other end has closed it) will result in a
@@ -3126,7 +3127,8 @@ be set for the newly opened file descriptor as determined by the value
 of $^F.  See L<perlvar/$^F>.
 
 Closing any piped filehandle causes the parent process to wait for the
-child to finish, and returns the status value in C<$?>.
+child to finish, and returns the status value in C<$?> and
+C<${^CHILD_ERROR_NATIVE}>.
 
 The filename passed to 2-argument (or 1-argument) form of open() will
 have leading and trailing whitespace deleted, and the normal
@@ -5975,8 +5977,8 @@ C<$?> like this:
 	printf "child exited with value %d\n", $? >> 8;
     }
 
-or more portably by using the W*() calls of the POSIX extension;
-see L<perlport> for more information.
+Alternatively you might inspect the value of C<${^CHILD_ERROR_NATIVE}>
+with the W*() calls of the POSIX extension.
 
 When the arguments get executed via the system shell, results
 and return codes will be subject to its quirks and capabilities.
@@ -6761,7 +6763,8 @@ example should print the following table:
 
 Behaves like the wait(2) system call on your system: it waits for a child
 process to terminate and returns the pid of the deceased process, or
-C<-1> if there are no child processes.  The status is returned in C<$?>.
+C<-1> if there are no child processes.  The status is returned in C<$?>
+and C<{^CHILD_ERROR_NATIVE}.
 Note that a return value of C<-1> could mean that child processes are
 being automatically reaped, as described in L<perlipc>.
 
@@ -6770,7 +6773,7 @@ being automatically reaped, as described in L<perlipc>.
 Waits for a particular child process to terminate and returns the pid of
 the deceased process, or C<-1> if there is no such child process.  On some
 systems, a value of 0 indicates that there are processes still running.
-The status is returned in C<$?>.  If you say
+The status is returned in C<$?> and C<{^CHILD_ERROR_NATIVE}.  If you say
 
     use POSIX ":sys_wait_h";
     #...
diff --git a/pod/perlport.pod b/pod/perlport.pod
index e250ea183b..36a87050ba 100644
--- a/pod/perlport.pod
+++ b/pod/perlport.pod
@@ -1942,16 +1942,6 @@ OS>, OS/390, VM/ESA)
 
 =item system
 
-In general, do not assume the UNIX/POSIX semantics that you can shift
-C<$?> right by eight to get the exit value, or that C<$? & 127>
-would give you the number of the signal that terminated the program,
-or that C<$? & 128> would test true if the program was terminated by a
-coredump.  Instead, use the POSIX W*() interfaces: for example, use
-WIFEXITED($?) and WEXITVALUE($?) to test for a normal exit and the exit
-value, WIFSIGNALED($?) and WTERMSIG($?) for a signal exit and the
-signal.  Core dumping is not a portable concept, so there's no portable
-way to test for that.
-
 Only implemented if ToolServer is installed. (S<Mac OS>)
 
 As an optimization, may not call the command shell specified in
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 53fe6c92c8..a9bbdaea57 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -617,7 +617,7 @@ L<perlfunc/formline()>.
 The status returned by the last pipe close, backtick (C<``>) command,
 successful call to wait() or waitpid(), or from the system()
 operator.  This is just the 16-bit status word returned by the
-wait() system call (or else is made up to look like it).  Thus, the
+traditional Unix wait() system call (or else is made up to look like it).  Thus, the
 exit value of the subprocess is really (C<<< $? >> 8 >>>), and
 C<$? & 127> gives which signal, if any, the process died from, and
 C<$? & 128> reports whether there was a core dump.  (Mnemonic:
@@ -643,6 +643,17 @@ status; see L<perlvms/$?> for details.
 
 Also see L<Error Indicators>.
 
+=item ${^CHILD_ERROR_NATIVE}
+
+The native status returned by the last pipe close, backtick (C<``>)
+command, successful call to wait() or waitpid(), or from the system()
+operator.  On POSIX-like systems this value can be decoded with the
+WIFEXITED, WEXITSTATUS, WIFSIGNALED, WTERMSIG, WIFSTOPPED, WSTOPSIG
+and WIFCONTINUED functions provided by the L<POSIX> module.
+
+Under VMS this reflects the actual VMS exit status; i.e. it is the same
+as $? when the pragma C<use vmsish 'status'> is in effect.
+
 =item ${^ENCODING}
 
 The I<object reference> to the Encode object that is used to convert
diff --git a/t/run/exit.t b/t/run/exit.t
index 53ba4ea76b..a639a1122d 100644
--- a/t/run/exit.t
+++ b/t/run/exit.t
@@ -20,7 +20,7 @@ sub run {
 
 BEGIN {
     # MacOS system() doesn't have good return value
-    $numtests = ($^O eq 'VMS') ? 7 : ($^O eq 'MacOS') ? 0 : 3; 
+    $numtests = ($^O eq 'VMS') ? 10 : ($^O eq 'MacOS') ? 0 : 17;
 }
 
 require "test.pl";
@@ -31,11 +31,35 @@ my $exit, $exit_arg;
 
 $exit = run('exit');
 is( $exit >> 8, 0,              'Normal exit' );
+is( $exit, $?,                  'Normal exit $?' );
+is( ${^CHILD_ERROR_NATIVE}, 0,  'Normal exit ${^CHILD_ERROR_NATIVE}' );
 
 if ($^O ne 'VMS') {
+  my $posix_ok = eval { require POSIX; };
 
   $exit = run('exit 42');
   is( $exit >> 8, 42,             'Non-zero exit' );
+  is( $exit, $?,                  'Non-zero exit $?' );
+  isnt( !${^CHILD_ERROR_NATIVE}, 0, 'Non-zero exit ${^CHILD_ERROR_NATIVE}' );
+ SKIP: {
+      skip("No POSIX", 3) unless $posix_ok;
+      ok(POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), "WIFEXITED");
+      ok(!POSIX::WIFSIGNALED(${^CHILD_ERROR_NATIVE}), "WIFSIGNALED");
+      is(POSIX::WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 42, "WEXITSTATUS");
+  }
+
+  $exit = run('kill 15, $$; sleep(1);');
+
+  is( $exit & 127, 15,            'Term by signal' );
+  ok( !($exit & 128),             'No core dump' );
+  is( $? & 127, 15,               'Term by signal $?' );
+  isnt( ${^CHILD_ERROR_NATIVE},  0, 'Term by signal ${^CHILD_ERROR_NATIVE}' );
+ SKIP: {
+      skip("No POSIX", 3) unless $posix_ok;
+      ok(!POSIX::WIFEXITED(${^CHILD_ERROR_NATIVE}), "WIFEXITED");
+      ok(POSIX::WIFSIGNALED(${^CHILD_ERROR_NATIVE}), "WIFSIGNALED");
+      is(POSIX::WTERMSIG(${^CHILD_ERROR_NATIVE}), 15, "WTERMSIG");
+  }
 
 } else {
 
@@ -63,7 +87,7 @@ $exit = run("END { \$? = $exit_arg }");
 
 # On VMS, in the child process the actual exit status will be SS$_ABORT, 
 # which is what you get from any non-zero value of $? that has been 
-# dePOSIXified by STATUS_POSIX_SET.  In the parent process, all we'll 
+# dePOSIXified by STATUS_UNIX_SET.  In the parent process, all we'll 
 # see are the severity bits (0-2) shifted left by 8.
 $exit_arg = (44 & 7) if $^O eq 'VMS';