Revert eval in DB fix, changing back to 5.38 CV outside referencing behaviour

cv.h

@@ -147,7 +147,7 @@ See L<perlguts/Autoloading with XSUBs>.
 #endif
 #define CVf_DYNFILE	0x1000	/* The filename is malloced  */
 #define CVf_AUTOLOAD	0x2000	/* SvPVX contains AUTOLOADed sub name  */
-/* 0x4000 previously CVf_HASEVAL  */
+#define CVf_HASEVAL	0x4000	/* contains string eval  */
 #define CVf_NAMED	0x8000  /* Has a name HEK */
 #define CVf_LEXICAL	0x10000 /* Omit package from name */
 #define CVf_ANONCONST	0x20000 /* :const - create anonconst op */
@@ -232,6 +232,10 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CvAUTOLOAD_on(cv)	(CvFLAGS(cv) |= CVf_AUTOLOAD)
 #define CvAUTOLOAD_off(cv)	(CvFLAGS(cv) &= ~CVf_AUTOLOAD)
 
+#define CvHASEVAL(cv)		(CvFLAGS(cv) & CVf_HASEVAL)
+#define CvHASEVAL_on(cv)	(CvFLAGS(cv) |= CVf_HASEVAL)
+#define CvHASEVAL_off(cv)	(CvFLAGS(cv) &= ~CVf_HASEVAL)
+
 #define CvNAMED(cv)		(CvFLAGS(cv) & CVf_NAMED)
 #define CvNAMED_on(cv)		(CvFLAGS(cv) |= CVf_NAMED)
 #define CvNAMED_off(cv)		(CvFLAGS(cv) &= ~CVf_NAMED)

dump.c

@@ -1899,6 +1899,7 @@ const struct flag_to_name cv_flags_names[] = {
     {CVf_CVGV_RC, "CVGV_RC,"},
     {CVf_DYNFILE, "DYNFILE,"},
     {CVf_AUTOLOAD, "AUTOLOAD,"},
+    {CVf_HASEVAL, "HASEVAL,"},
     {CVf_SLABBED, "SLABBED,"},
     {CVf_NAMED, "NAMED,"},
     {CVf_LEXICAL, "LEXICAL,"},

ext/Devel-Peek/t/Peek.t

@@ -364,8 +364,8 @@ do_test('reference to named subroutine without prototype',
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = (3|4)
-    FLAGS = \\((?:HASEVAL,)?(?:NAMED)?\\)	# $] < 5.015 || !thr
-    FLAGS = \\(DYNFILE(?:,HASEVAL)?(?:,NAMED)?\\) # $] >= 5.015 && thr
+    FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\)	# $] < 5.015 || !thr
+    FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
     COMP_STASH = $ADDR\\t"main"
     START = $ADDR ===> \\d+
     ROOT = $ADDR
@@ -375,8 +375,8 @@ do_test('reference to named subroutine without prototype',
     DEPTH = 1(?:
     MUTEXP = $ADDR
     OWNER = $ADDR)?
-    FLAGS = 0x(?:[c84]00)?0			# $] < 5.015 || !thr
-    FLAGS = 0x[cd1459]000			# $] >= 5.015 && thr
+    FLAGS = 0x(?:[c4]00)?0			# $] < 5.015 || !thr
+    FLAGS = 0x[cd145]000			# $] >= 5.015 && thr
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)

lib/B/Deparse.t

@@ -2150,6 +2150,7 @@ my sub g {
     sub f { }
 }
 ####
+# TODO only partially fixed
 # lexical state subroutine with outer declaration and inner definition
 # CONTEXT use feature 'lexical_subs', 'state'; no warnings 'experimental::lexical_subs';
 ();

pad.c

@@ -1684,6 +1684,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
                     "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
                 CvCLONE_on(cv);
             }
+            CvHASEVAL_on(cv);
         }
     }
 
@@ -1975,7 +1976,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
     PL_compcv = cv;
     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
 
-    CvOUTSIDE(cv) = CvREFCNT_inc_simple(outside);
+    if (CvHASEVAL(cv))
+        CvOUTSIDE(cv)	= CvREFCNT_inc_simple(outside);
 
     SAVESPTR(PL_comppad_name);
     PL_comppad_name = protopad_name;

t/op/closure.t

@@ -687,7 +687,7 @@ $r = \$x
     isnt($s[0], $s[1], "cloneable with //ee");
 }
 
-# [perl #89544] aka [GH #11286]
+# [perl #89544]
 {
    sub trace::DESTROY {
        push @trace::trace, "destroyed";
@@ -711,7 +711,6 @@ $r = \$x
    };
 
    my $inner = $outer2->();
-   local $TODO = "we need outside links for debugger behaviour";
    is "@trace::trace", "destroyed",
       'closures only close over named variables, not entire subs';
 }
@@ -812,4 +811,47 @@ sub {
 };
 test_ref_to_unavailable();
 
+{
+    # 22547
+    fresh_perl_is(<<'EOC', "OK", {}, "RT #22547");
+use builtin qw(weaken);
+
+my $wref;
+{
+    my $x;
+    my $subject = sub {
+        $x = $_[0];
+
+        my $y;
+        return sub { $y };
+    };
+    my $subscriber = {};
+    weaken($wref = $subscriber);
+    $subscriber->{foo} = $subject->($subscriber);
+}
+!defined $wref and print "OK";
+EOC
+
+    local $TODO = "still leaks with eval ''";
+    fresh_perl_is(<<'EOC', "OK", {}, "RT #22547 with eval");
+use builtin qw(weaken);
+
+my $wref;
+{
+    my $x;
+    my $subject = sub {
+        $x = $_[0];
+
+        my $y;
+        return sub { eval "1"; $y };
+    };
+    my $subscriber = {};
+    weaken($wref = $subscriber);
+    $subscriber->{foo} = $subject->($subscriber);
+}
+!defined $wref and print "OK";
+EOC
+}
+
+
 done_testing();

t/op/eval.t

@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 170);
+plan(tests => 172);
 
 eval 'pass();';
 
@@ -379,6 +379,7 @@ our $x = 1;
     is(db6(),      4);
 
     # [GH #19370]
+    local $TODO = "outside not available when needed";
     my sub d6 {
         DB::db3();
     }
@@ -391,6 +392,57 @@ our $x = 1;
     is($d7->(), 3);
 }
 
+{
+    # github 22547
+    # these produce the expected results with 5.40.0
+    local $TODO = "eval from DB outside chain is broken";
+    fresh_perl_is(<<'CODE', "1.1\n1.2\n2\n", {}, "lexical lookup from DB::");
+use builtin qw(ceil);
+use strict;
+
+package DB {
+  sub do_eval { eval shift or $@; }
+}
+
+{
+  my $xx = 1.2;
+  my sub f {
+    print DB::do_eval(shift), "\n";
+  }
+  f('1.1');
+  f('$xx');
+  f('ceil(1.1)');
+}
+CODE
+
+    # subtley different, one of the suggested solutions was to make
+    # CvOUTSIDE a weak reference, but in the case below $f exits before
+    # the eval is called, so the outside link from the closure it returns
+    # would break for a weak reference.
+    fresh_perl_is(<<'CODE', "1.1\n1.2\n2\n", {}, "lexical lookup from DB::");
+use strict;
+
+package DB {
+  sub do_eval { eval shift or $@; }
+}
+
+sub g {
+  my $yy;
+  my $f = sub {
+    $yy; # closure
+    use builtin qw(ceil);
+    our $xx = 1.2;
+    my $yy = shift;
+    return sub { print DB::do_eval($yy) || $@, "\n" };
+  };
+  return $f->(shift);
+}
+g('1.1')->();
+g('$xx')->();
+g('ceil(1.1)')->();
+CODE
+}
+
 # [perl #19022] used to end up with shared hash warnings
 # The program should generate no output, so anything we see is on stderr
 my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',