From: Gisle Aas <gisle@aas.no>
Date: Wed, 18 May 2005 08:35:47 +0000 (-0700)
Subject: Well defined $? and introduction of ${^CHILD_ERROR_NATIVE} [PATCH]
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e5218da503dbb4980410e0018f4cc5dcba3ea666;p=p5sagit%2Fp5-mst-13.2.git
Well defined $? and introduction of ${^CHILD_ERROR_NATIVE} [PATCH]
Message-ID: <lr8y2cim24.fsf_-_@caliper.activestate.com>
p4raw-id: //depot/perl@24501
---
diff --git a/doio.c b/doio.c
index 224f72d..e09ef64 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 60c5d27..760a53f 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 7d3eccb..0b31ae9 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 ab08e05..c879e9e 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 359b8ca..baad04f 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 66d5e1d..5f38e64 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 cb64a6e..1a2145c 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 6ae40a2..46177d2 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 a428b5f..5414e32 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 e250ea1..36a8705 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 53fe6c9..a9bbdae 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 53ba4ea..a639a11 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';