In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/5e196316f76f6f3ce68647b65f6a2609b286674b?hp=5b2ef88ec2b538ad872eb354160909d8bd529aa7>
- Log ----------------------------------------------------------------- commit 5e196316f76f6f3ce68647b65f6a2609b286674b Author: Father Chrysostomos <spr...@cpan.org> Date: Thu Aug 4 23:24:18 2016 -0700 Add Chris Travers to AUTHORS M AUTHORS commit 458470f62360040dcd4b5a55c8ba07503e1af5fc Author: Father Chrysostomos <spr...@cpan.org> Date: Thu Aug 4 23:23:09 2016 -0700 [perl #128769] Improve base.pm @INC . message The new version is based on one written by Chris Travers, polished up a bit by yours truly. M dist/base/lib/base.pm M dist/base/t/incdot.t ----------------------------------------------------------------------- Summary of changes: AUTHORS | 1 + dist/base/lib/base.pm | 9 ++++++-- dist/base/t/incdot.t | 2 +- embed.fnc | 2 +- embed.h | 2 +- gv.c | 63 ++++++++++++++++++++++++--------------------------- proto.h | 2 +- 7 files changed, 41 insertions(+), 40 deletions(-) diff --git a/AUTHORS b/AUTHORS index e3dc53a..3fbbc9c 100644 --- a/AUTHORS +++ b/AUTHORS @@ -235,6 +235,7 @@ Chris Lightfoot <ch...@ex-parrot.com> Chris Nandor <pu...@pobox.com> Chris Pepper Chris R. Donnelly <chris.donne...@vauto.com> +Chris Travers <chris.trav...@gmail.com> Chris Tubutis <ch...@broadband.att.com> Chris Wick <cw...@lmc.com> Chris Williams <chr...@netinfo.com.au> diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm index c7f9963..38c91c7 100644 --- a/dist/base/lib/base.pm +++ b/dist/base/lib/base.pm @@ -122,8 +122,13 @@ Base class package "$base" is empty. ERROR if ($dotty && -e $fn) { $e .= <<ERROS; - If you mean to load $fn from the current directory, you may - want to try "use lib '.'". + The file $fn does exist in the current directory. But note + that base.pm, when loading a module, now ignores the current working + directory if it is the last entry in \@INC. If your software worked on + previous versions of Perl, the best solution is to use FindBin to + detect the path properly and to add that path to \@INC. As a last + resort, you can re-enable looking in the current working directory by + adding "use lib '.'" to your code. ERROS } $e =~ s/\n\z/)\n/; diff --git a/dist/base/t/incdot.t b/dist/base/t/incdot.t index fadebc4..1619492 100644 --- a/dist/base/t/incdot.t +++ b/dist/base/t/incdot.t @@ -15,5 +15,5 @@ like $@, qr/\@INC contains: $inc\).\)/, 'Error does not list final dot in @INC (or mention use lib)'; eval { 'base'->import('t::lib::Dummy') }; like $@, qr<\@INC contains: $inc\).\n(?x: - ) If you mean to load t/lib/Dummy\.pm from the current >, + ) The file t/lib/Dummy\.pm does exist in the current direct>, 'special cur dir message for existing files in . that are ignored'; diff --git a/embed.fnc b/embed.fnc index baa15b2..f2e48ab 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1933,7 +1933,7 @@ s |bool|find_default_stash|NN HV **stash|NN const char *name \ |STRLEN len|const U32 is_utf8|const I32 add \ |const svtype sv_type s |bool|gv_magicalize|NN GV *gv|NN HV *stash|NN const char *name \ - |STRLEN len|bool addmg \ + |STRLEN len \ |const svtype sv_type s |void|maybe_multimagic_gv|NN GV *gv|NN const char *name|const svtype sv_type s |bool|gv_is_in_main|NN const char *name|STRLEN len \ diff --git a/embed.h b/embed.h index 930ea91..7b4efff 100644 --- a/embed.h +++ b/embed.h @@ -1538,7 +1538,7 @@ #define gv_fetchmeth_internal(a,b,c,d,e,f) S_gv_fetchmeth_internal(aTHX_ a,b,c,d,e,f) #define gv_init_svtype(a,b) S_gv_init_svtype(aTHX_ a,b) #define gv_is_in_main(a,b,c) S_gv_is_in_main(aTHX_ a,b,c) -#define gv_magicalize(a,b,c,d,e,f) S_gv_magicalize(aTHX_ a,b,c,d,e,f) +#define gv_magicalize(a,b,c,d,e) S_gv_magicalize(aTHX_ a,b,c,d,e) #define gv_magicalize_isa(a) S_gv_magicalize_isa(aTHX_ a) #define gv_stashpvn_internal(a,b,c) S_gv_stashpvn_internal(aTHX_ a,b,c) #define gv_stashsvpvn_cached(a,b,c,d) S_gv_stashsvpvn_cached(aTHX_ a,b,c,d) diff --git a/gv.c b/gv.c index 0fd789d..e24a193 100644 --- a/gv.c +++ b/gv.c @@ -1312,7 +1312,6 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char * name, load_module, so save it. For the moment itâs always a single char. */ const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv); - SV * const namesv = newSVpvn(name, len); PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; @@ -1326,27 +1325,26 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char * name, dSP; ENTER; - SAVEFREESV(namesv); #define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0) /* Load the module if it is not loaded. */ - if (!(stash = gv_stashsv(namesv, 0)) + if (!(stash = gv_stashpvn(name, len, 0)) || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) { - SV *module = newSVsv(namesv); + SV * const module = newSVpvn(name, len); const char type = varname == '[' ? '$' : '%'; if ( flags & 1 ) save_scalar(gv); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); assert(sp == PL_stack_sp); - stash = gv_stashsv(namesv, 0); + stash = gv_stashpvn(name, len, 0); if (!stash) - Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", - type, varname, SVfARG(namesv)); + Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", + type, varname, name); else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) - Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not define _tie_it", - type, varname, SVfARG(namesv)); + Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", + type, varname, name); } /* Now call the tie function. It should be in *gvp. */ assert(gvp); assert(*gvp); assert(GvCV(*gvp)); @@ -1356,7 +1354,6 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, const char * name, call_sv((SV *)*gvp, G_VOID|G_DISCARD); LEAVE; } - else SvREFCNT_dec_NN(namesv); } /* @@ -1817,15 +1814,14 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, * Note that it does not insert the GV into the stash prior to * magicalization, which some variables require need in order * to work (like $[, %+, %-, %!), so callers must take care of - * that beforehand. + * that. * - * The return value has a specific meaning for gv_fetchpvn_flags: - * If it returns true, and the gv is empty, it indicates that its - * refcount should be decreased. + * It returns true if the gv did turn out to be magical one; i.e., + * if gv_magicalize actually did something. */ PERL_STATIC_INLINE bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, - bool addmg, const svtype sv_type) + const svtype sv_type) { SSize_t paren; @@ -1862,7 +1858,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, default: goto try_core; } - return addmg; + goto ret; } try_core: if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { @@ -2013,7 +2009,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, this test */ UV uv; if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) - return addmg; + goto ret; /* XXX why are we using a SSize_t? */ paren = (SSize_t)(I32)uv; goto storeparen; @@ -2189,7 +2185,13 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, } } - return addmg; + ret: + /* Return true if we actually did something. */ + return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) + || ( GvSV(gv) && ( + SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)) + ) + ); } /* If we do ever start using this later on in the file, we need to make @@ -2352,29 +2354,22 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) ) GvMULTI_on(gv) ; -#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \ - || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv)))) - /* set up magic where warranted */ - if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) { + if ( gv_magicalize(gv, stash, name, len, sv_type) ) { /* See 23496c6 */ - if (GvEMPTY(gv)) { - if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) { - /* The GV was and still is "empty", except that now - * it has the magic flags turned on, so we want it + if (addmg) { + /* gv_magicalize magicalised this gv, so we want it * stored in the symtab. + * Effectively the caller is asking, âDoes this gv exist?â + * And we respond, âEr, *now* it does!â */ (void)hv_store(stash,name,len,(SV *)gv,0); - } - else { - /* Most likely the temporary GV created above */ + } + } + else if (addmg) { + /* The temporary GV created above */ SvREFCNT_dec_NN(gv); gv = NULL; - } - } - else - /* Not empty; this means gv_magicalize magicalised it. */ - (void)hv_store(stash,name,len,(SV *)gv,0); } if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); diff --git a/proto.h b/proto.h index 3cdb21c..f047e46 100644 --- a/proto.h +++ b/proto.h @@ -4308,7 +4308,7 @@ STATIC void S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type); STATIC bool S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8); #define PERL_ARGS_ASSERT_GV_IS_IN_MAIN \ assert(name) -STATIC bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, bool addmg, const svtype sv_type); +STATIC bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, const svtype sv_type); #define PERL_ARGS_ASSERT_GV_MAGICALIZE \ assert(gv); assert(stash); assert(name) STATIC void S_gv_magicalize_isa(pTHX_ GV *gv); -- Perl5 Master Repository