Change 24501 by [EMAIL PROTECTED] on 2005/05/18 16:08:30
Subject: Well defined $? and introduction of ${^CHILD_ERROR_NATIVE}
[PATCH]
From: Gisle Aas <[EMAIL PROTECTED]>
Date: 18 May 2005 08:35:47 -0700
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/doio.c#256 edit
... //depot/perl/embedvar.h#198 edit
... //depot/perl/gv.c#235 edit
... //depot/perl/intrpvar.h#150 edit
... //depot/perl/mg.c#331 edit
... //depot/perl/perl.c#610 edit
... //depot/perl/perl.h#591 edit
... //depot/perl/perlapi.h#118 edit
... //depot/perl/pod/perlfunc.pod#469 edit
... //depot/perl/pod/perlport.pod#150 edit
... //depot/perl/pod/perlvar.pod#139 edit
... //depot/perl/t/run/exit.t#9 edit
Differences ...
==== //depot/perl/doio.c#256 (text) ====
Index: perl/doio.c
--- perl/doio.c#255~24445~ Wed May 11 00:54:19 2005
+++ perl/doio.c Wed May 18 09:08:30 2005
@@ -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);
==== //depot/perl/embedvar.h#198 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h#197~24459~ Fri May 13 04:09:03 2005
+++ perl/embedvar.h Wed May 18 09:08:30 2005
@@ -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
==== //depot/perl/gv.c#235 (text) ====
Index: perl/gv.c
--- perl/gv.c#234~24445~ Wed May 11 00:54:19 2005
+++ perl/gv.c Wed May 18 09:08:30 2005
@@ -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;
==== //depot/perl/intrpvar.h#150 (text) ====
Index: perl/intrpvar.h
--- perl/intrpvar.h#149~24459~ Fri May 13 04:09:03 2005
+++ perl/intrpvar.h Wed May 18 09:08:30 2005
@@ -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 */
==== //depot/perl/mg.c#331 (text) ====
Index: perl/mg.c
--- perl/mg.c#330~24492~ Tue May 17 08:15:46 2005
+++ perl/mg.c Wed May 18 09:08:30 2005
@@ -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 '!':
{
==== //depot/perl/perl.c#610 (text) ====
Index: perl/perl.c
--- perl/perl.c#609~24489~ Mon May 16 09:56:43 2005
+++ perl/perl.c Wed May 18 09:08:30 2005
@@ -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();
==== //depot/perl/perl.h#591 (text) ====
Index: perl/perl.h
--- perl/perl.h#590~24495~ Tue May 17 11:45:56 2005
+++ perl/perl.h Wed May 18 09:08:30 2005
@@ -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() */
==== //depot/perl/perlapi.h#118 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h#117~24459~ Fri May 13 04:09:03 2005
+++ perl/perlapi.h Wed May 18 09:08:30 2005
@@ -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
==== //depot/perl/pod/perlfunc.pod#469 (text) ====
Index: perl/pod/perlfunc.pod
--- perl/pod/perlfunc.pod#468~24450~ Thu May 12 01:45:40 2005
+++ perl/pod/perlfunc.pod Wed May 18 09:08:30 2005
@@ -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";
#...
==== //depot/perl/pod/perlport.pod#150 (text) ====
Index: perl/pod/perlport.pod
--- perl/pod/perlport.pod#149~24496~ Wed May 18 04:50:47 2005
+++ perl/pod/perlport.pod Wed May 18 09:08:30 2005
@@ -1942,16 +1942,6 @@
=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
==== //depot/perl/pod/perlvar.pod#139 (text) ====
Index: perl/pod/perlvar.pod
--- perl/pod/perlvar.pod#138~24383~ Wed May 4 05:12:30 2005
+++ perl/pod/perlvar.pod Wed May 18 09:08:30 2005
@@ -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:
@@ -642,6 +642,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}
==== //depot/perl/t/run/exit.t#9 (text) ====
Index: perl/t/run/exit.t
--- perl/t/run/exit.t#8~22091~ Wed Jan 7 11:09:50 2004
+++ perl/t/run/exit.t Wed May 18 09:08:30 2005
@@ -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';
End of Patch.
