diff options
author | Tony Cook <tony@develop-help.com> | 2013-07-25 12:09:00 +1000 |
---|---|---|
committer | Ricardo Signes <rjbs@cpan.org> | 2013-07-29 21:18:09 -0400 |
commit | e6c4c33220ccb1253bd58e54cc2f5fbf6ac9d5de (patch) | |
tree | 03109c738a4d41bf224764e621190a5d85ce7fcf | |
parent | a183b355664edd52456e891b72da9d326050e0cd (diff) | |
download | perl-e6c4c33220ccb1253bd58e54cc2f5fbf6ac9d5de.tar.gz |
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
-rw-r--r-- | ext/B/B.pm | 6 | ||||
-rw-r--r-- | ext/B/B.xs | 22 | ||||
-rw-r--r-- | ext/B/t/b.t | 39 |
3 files changed, 65 insertions, 2 deletions
diff --git a/ext/B/B.pm b/ext/B/B.pm index 8856a32aa9..bd2cf66b62 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.42'; + $B::VERSION = '1.42_01'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -1014,6 +1014,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 e2ebdaddb7..d933a56bda 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1380,7 +1380,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 @@ -1873,6 +1872,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 a065375639..d58d2e06f0 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(); |