Rafael Garcia-Suarez <[EMAIL PROTECTED]> writes:
> Makes sense to me... more than reformulating $? anyway (historically
> perl trying to hide the differences between platforms rather than to
> show them.)
This is a patch that I think can be applied to blead. It contains
additional doc tweaks as well as test suite additions to prove that
${^CHILD_ERROR_NATIVE} works as expected. I've tested this patch on
Linux and AIX.
--Gisle
diff -ru perl-current/doio.c perl-hack/doio.c
--- perl-current/doio.c 2005-05-11 10:24:13.000000000 +0200
+++ perl-hack/doio.c 2005-05-18 13:47:31.808879838 +0200
@@ -1046,7 +1046,7 @@
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 -ru perl-current/embedvar.h perl-hack/embedvar.h
--- perl-current/embedvar.h 2005-05-13 13:38:15.000000000 +0200
+++ perl-hack/embedvar.h 2005-05-18 13:47:31.809879632 +0200
@@ -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 -ru perl-current/gv.c perl-hack/gv.c
--- perl-current/gv.c 2005-05-11 10:24:13.000000000 +0200
+++ perl-hack/gv.c 2005-05-18 13:47:31.810879425 +0200
@@ -932,6 +932,10 @@
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 -ru perl-current/intrpvar.h perl-hack/intrpvar.h
--- perl-current/intrpvar.h 2005-05-13 13:38:15.000000000 +0200
+++ perl-hack/intrpvar.h 2005-05-18 13:47:31.810879425 +0200
@@ -74,6 +74,8 @@
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 -ru perl-current/mg.c perl-hack/mg.c
--- perl-current/mg.c 2005-05-17 17:44:22.000000000 +0200
+++ perl-hack/mg.c 2005-05-18 13:47:31.812879013 +0200
@@ -581,8 +581,13 @@
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 @@
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 -ru perl-current/perl.c perl-hack/perl.c
--- perl-current/perl.c 2005-05-16 19:23:31.000000000 +0200
+++ perl-hack/perl.c 2005-05-18 13:47:31.814878600 +0200
@@ -4806,13 +4806,13 @@
#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 -ru perl-current/perl.h perl-hack/perl.h
--- perl-current/perl.h 2005-05-17 21:14:54.000000000 +0200
+++ perl-hack/perl.h 2005-05-18 13:47:31.817877981 +0200
@@ -2414,6 +2414,7 @@
# 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 @@
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 @@
# 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 -ru perl-current/perlapi.h perl-hack/perlapi.h
--- perl-current/perlapi.h 2005-05-13 13:38:15.000000000 +0200
+++ perl-hack/perlapi.h 2005-05-18 13:47:31.817877981 +0200
@@ -551,6 +551,8 @@
#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 -ru perl-current/pod/perlfunc.pod perl-hack/pod/perlfunc.pod
--- perl-current/pod/perlfunc.pod 2005-05-12 11:15:46.000000000 +0200
+++ perl-hack/pod/perlfunc.pod 2005-05-18 14:59:07.807723949 +0200
@@ -782,7 +782,8 @@
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 @@
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 @@
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 @@
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 @@
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 -ru perl-current/pod/perlport.pod perl-hack/pod/perlport.pod
--- perl-current/pod/perlport.pod 2005-05-04 23:18:41.000000000 +0200
+++ perl-hack/pod/perlport.pod 2005-05-18 14:14:09.207332644 +0200
@@ -1964,16 +1964,6 @@
=item system LIST
-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 -ru perl-current/pod/perlvar.pod perl-hack/pod/perlvar.pod
--- perl-current/pod/perlvar.pod 2005-05-04 14:42:51.000000000 +0200
+++ perl-hack/pod/perlvar.pod 2005-05-18 13:47:31.822876949 +0200
@@ -617,7 +617,7 @@
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 @@
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 system 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 reflect 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 -ru perl-current/t/run/exit.t perl-hack/t/run/exit.t
--- perl-current/t/run/exit.t 2004-01-07 20:28:47.000000000 +0100
+++ perl-hack/t/run/exit.t 2005-05-18 14:45:07.911815970 +0200
@@ -20,7 +20,7 @@
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 @@
$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 @@
# 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';
