/* gv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
GV *
-Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
+Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
+ STRLEN len = strlen (nambeg);
+ return gv_fetchpvn_flags(nambeg, len, add, sv_type);
+}
+
+GV *
+Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
+ STRLEN len;
+ const char *nambeg = SvPV(name, len);
+ return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
+}
+
+GV *
+Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
+ I32 sv_type)
{
register const char *name = nambeg;
register GV *gv = 0;
I32 len;
register const char *namend;
HV *stash = 0;
+ I32 add = flags & ~SVf_UTF8;
if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
name++;
/* set up magic where warranted */
if (len > 1) {
+#ifndef EBCDIC
if (*name > 'V' ) {
/* Nothing else to do.
The compiler will probably turn the switch statement into a
branch table. Make sure we avoid even that small overhead for
the common case of lower case variable names. */
- } else {
+ } else
+#endif
+ {
const char *name2 = name + 1;
switch (*name) {
case 'A':
if (strEQ(name2, "AINT"))
goto ro_magicalize;
break;
- case '\025': /* $^UNICODE */
+ case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
if (strEQ(name2, "NICODE"))
goto ro_magicalize;
+ if (strEQ(name2, "TF8LOCALE"))
+ goto ro_magicalize;
break;
case '\027': /* $^WARNING_BITS */
if (strEQ(name2, "ARNING_BITS"))
}
}
}
- } else if (len == 1) {
- /* Names of length 1. */
+ } else {
+ /* Names of length 1. (Or 0. But name is NUL terminated, so that will
+ be case '\0' in this switch statement (ie a default case) */
switch (*name) {
case '&':
case '`':
break;
case '\026': /* $^V */
{
- SV *sv = GvSV(gv);
+ SV * const sv = GvSV(gv);
GvSV(gv) = new_version(PL_patchlevel);
SvREADONLY_on(GvSV(gv));
SvREFCNT_dec(sv);
}
void
-Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
- char *name;
- HV *hv = GvSTASH(gv);
+ const char *name;
+ const HV * const hv = GvSTASH(gv);
if (!hv) {
SvOK_off(sv);
return;
}
void
-Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
+Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
{
gv_fullname4(sv, gv, prefix, TRUE);
}
void
-Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
{
- GV *egv = GvEGV(gv);
+ const GV *egv = GvEGV(gv);
if (!egv)
egv = gv;
gv_fullname4(sv, egv, prefix, keepmain);
}
void
-Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
+Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
{
gv_efullname4(sv, gv, prefix, TRUE);
}
-/* XXX compatibility with versions <= 5.003. */
+/* compatibility with versions <= 5.003. */
void
-Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
+Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
{
- gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+ gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
}
-/* XXX compatibility with versions <= 5.003. */
+/* compatibility with versions <= 5.003. */
void
-Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
+Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
{
gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}
}
/*
+=for apidoc is_gv_magical_sv
+
+Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
+
+=cut
+*/
+
+bool
+Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
+{
+ STRLEN len;
+ char *temp = SvPV(name, len);
+ return is_gv_magical(temp, len, flags);
+}
+
+/*
=for apidoc is_gv_magical
Returns C<TRUE> if given the name of a magical GV.
C<flags> is not used at present but available for future extension to
allow selecting particular classes of magical variable.
+Currently assumes that C<name> is NUL terminated (as well as len being valid).
+This assumption is met by all callers within the perl core, which all pass
+pointers returned by SvPV.
+
=cut
*/
bool
-Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
+Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
{
- if (!len)
- return FALSE;
-
- switch (*name) {
- case 'I':
- if (len == 3 && strEQ(name, "ISA"))
- goto yes;
- break;
- case 'O':
- if (len == 8 && strEQ(name, "OVERLOAD"))
- goto yes;
- break;
- case 'S':
- if (len == 3 && strEQ(name, "SIG"))
- goto yes;
- break;
- case '\017': /* $^O & $^OPEN */
- if (len == 1
- || (len == 4 && strEQ(name, "\017PEN")))
- {
- goto yes;
- }
- break;
- case '\025':
- if (len > 1 && strEQ(name, "\025NICODE"))
- goto yes;
- case '\027': /* $^W & $^WARNING_BITS */
- if (len == 1
- || (len == 12 && strEQ(name, "\027ARNING_BITS"))
- )
+ if (len > 1) {
+ const char *name1 = name + 1;
+ switch (*name) {
+ case 'I':
+ if (len == 3 && name1[1] == 'S' && name[2] == 'A')
+ goto yes;
+ break;
+ case 'O':
+ if (len == 8 && strEQ(name1, "VERLOAD"))
+ goto yes;
+ break;
+ case 'S':
+ if (len == 3 && name[1] == 'I' && name[2] == 'G')
+ goto yes;
+ break;
+ /* Using ${^...} variables is likely to be sufficiently rare that
+ it seems sensible to avoid the space hit of also checking the
+ length. */
+ case '\017': /* ${^OPEN} */
+ if (strEQ(name1, "PEN"))
+ goto yes;
+ break;
+ case '\024': /* ${^TAINT} */
+ if (strEQ(name1, "AINT"))
+ goto yes;
+ break;
+ case '\025': /* ${^UNICODE} */
+ if (strEQ(name1, "NICODE"))
+ goto yes;
+ if (strEQ(name1, "TF8LOCALE"))
+ goto yes;
+ break;
+ case '\027': /* ${^WARNING_BITS} */
+ if (strEQ(name1, "ARNING_BITS"))
+ goto yes;
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
{
- goto yes;
- }
- break;
-
- case '&':
- case '`':
- case '\'':
- case ':':
- case '?':
- case '!':
- case '-':
- case '#':
- case '[':
- case '^':
- case '~':
- case '=':
- case '%':
- case '.':
- case '(':
- case ')':
- case '<':
- case '>':
- case ',':
- case '\\':
- case '/':
- case '|':
- case '+':
- case ';':
- case ']':
- case '\001': /* $^A */
- case '\003': /* $^C */
- case '\004': /* $^D */
- case '\005': /* $^E */
- case '\006': /* $^F */
- case '\010': /* $^H */
- case '\011': /* $^I, NOT \t in EBCDIC */
- case '\014': /* $^L */
- case '\016': /* $^N */
- case '\020': /* $^P */
- case '\023': /* $^S */
- case '\026': /* $^V */
- if (len == 1)
- goto yes;
- break;
- case '\024': /* $^T, ${^TAINT} */
- if (len == 1 || strEQ(name, "\024AINT"))
- goto yes;
- break;
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- if (len > 1) {
- char *end = name + len;
+ const char *end = name + len;
while (--end > name) {
if (!isDIGIT(*end))
return FALSE;
}
+ goto yes;
+ }
+ }
+ } else {
+ /* Because we're already assuming that name is NUL terminated
+ below, we can treat an empty name as "\0" */
+ switch (*name) {
+ case '&':
+ case '`':
+ case '\'':
+ case ':':
+ case '?':
+ case '!':
+ case '-':
+ case '#':
+ case '[':
+ case '^':
+ case '~':
+ case '=':
+ case '%':
+ case '.':
+ case '(':
+ case ')':
+ case '<':
+ case '>':
+ case ',':
+ case '\\':
+ case '/':
+ case '|':
+ case '+':
+ case ';':
+ case ']':
+ case '\001': /* $^A */
+ case '\003': /* $^C */
+ case '\004': /* $^D */
+ case '\005': /* $^E */
+ case '\006': /* $^F */
+ case '\010': /* $^H */
+ case '\011': /* $^I, NOT \t in EBCDIC */
+ case '\014': /* $^L */
+ case '\016': /* $^N */
+ case '\017': /* $^O */
+ case '\020': /* $^P */
+ case '\023': /* $^S */
+ case '\024': /* $^T */
+ case '\026': /* $^V */
+ case '\027': /* $^W */
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ yes:
+ return TRUE;
+ default:
+ break;
}
- yes:
- return TRUE;
- default:
- break;
}
return FALSE;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff