From: Gisle Aas 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: 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. 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 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. @@ -6770,7 +6773,7 @@ being automatically reaped, as described in L. 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) 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. 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 for details. Also see L. +=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 module. + +Under VMS this reflects the actual VMS exit status; i.e. it is the same +as $? when the pragma C is in effect. + =item ${^ENCODING} The I 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';