From: Tony Cook <tony@develop-help.com>
Date: Thu, 25 Jul 2013 02:09:00 +0000 (+1000)
Subject: CvGV is no longer a simple struct member access
X-Git-Tag: v5.19.3~314
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/486b1e7f08f6ed37f4e5b11823cc569ad2140246?ds=inline

CvGV is no longer a simple struct member access

The same slot is also used for the NAME_HEK for lexical subs, so:

- split B::CV::GV out into its own function that uses the CvGV macro

- add B::CV::NAME_HEK so the name of a lexical sub can be fetched
---

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 8b13dea..35b81cf 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -15,7 +15,7 @@ require Exporter;
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.44';
+    $B::VERSION = '1.45';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
@@ -1019,6 +1019,10 @@ For constant subroutines, returns the constant SV returned by the subroutine.
 
 =item const_sv
 
+=item NAME_HEK
+
+Returns the name of a lexical sub, otherwise C<undef>.
+
 =back
 
 =head2 B::HV Methods
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 20eeba8..85e53cc 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1400,7 +1400,6 @@ IVX(sv)
 	B::IO::IoFLAGS = PVIO_flags_ix
 	B::AV::MAX = PVAV_max_ix
 	B::CV::STASH = PVCV_stash_ix
-	B::CV::GV = PVCV_gv_ix
 	B::CV::FILE = PVCV_file_ix
 	B::CV::OUTSIDE = PVCV_outside_ix
 	B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
@@ -1903,6 +1902,27 @@ const_sv(cv)
     PPCODE:
 	PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
 
+void
+GV(cv)
+	B::CV cv
+    PREINIT:
+        GV *gv;
+    CODE:
+	gv = CvGV(cv);
+	ST(0) = gv ? make_sv_object((SV*)gv) : &PL_sv_undef;
+
+#if PERL_VERSION > 17
+
+SV *
+NAME_HEK(cv)
+	B::CV cv
+    CODE:
+	RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
+    OUTPUT:
+	RETVAL
+
+#endif
+
 MODULE = B	PACKAGE = B::HV		PREFIX = Hv
 
 STRLEN
diff --git a/ext/B/t/b.t b/ext/B/t/b.t
index a065375..d58d2e0 100644
--- a/ext/B/t/b.t
+++ b/ext/B/t/b.t
@@ -376,4 +376,43 @@ SKIP: {
     is($op->name, "leavesub", "overlay: orig name");
 }
 
+{ # [perl #118525]
+    {
+        sub foo {}
+	my $cv = B::svref_2object(\&foo);
+	ok($cv, "make a B::CV from a non-anon sub reference");
+	isa_ok($cv, "B::CV");
+	my $gv = $cv->GV;
+	ok($gv, "we get a GV from a GV on a normal sub");
+	isa_ok($gv, "B::GV");
+	is($gv->NAME, "foo", "check the GV name");
+      SKIP:
+	{ # do we need these version checks?
+	    skip "no HEK before 5.18", 1 if $] < 5.018;
+	    is($cv->NAME_HEK, undef, "no hek for a global sub");
+	}
+    }
+
+SKIP:
+    {
+        skip "no HEK before 5.18", 4 if $] < 5.018;
+        eval <<'EOS'
+    {
+        use feature 'lexical_subs';
+        no warnings 'experimental::lexical_subs';
+        my sub bar {};
+        my $cv = B::svref_2object(\&bar);
+        ok($cv, "make a B::CV from a lexical sub reference");
+        isa_ok($cv, "B::CV");
+        my $gv = $cv->GV;
+        is($gv, undef, "GV on a lexical sub is NULL");
+        my $hek = $cv->NAME_HEK;
+        is($hek, "bar", "check the NAME_HEK");
+    }
+    1;
+EOS
+	  or die "lexical_subs test failed to compile: $@";
+    }
+}
+
 done_testing();