Well defined $? and introduction of ${^CHILD_ERROR_NATIVE} [PATCH]
Gisle Aas [Wed, 18 May 2005 08:35:47 +0000 (01:35 -0700)]
Message-ID: <lr8y2cim24.fsf_-_@caliper.activestate.com>

p4raw-id: //depot/perl@24501

12 files changed:
doio.c
embedvar.h
gv.c
intrpvar.h
mg.c
perl.c
perl.h
perlapi.h
pod/perlfunc.pod
pod/perlport.pod
pod/perlvar.pod
t/run/exit.t

diff --git a/doio.c b/doio.c
index 224f72d..e09ef64 100644 (file)
--- 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);
index 60c5d27..760a53f 100644 (file)
 #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)
 #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 (file)
--- 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;
index ab08e05..c879e9e 100644 (file)
@@ -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 (file)
--- 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 (file)
--- 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 (file)
--- 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() */
index 6ae40a2..46177d2 100644 (file)
--- 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
index a428b5f..5414e32 100644 (file)
@@ -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";
     #...
index e250ea1..36a8705 100644 (file)
@@ -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
index 53fe6c9..a9bbdae 100644 (file)
@@ -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
index 53ba4ea..a639a11 100644 (file)
@@ -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';