In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/be064c4a1f59651142e99788731ae1d164c19537?hp=95f567513aaa04ffb8bb9d148aff1a85b1eff161>
- Log -----------------------------------------------------------------
commit be064c4a1f59651142e99788731ae1d164c19537
Author: David Mitchell <da...@iabyn.com>
Date: Sun Oct 3 20:50:20 2010 +0100
better documentation for eval_sv() and G_KEEPERR
M perl.c
M pod/perlcall.pod
commit 6b2fb389897a68db92c38c22f79403607f0da303
Author: David Mitchell <da...@iabyn.com>
Date: Sun Oct 3 20:36:36 2010 +0100
G_KEEPERR sometimes set $@
eval_sv(sv,G_KEEPERR) is supposed to warn on errors, rather than
set $@; but in the particular case of compile-time errors it still
set $@ instead. See [perl ##3719].
M ext/XS-APItest/t/call.t
M pp_ctl.c
commit 4aca2f62efca883199d7975f34b7fb876c280366
Author: David Mitchell <da...@iabyn.com>
Date: Sat Oct 2 11:13:09 2010 +0100
eval_sv() and eval_pv() don't fail on syntax err
[perl #3719] eval_sv("some syntax err") cleared $@ and didn't return
a failure indication. This also affected eval_pv() which calls eval_sv().
Fix this and add lots of tests.
M ext/XS-APItest/t/call.t
M perl.c
-----------------------------------------------------------------------
Summary of changes:
ext/XS-APItest/t/call.t | 92 ++++++++++++++++++++++++++++++++++++++++++++++-
perl.c | 16 ++++----
pod/perlcall.pod | 8 +++-
pp_ctl.c | 10 ++++-
4 files changed, 113 insertions(+), 13 deletions(-)
diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 9a84f88..caa86c4 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -11,12 +11,16 @@ use strict;
BEGIN {
require '../../t/test.pl';
- plan(342);
+ plan(435);
use_ok('XS::APItest')
};
#########################
+# f(): general test sub to be called by call_sv() etc.
+# Return the called args, but with the first arg replaced with 'b',
+# and the last arg replaced with x/y/z depending on context
+#
sub f {
shift;
unshift @_, 'b';
@@ -186,6 +190,92 @@ is($@, "its_dead_jim\n", "eval_pv('d()', 0) - \$@");
is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@");
+
+# #3719 - check that the eval call variants handle exceptions correctly,
+# and do the right thing with $@, both with and without G_KEEPERR set.
+
+sub f99 { 99 };
+
+
+for my $fn_type (0..2) { # 0:eval_pv 1:eval_sv 2:call_sv
+
+ my $warn_msg;
+ local $SIG{__WARN__} = sub { $warn_msg .= $_[0] };
+
+ for my $code_type (0..3) {
+
+ # call_sv can only handle function names, not code snippets
+ next if $fn_type == 2 and ($code_type == 1 or $code_type == 2);
+
+ my $code = (
+ 'f99', # ok
+ '$x=', # compile-time err
+ 'BEGIN { die "die in BEGIN"}', # compile-time exception
+ 'd', # run-time exception
+ )[$code_type];
+
+ for my $keep (0, G_KEEPERR) {
+ my $keep_desc = $keep ? 'G_KEEPERR' : '0';
+
+ my $desc;
+ my $expect = ($code_type == 0) ? 1 : 0;
+
+ undef $warn_msg;
+ $@ = 'pre-err';
+
+ my @ret;
+ if ($fn_type == 0) { # eval_pv
+ # eval_pv returns its result rather than a 'succeed' boolean
+ $expect = $expect ? '99' : undef;
+
+ # eval_pv doesn't support G_KEEPERR, but it has a croak
+ # boolean arg instead, so switch on that instead
+ if ($keep) {
+ $desc = "eval { eval_pv('$code', 1) }";
+ @ret = eval { eval_pv($code, 1); '99' };
+ # die in eval returns empty list
+ push @ret, undef unless @ret;
+ }
+ else {
+ $desc = "eval_pv('$code', 0)";
+ @ret = eval_pv($code, 0);
+ }
+ }
+ elsif ($fn_type == 1) { # eval_sv
+ $desc = "eval_sv('$code', G_ARRAY|$keep_desc)";
+ @ret = eval_sv($code, G_ARRAY|$keep);
+ }
+ elsif ($fn_type == 2) { # call_sv
+ $desc = "call_sv('$code', G_EVAL|G_ARRAY|$keep_desc)";
+ @ret = call_sv($code, G_EVAL|G_ARRAY|$keep);
+ }
+ is(scalar @ret, ($code_type == 0 && $fn_type != 0) ? 2 : 1,
+ "$desc - number of returned args");
+ is($ret[-1], $expect, "$desc - return value");
+
+ if ($keep && $fn_type != 0) {
+ # G_KEEPERR doesn't propagate into inner evals, requires etc
+ unless ($keep && $code_type == 2) {
+ is($@, 'pre-err', "$desc - \$@ unmodified");
+ }
+ $@ = $warn_msg;
+ }
+ else {
+ is($warn_msg, undef, "$desc - __WARN__ not called");
+ unlike($@, 'pre-err', "$desc - \$@ modified");
+ }
+ like($@,
+ (
+ qr/^$/,
+ qr/syntax error/,
+ qr/die in BEGIN/,
+ qr/its_dead_jim/,
+ )[$code_type],
+ "$desc - the correct error message");
+ }
+ }
+}
+
# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
# a new jump level but before pushing an eval context, leading to
# stack corruption
diff --git a/perl.c b/perl.c
index cf42087..ca5aea6 100644
--- a/perl.c
+++ b/perl.c
@@ -80,12 +80,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int
maxlen);
# define validate_suid(validarg, scriptname, fdscript, suidscript,
linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
#endif
-#define CALL_BODY_EVAL(myop) \
- if (PL_op == (myop)) \
- PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \
- if (PL_op) \
- CALLRUNOPS(aTHX);
-
#define CALL_BODY_SUB(myop) \
if (PL_op == (myop)) \
PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
@@ -2667,7 +2661,8 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
/*
=for apidoc p||eval_sv
-Tells Perl to C<eval> the string in the SV.
+Tells Perl to C<eval> the string in the SV. It supports the same flags
+as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
=cut
*/
@@ -2715,7 +2710,11 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
switch (ret) {
case 0:
redo_body:
- CALL_BODY_EVAL((OP*)&myop);
+ assert(PL_op == (OP*)(&myop));
+ PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
+ if (!PL_op)
+ goto fail; /* failed in compilation */
+ CALLRUNOPS(aTHX);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR)) {
CLEAR_ERRSV();
@@ -2738,6 +2737,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
PL_restartop = 0;
goto redo_body;
}
+ fail:
PL_stack_sp = PL_stack_base + oldmark;
if ((flags & G_WANT) == G_ARRAY)
retval = 0;
diff --git a/pod/perlcall.pod b/pod/perlcall.pod
index f34a53d..1694848 100644
--- a/pod/perlcall.pod
+++ b/pod/perlcall.pod
@@ -336,8 +336,9 @@ It may also be useful to do this with code for C<__DIE__>
or C<__WARN__>
hooks, and C<tie> functions.
The G_KEEPERR flag is meant to be used in conjunction with G_EVAL in
-I<call_*> functions that are used to implement such code. This flag
-has no effect when G_EVAL is not used.
+I<call_*> functions that are used to implement such code, or with
+C<eval_sv>. This flag has no effect on the C<call_*> functions when
+G_EVAL is not used.
When G_KEEPERR is used, any error in the called code will terminate the
call as usual, and the error will not propagate beyond the call (as usual
@@ -346,6 +347,9 @@ converted into a warning, prefixed with the string "\t(in
cleanup)".
This can be disabled using C<no warnings 'misc'>. If there is no error,
C<$@> will not be cleared.
+Note that the G_KEEPERR flag does not propagate into inner evals; these
+may still set C<$@>.
+
The G_KEEPERR flag was introduced in Perl version 5.002.
See I<Using G_KEEPERR> for an example of a situation that warrants the
diff --git a/pp_ctl.c b/pp_ctl.c
index 2444452..63a5f22 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1577,8 +1577,14 @@ Perl_qerror(pTHX_ SV *err)
PERL_ARGS_ASSERT_QERROR;
- if (PL_in_eval)
- sv_catsv(ERRSV, err);
+ if (PL_in_eval) {
+ if (PL_in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+ SvPV_nolen_const(err));
+ }
+ else
+ sv_catsv(ERRSV, err);
+ }
else if (PL_errors)
sv_catsv(PL_errors, err);
else
--
Perl5 Master Repository
