In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/66ff4fb5827047a9962893be6bdf6c6439b7af2c?hp=51d22a816ecfc587acee9913de2de6a113718dcd>
- Log -----------------------------------------------------------------
commit 66ff4fb5827047a9962893be6bdf6c6439b7af2c
Author: Tony Cook <t...@develop-help.com>
Date: Mon Jun 24 10:01:42 2019 +1000
use hex for the call_*()/eval_sv() flag definitions
while I expect most C programmers have these powers of two engraved
into their brains, using hex makes this more obvious
commit fb81daf0179f156be3f2a95cd5cf1d27e9f7ebbb
Author: Tony Cook <t...@develop-help.com>
Date: Thu Jun 20 15:26:22 2019 +1000
(perl #134177) add G_RETHROW flag to eval_sv()
and update eval_pv() to use it.
-----------------------------------------------------------------------
Summary of changes:
cop.h | 23 ++++++++++++-----------
ext/XS-APItest/Makefile.PL | 2 +-
ext/XS-APItest/t/call.t | 26 +++++++++++++++++++++++++-
perl.c | 25 ++++++++++++++++---------
4 files changed, 54 insertions(+), 22 deletions(-)
diff --git a/cop.h b/cop.h
index b9b61faa76..243f70094d 100644
--- a/cop.h
+++ b/cop.h
@@ -956,23 +956,24 @@ L<perlcall>.
#define G_WANT 3
/* extra flags for Perl_call_* routines */
-#define G_DISCARD 4 /* Call FREETMPS.
+#define G_DISCARD 0x4 /* Call FREETMPS.
Don't change this without consulting the
hash actions codes defined in hv.h */
-#define G_EVAL 8 /* Assume eval {} around subroutine call. */
-#define G_NOARGS 16 /* Don't construct a @_ array. */
-#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */
-#define G_NODEBUG 64 /* Disable debugging at toplevel. */
-#define G_METHOD 128 /* Calling method. */
-#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
+#define G_EVAL 0x8 /* Assume eval {} around subroutine call. */
+#define G_NOARGS 0x10 /* Don't construct a @_ array. */
+#define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */
+#define G_NODEBUG 0x40 /* Disable debugging at toplevel. */
+#define G_METHOD 0x80 /* Calling method. */
+#define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or
fold_constants. */
-#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef
+#define G_UNDEF_FILL 0x200 /* Fill the stack with &PL_sv_undef
A special case for UNSHIFT in
Perl_magic_methcall(). */
-#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling
+#define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling
Perl_magic_methcall(). */
-#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
-#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */
+#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */
+#define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */
+#define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index d79ba1150e..3fe5e397a8 100644
--- a/ext/XS-APItest/Makefile.PL
+++ b/ext/XS-APItest/Makefile.PL
@@ -23,7 +23,7 @@ WriteMakefile(
my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE
HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV
G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS
- G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL
+ G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL G_RETHROW
GV_NOADD_NOINIT
IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 632a421d4f..e4228077cb 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -11,7 +11,7 @@ use strict;
BEGIN {
require '../../t/test.pl';
- plan(530);
+ plan(538);
use_ok('XS::APItest')
};
@@ -228,6 +228,30 @@ is(eval { eval_pv(q/die $obj/, 1) }, undef,
ok(ref $@, "object thrown");
is($@, $obj, "check object rethrown");
+package False {
+ use overload
+ bool => sub { 0 },
+ '""' => sub { "Foo" };
+ sub new { bless {}, shift }
+};
+my $false = False->new;
+ok(!$false, "our false object is actually false");
+is(eval { eval_pv(q/die $false;/, 1); 1 }, undef,
+ "check false objects are rethrown");
+is(overload::StrVal($@), overload::StrVal($false),
+ "check we got the expected object");
+
+is(eval { eval_sv(q/die $false/, G_RETHROW); 1 }, undef,
+ "check G_RETHROW for thrown object");
+is(overload::StrVal($@), overload::StrVal($false),
+ "check we got the expected object");
+is(eval { eval_sv(q/"unterminated/, G_RETHROW); 1 }, undef,
+ "check G_RETHROW for syntax error");
+like($@, qr/Can't find string terminator/,
+ "check error rethrown");
+ok(eq_array([ eval { eval_sv(q/"working code"/, G_RETHROW) } ], [ "working
code", 1 ]),
+ "check for spurious rethrow");
+
# #3719 - check that the eval call variants handle exceptions correctly,
# and do the right thing with $@, both with and without G_KEEPERR set.
diff --git a/perl.c b/perl.c
index 2e80cfe940..e642f2e76d 100644
--- a/perl.c
+++ b/perl.c
@@ -3097,6 +3097,9 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
Tells Perl to C<eval> the string in the SV. It supports the same flags
as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
+The C<G_RETHROW> flag can be used if you only need eval_sv() to
+execute code specified by a string, but not catch any errors.
+
=cut
*/
@@ -3178,6 +3181,11 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
goto redo_body;
}
fail:
+ if (flags & G_RETHROW) {
+ JMPENV_POP;
+ croak_sv(ERRSV);
+ }
+
PL_stack_sp = PL_stack_base + oldmark;
if ((flags & G_WANT) == G_ARRAY)
retval = 0;
@@ -3214,8 +3222,14 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
PERL_ARGS_ASSERT_EVAL_PV;
- eval_sv(sv, G_SCALAR);
- SvREFCNT_dec(sv);
+ if (croak_on_error) {
+ sv_2mortal(sv);
+ eval_sv(sv, G_SCALAR | G_RETHROW);
+ }
+ else {
+ eval_sv(sv, G_SCALAR);
+ SvREFCNT_dec(sv);
+ }
{
dSP;
@@ -3223,13 +3237,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
PUTBACK;
}
- /* just check empty string or undef? */
- if (croak_on_error) {
- SV * const errsv = ERRSV;
- if(SvTRUE_NN(errsv))
- croak_sv(errsv);
- }
-
return sv;
}
--
Perl5 Master Repository
