(perl #134177) add G_RETHROW flag to eval_sv()
authorTony Cook <tony@develop-help.com>
Thu, 20 Jun 2019 05:26:22 +0000 (15:26 +1000)
committerTony Cook <tony@develop-help.com>
Mon, 8 Jul 2019 01:02:19 +0000 (11:02 +1000)
and update eval_pv() to use it.

cop.h
ext/XS-APItest/Makefile.PL
ext/XS-APItest/t/call.t
perl.c

diff --git a/cop.h b/cop.h
index b9b61fa..b1d1075 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -973,6 +973,7 @@ L<perlcall>.
                                    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_RETHROW      8192    /* eval_sv(): re-throw any error */
 
 /* flag bits for PL_in_eval */
 #define EVAL_NULL      0       /* not in an eval */
index d79ba11..3fe5e39 100644 (file)
@@ -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
index 632a421..e422807 100644 (file)
@@ -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 2e80cfe..e642f2e 100644 (file)
--- 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;
 }