From c2e77d414d2a2e36c61a1774d7450d2fdd4ae3b0 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 24 Aug 2023 15:07:00 +1000
Subject: [PATCH] make a new stub to clone into when pushing a new pad

This previously put the same CV into the inner pad, so on a
recursive call into the owning sub, from this sub, this CV would
still be active, and the attempt to clone into the still busy CV
would throw.

Fixes #18606
---
 pad.c         | 15 +++++++++++--
 t/op/lexsub.t | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 71 insertions(+), 3 deletions(-)

diff --git a/pad.c b/pad.c
index e8a3ab1b8385f..33b69a31324d4 100644
--- a/pad.c
+++ b/pad.c
@@ -2460,8 +2460,19 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
                         || PadnameIsSTATE(names[ix])
                         || sigil == '&')
                 {
-                    /* outer lexical or anon code */
-                    sv = SvREFCNT_inc(oldpad[ix]);
+                    SV *tmp = oldpad[ix];
+                    if (sigil == '&' && SvTYPE(tmp) == SVt_PVCV
+                        && !PadnameOUTER(names[ix])
+                        && CvLEXICAL(tmp) && CvCLONED(tmp)
+                        && !PadnameIsOUR(names[ix])
+                        && !PadnameIsSTATE(names[ix])) {
+                        /* lexical sub that needs cloning */
+                        sv = newSV_type(SVt_PVCV);
+                    }
+                    else {
+                        /* outer non-cloning lexical or anon code */
+                        sv = SvREFCNT_inc(oldpad[ix]);
+                    }
                 }
                 else {		/* our own lexical */
                     if (sigil == '@')
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index 25582fceea31b..565155074745c 100644
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -7,7 +7,8 @@ BEGIN {
     *bar::is = *is;
     *bar::like = *like;
 }
-plan 152;
+
+plan 156;
 
 # -------------------- our -------------------- #
 
@@ -979,3 +980,59 @@ is join("-", qw(aa bb), do { my sub lleexx; 123 }, qw(cc dd)),
     }
     nested();
 }
+
+SKIP:
+{
+    # github #18606
+    sub rec1 {
+        my $x = shift;
+        my sub b { $x };
+        rec1(2) if $x == 1;
+        return b();
+    }
+    is(rec1(1), 1, "check recursively defined lexical sub is lexical");
+
+    sub rec2 {
+        my ($x, $name) = @_;
+
+        my sub b;
+        if ($x) {
+            # provides definition for my sub b
+            sub b { $name }
+        }
+        rec2($x-1, "inner") if $x;
+
+        b();
+    }
+    is(rec2(0, "outer"), "outer", "check again");
+    is(rec2(1, "outer"), "outer", "check some more");
+
+    fresh_perl_like(<<'EOS', qr/result=103/, {}, "test code from #18606");
+use strict; use warnings; use feature qw/say state/;
+say "Perl version $^V";
+
+sub process($;$) {
+  my ($value, $callback) = @_;
+  say "### process($value,", ($callback//"undef"), ")";
+
+  my sub inner {
+    if ($callback) {
+      return $callback->($value+1);
+    } else {
+      return $value+1;
+    }
+  }
+
+  inner();
+}
+
+my $result =
+  process(1, sub{
+                 my $arg = shift;
+                 say "#   callback called with arg $arg";
+                 process($arg+100);
+              });
+say "result=", ($result//"undef");
+EOS
+
+}