From: Vincent Pit <vince@profvince.com>
Date: Wed, 15 Jul 2009 16:15:42 +0000 (+0200)
Subject: Turn on CvCLONE for all anonymous subs passed as hooks
X-Git-Tag: rt47902^0
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=4cb0e2cc26fbe39a7a040b090b1a1e6c2380af0f

Turn on CvCLONE for all anonymous subs passed as hooks

So that they're cloned later, which seems to fix some strange issues that arose with a5339a6ced4d5e3ad1541320476c3d6bf8ff9408 when the default callbacks were no longer capturing an external pad (which used to make them eligible for cloning).

This fixes RT #47902.
---

diff --git a/MANIFEST b/MANIFEST
index cab1db4..1bf2e07 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -25,5 +25,7 @@ t/95-portability-files.t
 t/99-kwalitee.t
 t/lib/indirect/Test0/Fffff/Vvvvvvv.pm
 t/lib/indirect/Test0/Oooooo/Pppppppp.pm
+t/lib/indirect/Test1/il1.pm
+t/lib/indirect/Test1/il2.pm
 t/lib/indirect/TestRequired1.pm
 t/lib/indirect/TestRequired2.pm
diff --git a/indirect.xs b/indirect.xs
index 57e78e1..8e6c789 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -35,6 +35,10 @@
 # define SvPVX_const SvPVX
 #endif
 
+#ifndef SvREFCNT_inc_simple_NN
+# define SvREFCNT_inc_simple_NN SvREFCNT_inc
+#endif
+
 #ifndef sv_catpvn_nomg
 # define sv_catpvn_nomg sv_catpvn
 #endif
@@ -260,12 +264,21 @@ STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
 STATIC SV *indirect_tag(pTHX_ SV *value) {
 #define indirect_tag(V) indirect_tag(aTHX_ (V))
  indirect_hint_t *h;
+ SV *code = NULL;
  dMY_CXT;
 
- value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
+ if (SvOK(value) && SvROK(value)) {
+  value = SvRV(value);
+  if (SvTYPE(value) >= SVt_PVCV) {
+   code = value;
+   if (CvANON(code) && !CvCLONED(code))
+    CvCLONE_on(code);
+   SvREFCNT_inc_simple_NN(code);
+  }
+ }
 
  h = PerlMemShared_malloc(sizeof *h);
- h->code = SvREFCNT_inc(value);
+ h->code = code;
 
 #if I_WORKAROUND_REQUIRE_PROPAGATION
  {
diff --git a/t/30-scope.t b/t/30-scope.t
index fffaad9..2b937f7 100644
--- a/t/30-scope.t
+++ b/t/30-scope.t
@@ -6,7 +6,7 @@ use warnings;
 my $tests;
 BEGIN { $tests = 18 }
 
-use Test::More tests => 1 + $tests + 1 + 2 + 3 + 5;
+use Test::More tests => 1 + $tests + 1 + 2 + 3 + 5 + 1;
 
 use lib 't/lib';
 
@@ -104,6 +104,16 @@ sub expect {
  is_deeply \@w, [ ],           'second require test doesn\'t have more errors';
 }
 
+{
+ eval <<' SNIP';
+  return;
+  no indirect ':fatal';
+  use indirect::Test1::il1 ();
+  use indirect::Test1::il2 ();
+ SNIP
+ is $@, '', 'RT #47902';
+}
+
 __DATA__
 my $a = new P1;
 
diff --git a/t/lib/indirect/Test1/il1.pm b/t/lib/indirect/Test1/il1.pm
new file mode 100644
index 0000000..ac5c0e3
--- /dev/null
+++ b/t/lib/indirect/Test1/il1.pm
@@ -0,0 +1,3 @@
+no indirect ":fatal";
+
+1;
diff --git a/t/lib/indirect/Test1/il2.pm b/t/lib/indirect/Test1/il2.pm
new file mode 100644
index 0000000..ae83265
--- /dev/null
+++ b/t/lib/indirect/Test1/il2.pm
@@ -0,0 +1,3 @@
+package indirect::Test1::il2;
+import indirect::Test1::il2;
+1;