From @tonycoz

0001-perl-134177-add-G_RETHROW-flag-to-eval_sv.patch

From f79274795bd1fbd4808a731648ea158a964a14de Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 20 Jun 2019 15:26:22 +1000
Subject: (perl #134177) add G_RETHROW flag to eval_sv()

and update eval_pv() to use it.
---
 cop.h                      |  1 +
 ext/XS-APItest/Makefile.PL |  2 +-
 ext/XS-APItest/t/call.t    | 26 +++++++++++++++++++++++++-
 perl.c                     | 25 ++++++++++++++++---------
 4 files changed, 43 insertions(+), 11 deletions(-)

diff --git a/cop.h b/cop.h
index fca2aa755c..9cf85ef883 100644
--- 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 */
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 e71ecaf8fc..d851099a1d 100644
--- a/perl.c
+++ b/perl.c
@@ -3101,6 +3101,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
 */
 
@@ -3182,6 +3185,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;
@@ -3218,8 +3226,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;
@@ -3227,13 +3241,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;
 }
 
-- 
2.11.0

Argument croak_on_error for eval_pv() is broken #17036

Description

Metadata

Metadata

Assignees

Labels

Type

Projects

Milestone

Relationships

Development

Issue actions