{
*where = newSV_type(type);
if (type == SVt_PVAV && GvNAMELEN(gv) == 3
- && strnEQ(GvNAME(gv), "ISA", 3))
+ && strEQs(GvNAME(gv), "ISA"))
sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
}
return gv;
}
else if (stash == cachestash
&& len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
- && strnEQ(hvname, "CORE", 4)
+ && strEQs(hvname, "CORE")
&& S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
if (!gvp) {
if (len > 1 && HvNAMELEN_get(cstash) == 4) {
const char *hvname = HvNAME(cstash); assert(hvname);
- if (strnEQ(hvname, "CORE", 4)
+ if (strEQs(hvname, "CORE")
&& (candidate =
S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
))
return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
}
-/* Don't merge this yet, as it's likely to get a len parameter, and possibly
- even a U32 hash */
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) {
+ STRLEN sep_len= last_separator - origname;
+ if ( memEQs(origname, sep_len, "SUPER")) {
/* ->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 ( sep_len >= 7 &&
+ strEQs(last_separator - 7, "::SUPER")) {
/* don't autovifify if ->NoSuchStash::SUPER::method */
- stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+ stash = gv_stashpvn(origname, sep_len - 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, sep_len, 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));
}
}
ENTER;
-#define HV_FETCH_TIE_FUNC (GV **)hv_fetch(stash, "_tie_it", 7, 0)
+#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
/* Load the module if it is not loaded. */
if (!(stash = gv_stashpvn(name, len, 0))
}
}
+/* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
+ * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
+ * a true string WITHOUT a len.
+ */
+#define require_tie_mod_s(gv, varname, name, flags) \
+ S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
+
/*
=for apidoc gv_stashpv
*stash = GvHV(*gv) = newHV();
if (!HvNAME_get(*stash)) {
if (GvSTASH(*gv) == PL_defstash && *len == 6
- && strnEQ(*name, "CORE", 4))
- hv_name_set(*stash, "CORE", 4, 0);
+ && strEQs(*name, "CORE"))
+ hv_name_sets(*stash, "CORE", 0);
else
hv_name_set(
*stash, nambeg, name_cursor-nambeg, is_utf8
and VERSION. All the others apply only to the main stash or to
CORE (which is checked right after this). */
if (len) {
- const char * const name2 = name + 1;
switch (*name) {
case 'E':
- if (strnEQ(name2, "XPORT", 5))
+ if (
+ len >= 6 && name[1] == 'X' &&
+ (memEQs(name, len, "EXPORT")
+ ||memEQs(name, len, "EXPORT_OK")
+ ||memEQs(name, len, "EXPORT_FAIL")
+ ||memEQs(name, len, "EXPORT_TAGS"))
+ )
GvMULTI_on(gv);
break;
case 'I':
- if (strEQ(name2, "SA"))
+ if (memEQs(name, len, "ISA"))
gv_magicalize_isa(gv);
break;
case 'V':
- if (strEQ(name2, "ERSION"))
+ if (memEQs(name, len, "VERSION"))
GvMULTI_on(gv);
break;
case 'a':
- if (stash == PL_debstash && len==4 && strEQ(name2,"rgs")) {
+ if (stash == PL_debstash && memEQs(name, len, "args")) {
GvMULTI_on(gv_AVadd(gv));
break;
- }
+ }
+ /* FALLTHROUGH */
case 'b':
if (len == 1 && sv_type == SVt_PV)
GvMULTI_on(gv);
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* Avoid null warning: */
const char * const stashname = HvNAME(stash); assert(stashname);
- if (strnEQ(stashname, "CORE", 4))
+ if (strEQs(stashname, "CORE"))
S_maybe_add_coresub(aTHX_ 0, gv, name, len);
}
}
} else
#endif
{
- const char * name2 = name + 1;
switch (*name) {
case 'A':
- if (strEQ(name2, "RGV")) {
+ if (memEQs(name, len, "ARGV")) {
IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
}
- else if (strEQ(name2, "RGVOUT")) {
+ else if (memEQs(name, len, "ARGVOUT")) {
GvMULTI_on(gv);
}
break;
case 'E':
- if (strnEQ(name2, "XPORT", 5))
+ if (
+ len >= 6 && name[1] == 'X' &&
+ (memEQs(name, len, "EXPORT")
+ ||memEQs(name, len, "EXPORT_OK")
+ ||memEQs(name, len, "EXPORT_FAIL")
+ ||memEQs(name, len, "EXPORT_TAGS"))
+ )
GvMULTI_on(gv);
break;
case 'I':
- if (strEQ(name2, "SA")) {
+ if (memEQs(name, len, "ISA")) {
gv_magicalize_isa(gv);
}
break;
case 'S':
- if (strEQ(name2, "IG")) {
+ if (memEQs(name, len, "SIG")) {
HV *hv;
I32 i;
if (!PL_psig_name) {
}
break;
case 'V':
- if (strEQ(name2, "ERSION"))
+ if (memEQs(name, len, "VERSION"))
GvMULTI_on(gv);
break;
case '\003': /* $^CHILD_ERROR_NATIVE */
- if (strEQ(name2, "HILD_ERROR_NATIVE"))
+ if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
goto magicalize;
+ /* @{^CAPTURE} %{^CAPTURE} */
+ if (memEQs(name, len, "\003APTURE")) {
+ AV* const av = GvAVn(gv);
+ UV uv= *name;
+
+ sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
+ SvREADONLY_on(av);
+
+ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
+
+ } else /* %{^CAPTURE_ALL} */
+ if (memEQs(name, len, "\003APTURE_ALL")) {
+ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
+ }
break;
case '\005': /* $^ENCODING */
- if (strEQ(name2, "NCODING"))
+ if (memEQs(name, len, "\005NCODING"))
goto magicalize;
break;
case '\007': /* $^GLOBAL_PHASE */
- if (strEQ(name2, "LOBAL_PHASE"))
+ if (memEQs(name, len, "\007LOBAL_PHASE"))
goto ro_magicalize;
break;
case '\014': /* $^LAST_FH */
- if (strEQ(name2, "AST_FH"))
+ if (memEQs(name, len, "\014AST_FH"))
goto ro_magicalize;
break;
case '\015': /* $^MATCH */
- if (strEQ(name2, "ATCH")) {
+ if (memEQs(name, len, "\015ATCH")) {
paren = RX_BUFF_IDX_CARET_FULLMATCH;
goto storeparen;
}
break;
case '\017': /* $^OPEN */
- if (strEQ(name2, "PEN"))
+ if (memEQs(name, len, "\017PEN"))
goto magicalize;
break;
case '\020': /* $^PREMATCH $^POSTMATCH */
- if (strEQ(name2, "REMATCH")) {
+ if (memEQs(name, len, "\020REMATCH")) {
paren = RX_BUFF_IDX_CARET_PREMATCH;
goto storeparen;
}
- if (strEQ(name2, "OSTMATCH")) {
+ if (memEQs(name, len, "\020OSTMATCH")) {
paren = RX_BUFF_IDX_CARET_POSTMATCH;
goto storeparen;
}
break;
case '\024': /* ${^TAINT} */
- if (strEQ(name2, "AINT"))
+ if (memEQs(name, len, "\024AINT"))
goto ro_magicalize;
break;
case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
- if (strEQ(name2, "NICODE"))
+ if (memEQs(name, len, "\025NICODE"))
goto ro_magicalize;
- if (strEQ(name2, "TF8LOCALE"))
+ if (memEQs(name, len, "\025TF8LOCALE"))
goto ro_magicalize;
- if (strEQ(name2, "TF8CACHE"))
+ if (memEQs(name, len, "\025TF8CACHE"))
goto magicalize;
break;
case '\027': /* $^WARNING_BITS */
- if (strEQ(name2, "ARNING_BITS"))
+ if (memEQs(name, len, "\027ARNING_BITS"))
goto magicalize;
#ifdef WIN32
- else if (strEQ(name2, "IN32_SLOPPY_STAT"))
+ else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
goto magicalize;
#endif
break;
sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
- /* magicalization must be done before require_tie_mod is called */
+ /* magicalization must be done before require_tie_mod_s is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, '!', "Errno", 5, 1);
+ require_tie_mod_s(gv, '!', "Errno", 1);
break;
- case '-': /* $- */
- case '+': /* $+ */
- GvMULTI_on(gv); /* no used once warnings here */
- {
- AV* const av = GvAVn(gv);
- SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
-
- sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
- sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
- if (avc)
- SvREADONLY_on(GvSVn(gv));
- SvREADONLY_on(av);
-
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod(gv, *name, "Tie::Hash::NamedCapture",23,0);
+ case '-': /* $-, %-, @- */
+ case '+': /* $+, %+, @+ */
+ GvMULTI_on(gv); /* no used once warnings here */
+ { /* $- $+ */
+ sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
+ if (*name == '+')
+ SvREADONLY_on(GvSVn(gv));
+ }
+ { /* %- %+ */
+ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+ require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
+ }
+ { /* @- @+ */
+ AV* const av = GvAVn(gv);
+ const UV uv = (UV)*name;
+ sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
+ SvREADONLY_on(av);
+ }
break;
- }
case '*': /* $* */
case '#': /* $# */
if (sv_type == SVt_PV)
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod(gv,'[',"arybase",7,0);
+ require_tie_mod_s(gv,'[',"arybase",0);
}
else goto magicalize;
break;
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
if (*name == '!')
- require_tie_mod(gv, '!', "Errno", 5, 1);
+ require_tie_mod_s(gv, '!', "Errno", 1);
else if (*name == '-' || *name == '+')
- require_tie_mod(gv, *name, "Tie::Hash::NamedCapture", 23, 0);
+ require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 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,'[',"arybase",7,0);
+ require_tie_mod_s(gv,'[',"arybase",0);
break;
#ifdef PERL_SAWAMPERSAND
case '`':
maybe_multimagic_gv(gv, name, sv_type);
}
else if (len == 3 && sv_type == SVt_PVAV
- && strnEQ(name, "ISA", 3)
+ && strEQs(name, "ISA")
&& (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
gv_magicalize_isa(gv);
}
https://perl5.git.perl.org / perl5.git / blobdiff