diff options
| -rw-r--r-- | embed.fnc | 10 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | pp_ctl.c | 8 | ||||
| -rw-r--r-- | proto.h | 14 | ||||
| -rw-r--r-- | t/op/die.t | 20 | ||||
| -rw-r--r-- | t/op/eval.t | 17 | ||||
| -rw-r--r-- | util.c | 4 |
7 files changed, 62 insertions, 15 deletions
@@ -2558,7 +2558,7 @@ Adp |char * |pv_uni_display |NN SV *dsv \ |UV flags : FIXME - either make it public, or stop exporting it. (Data::Alias uses this) : Used in gv.c, op.c, toke.c -EXp |void |qerror |NN SV *err +EXp |void |qerror |NULLOK SV *err Adp |char * |rcpv_copy |NULLOK char * const pv Adp |char * |rcpv_free |NULLOK char * const pv Aadp |char * |rcpv_new |NULLOK const char * const pv \ @@ -4831,6 +4831,11 @@ S |void |save_lines |NULLOK AV *array \ RS |PerlIO *|doopen_pm |NN SV *name # endif /* !defined(PERL_DISABLE_PMC) */ #endif /* defined(PERL_IN_PP_CTL_C) */ +#if defined(PERL_IN_PP_CTL_C) || defined(PERL_IN_UTIL_C) +p |bool |invoke_exception_hook \ + |NULLOK SV *ex \ + |bool warn +#endif /* defined(PERL_IN_PP_CTL_C) || defined(PERL_IN_UTIL_C) */ #if defined(PERL_IN_PP_HOT_C) S |void |do_oddball |NN SV **oddkey \ |NN SV **firstkey @@ -5853,9 +5858,6 @@ S |void |warn_on_first_deprecated_use \ #endif /* defined(PERL_IN_UTF8_C) */ #if defined(PERL_IN_UTIL_C) S |bool |ckwarn_common |U32 w -S |bool |invoke_exception_hook \ - |NULLOK SV *ex \ - |bool warn S |SV * |mess_alloc S |SV * |with_queued_errors \ |NN SV *ex @@ -1491,6 +1491,9 @@ # define doopen_pm(a) S_doopen_pm(aTHX_ a) # endif /* !defined(PERL_DISABLE_PMC) */ # endif /* defined(PERL_IN_PP_CTL_C) */ +# if defined(PERL_IN_PP_CTL_C) || defined(PERL_IN_UTIL_C) +# define invoke_exception_hook(a,b) Perl_invoke_exception_hook(aTHX_ a,b) +# endif /* defined(PERL_IN_PP_CTL_C) || defined(PERL_IN_UTIL_C) */ # if defined(PERL_IN_PP_HOT_C) # define do_oddball(a,b) S_do_oddball(aTHX_ a,b) # define opmethod_stash(a) S_opmethod_stash(aTHX_ a) @@ -1622,7 +1625,6 @@ # endif /* defined(PERL_IN_UTF8_C) */ # if defined(PERL_IN_UTIL_C) # define ckwarn_common(a) S_ckwarn_common(aTHX_ a) -# define invoke_exception_hook(a,b) S_invoke_exception_hook(aTHX_ a,b) # define mess_alloc() S_mess_alloc(aTHX) # define with_queued_errors(a) S_with_queued_errors(aTHX_ a) # if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL) @@ -3804,6 +3804,9 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) * various vars restored. This block applies similar steps after * the other "failed to compile" cases in yyparse, eg, where * yystatus=1, "failed, but did not die". */ + + if (!in_require) + invoke_exception_hook(ERRSV,FALSE); if (PL_eval_root) { op_free(PL_eval_root); PL_eval_root = NULL; @@ -3811,6 +3814,10 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) SP = PL_stack_base + POPMARK; /* pop original mark */ cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); + /* If we are in an eval we need to make sure that $SIG{__DIE__} + * handler is invoked so we simulate that part of the + * Perl_die_unwind() process. In a require we will croak + * so it will happen there. */ /* pop the CXt_EVAL, and if was a require, croak */ S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2); } @@ -3824,6 +3831,7 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) if (!*(SvPV_nolen_const(errsv))) sv_setpvs(errsv, "Compilation error"); + if (gimme != G_LIST) PUSHs(&PL_sv_undef); PUTBACK; return FALSE; @@ -3578,8 +3578,7 @@ Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV f PERL_CALLCONV void Perl_qerror(pTHX_ SV *err); -#define PERL_ARGS_ASSERT_QERROR \ - assert(err) +#define PERL_ARGS_ASSERT_QERROR PERL_CALLCONV char * Perl_rcpv_copy(pTHX_ char * const pv); @@ -7945,6 +7944,13 @@ S_path_is_searchable(const char *name) # endif /* !defined(PERL_NO_INLINE_FUNCTIONS) */ #endif /* defined(PERL_IN_PP_CTL_C) */ +#if defined(PERL_IN_PP_CTL_C) || defined(PERL_IN_UTIL_C) +PERL_CALLCONV bool +Perl_invoke_exception_hook(pTHX_ SV *ex, bool warn) + __attribute__visibility__("hidden"); +# define PERL_ARGS_ASSERT_INVOKE_EXCEPTION_HOOK + +#endif /* defined(PERL_IN_PP_CTL_C) || defined(PERL_IN_UTIL_C) */ #if defined(PERL_IN_PP_HOT_C) STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey); @@ -9537,10 +9543,6 @@ STATIC bool S_ckwarn_common(pTHX_ U32 w); # define PERL_ARGS_ASSERT_CKWARN_COMMON -STATIC bool -S_invoke_exception_hook(pTHX_ SV *ex, bool warn); -# define PERL_ARGS_ASSERT_INVOKE_EXCEPTION_HOOK - STATIC SV * S_mess_alloc(pTHX); # define PERL_ARGS_ASSERT_MESS_ALLOC diff --git a/t/op/die.t b/t/op/die.t index eec1e8e485..c6579373f7 100644 --- a/t/op/die.t +++ b/t/op/die.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan tests => 21; +plan tests => 26; use utf8; # Tell EBCDIC translator to make this UTF-8, @@ -101,10 +101,26 @@ like($@, qr/\.{3}propagated at/, '... and appends a phrase'); like($@."", qr/100\t\.{3}propagated at/, 'check non-PVs in $@ are propagated'); } +{ + my @error; + local $SIG{__DIE__}= sub { push @error, @_ }; + use strict; + my $ok= eval '$intentionally_missing+1'; + my $eval_error= $@; + is($ok,undef,"eval should return undef"); + is(0+@error,1,"we should have captured 1 error via __DIE__"); + like( $error[0], + qr/Global symbol \"\$intentionally_missing\"/, + "The __DIE__ handler should have seen this message"); + like( $eval_error, + qr/Global symbol \"\$intentionally_missing\"/, + "The eval error in '\$@' should contain this message"); + is( $error[0], $eval_error, + "__DIE__ handler and \$@ should be the same"); +} TODO: { local $TODO = 'RT #4821: die qr{x} does not check termination'; my $out = runperl(prog => 'die qr{x}', stderr => 1); like($out, qr/at -e line 1./, 'RT #4821: output from die qr{x}'); } - diff --git a/t/op/eval.t b/t/op/eval.t index 3561e2f0b7..f2f06b1a74 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -738,3 +738,20 @@ pass("eval in freed package does not crash"); "No segfault inside sort: $sort_line"); } } +{ + # test that all of these cases behave the same + for my $fragment ('bar', '1+;', '1+;' x 11, 's/', ']') { + fresh_perl_is( + # code: + 'use strict; use warnings; $SIG{__DIE__} = sub { die "X" }; ' . + 'eval { eval "'.$fragment.'"; print "after eval $@"; };' . + 'if ($@) { print "outer eval $@" }', + # wanted: + "after eval X at - line 1.", + # opts: + {}, + # name: + "test that nested eval '$fragment' calls sig die as expected" + ); + } +} @@ -1717,8 +1717,8 @@ S_with_queued_errors(pTHX_ SV *ex) return ex; } -STATIC bool -S_invoke_exception_hook(pTHX_ SV *ex, bool warn) +bool +Perl_invoke_exception_hook(pTHX_ SV *ex, bool warn) { HV *stash; GV *gv; |