In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8748370e90a24f3901d476f43ed77f1ac3d861f4?hp=5969c5766a5d3f6b42a5140548d7c3d6812fec8b>
- Log ----------------------------------------------------------------- commit 8748370e90a24f3901d476f43ed77f1ac3d861f4 Author: Reini Urban <[email protected]> Date: Thu Jul 11 12:09:15 2013 -0500 [perl #118525] Return B::HEK for B::CV::GV of lexical subs A lexsub has a hek instead of a gv. Provide a ref to a PV for the name in the new B::HEK class. This crashed previously accessing the not existing SvFLAGS of the hek. M ext/B/B.pm M ext/B/B.xs commit 0d974c9d49eeff5a22550b2f774216c453689bd0 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 12 23:18:08 2013 -0700 [perl #118857] Test punct varsâ exemption from âonceâ warnings M t/lib/warnings/perl commit 2bde9ae6d41328ef8a0af7287fdbcbb982befeea Author: Father Chrysostomos <[email protected]> Date: Fri Jul 12 22:53:48 2013 -0700 [perl #113932] Make UNIVERSAL::can("STDOUT"...) work For consistency with the way method lookup works, UNIVERSAL::can(...) should treat a bareword representing a filehandle as a lookup in the IO::File package (or whichever package implements that filehandle object). M t/op/universal.t M universal.c commit db20b64061eaadedacbeffa6da95dab094e4cb40 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 12 22:40:04 2013 -0700 perldiag: reflow an entry for better splain output M pod/perldiag.pod ----------------------------------------------------------------------- Summary of changes: ext/B/B.pm | 25 +++++++++++++++++++++++++ ext/B/B.xs | 42 +++++++++++++++++++++++++++++++++++++++++- pod/perldiag.pod | 4 ++-- t/lib/warnings/perl | 10 ++++++++++ t/op/universal.t | 6 +----- universal.c | 3 +++ 6 files changed, 82 insertions(+), 8 deletions(-) diff --git a/ext/B/B.pm b/ext/B/B.pm index 8b13dea..85c0bfe 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -1244,6 +1244,8 @@ Since perl 5.17.1 Perl 5.18 introduces a new class, B::PADLIST, returned by B::CV's C<PADLIST> method. +Perl 5.18.1 and 5.19 introduce a new class, B::HEK, returned by B::CV's +C<GV> method for lexical subs. =head2 B::PADLIST Methods @@ -1265,6 +1267,29 @@ rather than a list of all of them. =back +=head2 B::HEK Methods + +A B::HEK is returned by B::CV->GV for a lexical sub, defining its name. +Using the dereferenced scalar value of the object returns the string value, +which is usually enough; the other methods are rarely needed. + + use B; + use feature 'lexical_subs'; + my sub p {1}; + $cv = B::svref_2object(\&p); + $hek = $cv->GV; + print $$hek, "==", $hek->KEY; + +=over 4 + +=item KEY + +=item LEN + +=item FLAGS + +=back + =head2 $B::overlay Although the optree is read-only, there is an overlay facility that allows diff --git a/ext/B/B.xs b/ext/B/B.xs index fbe6be6..444d2fe 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -296,6 +296,17 @@ make_sv_object(pTHX_ SV *sv) } static SV * +make_hek_object(pTHX_ HEK *hek) +{ + SV *ret = sv_setref_pvn(sv_newmortal(), "B::HEK", HEK_KEY(hek), HEK_LEN(hek)); + SV *rv = SvRV(ret); + SvIOKp_on(rv); + SvIV_set(rv, PTR2IV(hek)); + SvREADONLY_on(rv); + return ret; +} + +static SV * make_temp_object(pTHX_ SV *temp) { SV *target; @@ -602,6 +613,7 @@ typedef IO *B__IO; typedef MAGIC *B__MAGIC; typedef HE *B__HE; +typedef HEK *B__HEK; typedef struct refcounted_he *B__RHE; #ifdef PadlistARRAY typedef PADLIST *B__PADLIST; @@ -1390,7 +1402,10 @@ IVX(sv) ptr = (ix & 0xFFFF) + (char *)SvANY(sv); switch ((U8)(ix >> 16)) { case (U8)(sv_SVp >> 16): - ret = make_sv_object(aTHX_ *((SV **)ptr)); + if ((ix == (PVCV_gv_ix)) && CvNAMED(sv)) + ret = make_hek_object(aTHX_ CvNAME_HEK((CV*)sv)); + else + ret = make_sv_object(aTHX_ *((SV **)ptr)); break; case (U8)(sv_IVp >> 16): ret = sv_2mortal(newSViv(*((IV *)ptr))); @@ -1588,6 +1603,31 @@ PV(sv) } ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8); +MODULE = B PACKAGE = B::HEK + +void +KEY(hek) + B::HEK hek + ALIAS: + LEN = 1 + FLAGS = 2 + PPCODE: + SV *pv; + switch (ix) { + case 0: + pv = newSVpvn(HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) SvUTF8_on(pv); + SvREADONLY_on(pv); + PUSHs(pv); + break; + case 1: + mPUSHu(HEK_LEN(hek)); + break; + case 2: + mPUSHu(HEK_FLAGS(hek)); + break; + } + MODULE = B PACKAGE = B::PVMG void diff --git a/pod/perldiag.pod b/pod/perldiag.pod index a6c105c..2d31a09 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3121,8 +3121,8 @@ local() if you want to localize a package variable. (W once) Typographical errors often show up as unique variable names. If you had a good reason for having a unique name, then just mention it -again somehow to suppress the message. The C<our> declaration is -provided for this purpose. +again somehow to suppress the message. The C<our> declaration is provided +for this purpose. NOTE: This warning detects symbols that have been used only once so $c, @c, %c, *c, &c, sub c{}, c(), and c (the filehandle or format) are considered diff --git a/t/lib/warnings/perl b/t/lib/warnings/perl index a00ed62..3a0af11 100644 --- a/t/lib/warnings/perl +++ b/t/lib/warnings/perl @@ -39,6 +39,16 @@ $z = 3 EXPECT Name "main::x" used only once: possible typo at - line 3. ######## +# perl.c +use warnings 'once'; +$\; # test a few +$:; # punct vars +$0; # and +$123; # numbers +$_; # and +$_foo; # underscores (none of which should warn) +EXPECT +######## -W # perl.c no warnings 'once' ; diff --git a/t/op/universal.t b/t/op/universal.t index 7ca51fb..7b5cdb0 100644 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -114,11 +114,7 @@ ok UNIVERSAL::can(23, "can"), '23 can can when the pack exists'; sub IO::Handle::turn {} ok UNIVERSAL::can(*STDOUT, 'turn'), 'globs with IOs can'; ok UNIVERSAL::can(\*STDOUT, 'turn'), 'globrefs with IOs can'; -{ - local $::TODO = '[perl #113932]'; - # Should this pass? Or is the existing behaviour correct? - ok UNIVERSAL::can("STDOUT", 'turn'), 'IO barewords can'; -} +ok UNIVERSAL::can("STDOUT", 'turn'), 'IO barewords can'; ok $a->can("VERSION"); diff --git a/universal.c b/universal.c index 97231e2..a57572b 100644 --- a/universal.c +++ b/universal.c @@ -348,6 +348,7 @@ XS(XS_UNIVERSAL_can) SV *sv; SV *rv; HV *pkg = NULL; + GV *iogv; if (items != 2) croak_xs_usage(cv, "object-ref, method"); @@ -373,6 +374,8 @@ XS(XS_UNIVERSAL_can) } else if (isGV_with_GP(sv) && GvIO(sv)) pkg = SvSTASH(GvIO(sv)); + else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv)) + pkg = SvSTASH(GvIO(iogv)); else { pkg = gv_stashsv(sv, 0); if (!pkg) -- Perl5 Master Repository
