In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8753f506cef14f551777d67a7a9759c96c1e89ff?hp=2e06b51cf21f0d70a782e77099e579ac30d69d3b>
- Log ----------------------------------------------------------------- commit 8753f506cef14f551777d67a7a9759c96c1e89ff Merge: 2e06b51 6c341f6 Author: Tony Cook <[email protected]> Date: Mon Jul 29 15:44:15 2013 +1000 [perl #52000] Warn/abort on attempted perl exit commit 6c341f670657537087c5e506df91a2891e543b2d Author: Tony Cook <[email protected]> Date: Mon Jul 29 15:38:58 2013 +1000 [perl #52000] add perldiag entries for the new warnings M pod/perldiag.pod commit 9ee6b2e5367f3b8d4b64706d38742af273f4400e Author: Tony Cook <[email protected]> Date: Mon Jul 29 15:36:26 2013 +1000 John Gardiner Myers is now a perl AUTHOR M AUTHORS commit 6136213b81ecb05d74939be5083ddfdc96aef566 Author: John Gardiner Myers <[email protected]> Date: Mon Jul 29 15:33:09 2013 +1000 [perl #52000] Warn/abort on attempted perl exit M lib/ExtUtils/t/Embed.t M perl.c M perl.h ----------------------------------------------------------------------- Summary of changes: AUTHORS | 1 + lib/ExtUtils/t/Embed.t | 13 +++++++------ perl.c | 16 ++++++++++++++++ perl.h | 2 ++ pod/perldiag.pod | 10 ++++++++++ 5 files changed, 36 insertions(+), 6 deletions(-) diff --git a/AUTHORS b/AUTHORS index 629b456..64a37df 100644 --- a/AUTHORS +++ b/AUTHORS @@ -573,6 +573,7 @@ John Bley <[email protected]> John Borwick <[email protected]> John Cerney <[email protected]> John D Groenveld <[email protected]> +John Gardiner Myers <[email protected]> John Goodyear <[email protected]> John Hasstedt <[email protected]> John Hawkinson <[email protected]> diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t index fb9db91..f47d036 100644 --- a/lib/ExtUtils/t/Embed.t +++ b/lib/ExtUtils/t/Embed.t @@ -17,7 +17,7 @@ print $fh <DATA>; close($fh); $| = 1; -print "1..9\n"; +print "1..10\n"; my $cc = $Config{'cc'}; my $cl = ($^O eq 'MSWin32' && $cc eq 'cl'); my $skip_exe = $^O eq 'os2' && $Config{ldflags} =~ /(?<!\S)-Zexe\b/; @@ -136,7 +136,7 @@ my $embed_test = File::Spec->catfile(File::Spec->curdir, $exe); $embed_test = "run/nodebug $exe" if $^O eq 'VMS'; print "# embed_test = $embed_test\n"; $status = system($embed_test); -print (($status? 'not ':'')."ok 9 # system returned $status\n"); +print (($status? 'not ':'')."ok 10 # system returned $status\n"); unlink($exe,"embed_test.c",$obj); unlink("$exe.manifest") if $cl and $Config{'ccversion'} =~ /^(\d+)/ and $1 >= 14; unlink("$exe$Config{exe_ext}") if $skip_exe; @@ -154,7 +154,7 @@ __END__ #define my_puts(a) if(puts(a) < 0) exit(666) -static const char * cmds [] = { "perl", "-e", "$|=1; print qq[ok 5\\n]", NULL }; +static const char * cmds [] = { "perl", "-e", "$|=1; print qq[ok 5\\n]; $SIG{__WARN__} = sub { print qq[ok 6\\n] if $_[0] =~ /Unexpected exit/; }; exit 5;", NULL }; #ifdef PERL_GLOBAL_STRUCT_PRIVATE static struct perl_vars *my_plvarsp; @@ -184,6 +184,7 @@ int main(int argc, char **argv, char **env) { my_puts("ok 2"); perl_construct(my_perl); + my_perl->Iexit_flags |= PERL_EXIT_WARN; my_puts("ok 3"); @@ -195,15 +196,15 @@ int main(int argc, char **argv, char **env) { perl_run(my_perl); - my_puts("ok 6"); + my_puts("ok 7"); perl_destruct(my_perl); - my_puts("ok 7"); + my_puts("ok 8"); perl_free(my_perl); - my_puts("ok 8"); + my_puts("ok 9"); PERL_SYS_TERM(); diff --git a/perl.c b/perl.c index 57d51e6..f31c1ed 100644 --- a/perl.c +++ b/perl.c @@ -4950,6 +4950,14 @@ void Perl_my_exit(pTHX_ U32 status) { dVAR; + if (PL_exit_flags & PERL_EXIT_ABORT) { + abort(); + } + if (PL_exit_flags & PERL_EXIT_WARN) { + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit %u", status); + PL_exit_flags &= ~PERL_EXIT_ABORT; + } switch (status) { case 0: STATUS_ALL_SUCCESS; @@ -5047,6 +5055,14 @@ Perl_my_failure_exit(pTHX) STATUS_UNIX_SET(255); } #endif + if (PL_exit_flags & PERL_EXIT_ABORT) { + abort(); + } + if (PL_exit_flags & PERL_EXIT_WARN) { + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue); + PL_exit_flags &= ~PERL_EXIT_ABORT; + } my_exit_jump(); } diff --git a/perl.h b/perl.h index cfcf871..d3648e1 100644 --- a/perl.h +++ b/perl.h @@ -2953,6 +2953,8 @@ typedef pthread_key_t perl_key; /* flags in PL_exit_flags for nature of exit() */ #define PERL_EXIT_EXPECTED 0x01 #define PERL_EXIT_DESTRUCT_END 0x02 /* Run END in perl_destruct */ +#define PERL_EXIT_WARN 0x04 /* Warn if Perl_my_exit() or Perl_my_failure_exit() called */ +#define PERL_EXIT_ABORT 0x08 /* Call abort() if Perl_my_exit() or Perl_my_failure_exit() called */ #ifndef PERL_CORE /* format to use for version numbers in file/directory names */ diff --git a/pod/perldiag.pod b/pod/perldiag.pod index e48a556..9c32c04 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -5397,6 +5397,16 @@ enough to figure out what you really meant. (P) When compiling a subroutine call in lvalue context, Perl failed an internal consistency check. It encountered a malformed op tree. +=item Unexpected exit %u + +(S) exit() was called or the script otherwise finished gracefully when +C<PERL_EXIT_WARN> was set in C<PL_exit_flags>. + +=item Unexpected exit failure %u + +(S) An uncaught die() was called when C<PERL_EXIT_WARN> was set in +C<PL_exit_flags>. + =item Unexpected ')' in regex; marked by <-- HERE in m/%s/ (F) You had something like this: -- Perl5 Master Repository
