GV *
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
- const char *nend;
- const char *nsplit = NULL;
+ const char * const origname = name;
+ const char * const name_end = name + len;
+ const char *last_separator = NULL;
GV* gv;
HV* ostash = stash;
- const char * const origname = name;
SV *const error_report = MUTABLE_SV(stash);
const U32 autoload = flags & GV_AUTOLOAD;
const U32 do_croak = flags & GV_CROAK;
if (SvTYPE(stash) < SVt_PVHV)
stash = NULL;
else {
- /* The only way stash can become NULL later on is if nsplit is set,
+ /* The only way stash can become NULL later on is if last_separator is set,
which in turn means that there is no need for a SVt_PVHV case
the error reporting code. */
}
- for (nend = name; *nend || nend != (origname + len); nend++) {
- if (*nend == '\'') {
- nsplit = nend;
- name = nend + 1;
- }
- else if (*nend == ':' && *(nend + 1) == ':') {
- nsplit = nend++;
- name = nend + 1;
- }
+ {
+ /* check if the method name is fully qualified or
+ * not, and separate the package name from the actual
+ * method name.
+ *
+ * leaves last_separator pointing to the beginning of the
+ * last package separator (either ' or ::) or 0
+ * if none was found.
+ *
+ * leaves name pointing at the beginning of the
+ * method name.
+ */
+ const char *name_cursor = name;
+ const char * const name_em1 = name_end - 1; /* name_end minus 1 */
+ for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
+ if (*name_cursor == '\'') {
+ last_separator = name_cursor;
+ name = name_cursor + 1;
+ }
+ else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
+ last_separator = name_cursor++;
+ name = name_cursor + 1;
+ }
+ }
}
- if (nsplit) {
- if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
+
+ /* did we find a separator? */
+ if (last_separator) {
+ if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
stash = CopSTASH(PL_curcop);
flags |= GV_SUPER;
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvENAME_get(stash), name) );
}
- else if ((nsplit - origname) >= 7 &&
- strnEQ(nsplit - 7, "::SUPER", 7)) {
+ else if ((last_separator - origname) >= 7 &&
+ strnEQ(last_separator - 7, "::SUPER", 7)) {
/* don't autovifify if ->NoSuchStash::SUPER::method */
- stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+ stash = gv_stashpvn(origname, last_separator - origname - 7, is_utf8);
if (stash) flags |= GV_SUPER;
}
else {
/* don't autovifify if ->NoSuchStash::method */
- stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
+ stash = gv_stashpvn(origname, last_separator - origname, is_utf8);
}
ostash = stash;
}
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
+ gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
if (!gv) {
/* This is the special case that exempts Foo->import and
Foo->unimport from being an error even if there's no
gv = MUTABLE_GV(&PL_sv_yes);
else if (autoload)
gv = gv_autoload_pvn(
- ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
+ ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
);
if (!gv && do_croak) {
/* Right now this is exclusively for the benefit of S_method_common
HV_FETCH_ISEXISTS, NULL, 0)
) {
require_pv("IO/File.pm");
- gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
+ gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
if (gv)
return gv;
}
Perl_croak(aTHX_
"Can't locate object method \"%"UTF8f
"\" via package \"%"HEKf"\"",
- UTF8fARG(is_utf8, nend - name, name),
+ UTF8fARG(is_utf8, name_end - name, name),
HEKfARG(HvNAME_HEK(stash)));
}
else {
SV* packnamesv;
- if (nsplit) {
- packnamesv = newSVpvn_flags(origname, nsplit - origname,
+ if (last_separator) {
+ packnamesv = newSVpvn_flags(origname, last_separator - origname,
SVs_TEMP | is_utf8);
} else {
packnamesv = error_report;
"Can't locate object method \"%"UTF8f
"\" via package \"%"SVf"\""
" (perhaps you forgot to load \"%"SVf"\"?)",
- UTF8fARG(is_utf8, nend - name, name),
+ UTF8fARG(is_utf8, name_end - name, name),
SVfARG(packnamesv), SVfARG(packnamesv));
}
}
* with the passed gv as an argument.
*
* The "gv" parameter should be the glob.
- * "varpv" holds the name of the var, used for error messages.
+ * "varname" holds the 1-char name of the var, used for error messages.
* "namesv" holds the module name. Its refcount will be decremented.
* "flags": if flag & 1 then save the scalar before loading.
* For the protection of $! to work (it is set by this routine)
* the sv slot must already be magicalized.
*/
STATIC void
-S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const U32 flags)
+S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
+ STRLEN len, const U32 flags)
{
- const char varname = *varpv; /* varpv might be clobbered by
- load_module, so save it. For the
- moment it’s always a single char. */
const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
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));
call_sv((SV *)*gvp, G_VOID|G_DISCARD);
LEAVE;
}
- else SvREFCNT_dec_NN(namesv);
}
/*
gv_stashsvpvn_cached
Returns a pointer to the stash for a specified package, possibly
-cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
+cached. Implements both C<gv_stashpvn> and C<gv_stashsv>.
Requires one of either namesv or namepv to be non-null.
* 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;
default:
goto try_core;
}
- return addmg;
+ goto ret;
}
try_core:
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
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;
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, "!", newSVpvs("Errno"), 1);
+ require_tie_mod(gv, '!', "Errno", 5, 1);
break;
case '-': /* $- */
SvREADONLY_on(av);
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0);
+ require_tie_mod(gv, *name, "Tie::Hash::NamedCapture",23,0);
break;
}
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod(gv,name,newSVpvs("arybase"),0);
+ require_tie_mod(gv,'[',"arybase",7,0);
}
else goto magicalize;
break;
}
}
- 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
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
- require_tie_mod(gv, "!", newSVpvs("Errno"), 1);
+ require_tie_mod(gv, '!', "Errno", 5, 1);
else if (*name == '-' || *name == '+')
- require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), 0);
+ require_tie_mod(gv, *name, "Tie::Hash::NamedCapture", 23, 0);
} else if (sv_type == SVt_PV) {
if (*name == '*' || *name == '#') {
/* diag_listed_as: $* is no longer supported */
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
case '[':
- require_tie_mod(gv,name,newSVpvs("arybase"),0);
+ require_tie_mod(gv,'[',"arybase",7,0);
break;
#ifdef PERL_SAWAMPERSAND
case '`':
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);
https://perl5.git.perl.org / perl5.git / blobdiff