fix memory leak in @INC filters that die [perl #92252]

diff --git a/pp_ctl.c b/pp_ctl.c
index 437bc8f..30a4d36 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -5237,6 +5237,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
     char *prune_from = NULL;
     bool read_from_cache = FALSE;
     STRLEN umaxlen;
+    SV *err = NULL;
 
     PERL_ARGS_ASSERT_RUN_USER_FILTER;
 
@@ -5315,7 +5316,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
            PUSHs(filter_state);
        }
        PUTBACK;
-       count = call_sv(filter_sub, G_SCALAR);
+       count = call_sv(filter_sub, G_SCALAR|G_EVAL);
        SPAGAIN;
 
        if (count > 0) {
@@ -5323,6 +5324,9 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
            if (SvOK(out)) {
                status = SvIV(out);
            }
+            else if (SvTRUE(ERRSV)) {
+                err = newSVsv(ERRSV);
+            }
        }
 
        PUTBACK;
@@ -5330,7 +5334,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        LEAVE_with_name("call_filter_sub");
     }
 
-    if(SvOK(upstream)) {
+    if(!err && SvOK(upstream)) {
        got_p = SvPV(upstream, got_len);
        if (umaxlen) {
            if (got_len > umaxlen) {
@@ -5344,7 +5348,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
            }
        }
     }
-    if (prune_from) {
+    if (!err && prune_from) {
        /* Oh. Too long. Stuff some in our cache.  */
        STRLEN cached_len = got_p + got_len - prune_from;
        SV *const cache = datasv;
@@ -5373,7 +5377,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        have touched the SV upstream, so it may be undefined.  If we naively
        concatenate it then we get a warning about use of uninitialised value.
     */
-    if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+    if (!err && upstream != buf_sv &&
+        (SvOK(upstream) || SvGMAGICAL(upstream))) {
        sv_catsv(buf_sv, upstream);
     }
 
@@ -5389,6 +5394,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
        }
        filter_del(S_run_user_filter);
     }
+
+    if (err)
+        croak_sv(err);
+
     if (status == 0 && read_from_cache) {
        /* If we read some data from the cache (and by getting here it implies
           that we emptied the cache) then we aren't yet at EOF, and mustn't

diff --git a/t/op/inccode.t b/t/op/inccode.t
index 938a4e0..c6dcc8a 100644 (file)
--- a/t/op/inccode.t
+++ b/t/op/inccode.t
@@ -21,7 +21,7 @@ unless (is_miniperl()) {
 
 use strict;
 
-plan(tests => 49 + !is_miniperl() * (3 + 14 * $can_fork));
+plan(tests => 53 + !is_miniperl() * (3 + 14 * $can_fork));
 
 sub get_temp_fh {
     my $f = tempfile();
@@ -226,6 +226,26 @@ eval 'use foo';
 ok( 1, 'returning PVBM ref doesn\'t segfault use' );
 shift @INC;
 
+# [perl #92252]
+{
+    my $die = sub { die };
+    my $data = [];
+    unshift @INC, sub { $die, $data };
+
+    my $initial_sub_refcnt = Internals::SvREFCNT($die);
+    my $initial_data_refcnt = Internals::SvREFCNT($data);
+
+    do "foo";
+    is(Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
+    is(Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");
+
+    do "bar";
+    is(Internals::SvREFCNT($die), $initial_sub_refcnt, "no leaks");
+    is(Internals::SvREFCNT($data), $initial_data_refcnt, "no leaks");
+
+    shift @INC;
+}
+
 exit if is_miniperl();
 
 SKIP: {