/* 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.
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
register GP *gp;
- bool doproto = SvTYPE(gv) > SVt_NULL;
+ const bool doproto = SvTYPE(gv) > SVt_NULL;
char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
sv_upgrade((SV*)gv, SVt_PVGV);
HV* varstash;
GV* vargv;
SV* varsv;
- char *packname = "";
+ const char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
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;
+ const I32 add = flags & ~SVf_UTF8;
+ (void)full_len;
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 ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
&& AvFILLp(av) == -1)
{
- char *pname;
+ const char *pname;
av_push(av, newSVpvn(pname = "NDBM_File",9));
gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpvn(pname = "DB_File",7));
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"))
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 ? "*" : "");
+ gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
}
IO *
void
Perl_gv_check(pTHX_ HV *stash)
{
- register HE *entry;
register I32 i;
register GV *gv;
HV *hv;
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
+ const HE *entry;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
gv_check(hv); /* nested package */
}
else if (isALPHA(*HeKEY(entry))) {
- char *file;
+ const char *file;
gv = (GV*)HeVAL(entry);
if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
continue;
}
CopLINE_set(PL_curcop, GvLINE(gv));
#ifdef USE_ITHREADS
- CopFILE(PL_curcop) = file; /* set for warning */
+ CopFILE(PL_curcop) = (char *)file; /* set for warning */
#else
CopFILEGV(PL_curcop) = gv_fetchfile(file);
#endif
}
GV *
-Perl_newGVgen(pTHX_ char *pack)
+Perl_newGVgen(pTHX_ const char *pack)
{
return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
TRUE, SVt_PVGV);
Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
{
AMT *amtp = (AMT*)mg->mg_ptr;
+ (void)sv;
+
if (amtp && AMT_AMAGIC(amtp)) {
int i;
for (i = 1; i < NofAMmeth; i++) {
for (i = 1; i < lim; i++)
amt.table[i] = Nullcv;
for (; i < NofAMmeth; i++) {
- char *cooky = (char*)PL_AMG_names[i];
+ const char *cooky = PL_AMG_names[i];
/* Human-readable form, for debugging: */
- char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
- STRLEN l = strlen(cooky);
+ const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+ const STRLEN l = strlen(cooky);
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
cp, HvNAME(stash)) );
"Inherited AUTOLOAD for a non-method deprecated", since
our caller is going through a function call, not a method call.
So return the CV for AUTOLOAD, setting $AUTOLOAD. */
- GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
+ GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
if (gv && GvCV(gv))
return GvCV(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;
+ const 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.
=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)
{
+ (void)flags;
if (len > 1) {
+ const char *name1 = name + 1;
switch (*name) {
case 'I':
- if (len == 3 && strEQ(name, "ISA"))
+ if (len == 3 && name1[1] == 'S' && name[2] == 'A')
goto yes;
break;
case 'O':
- if (len == 8 && strEQ(name, "OVERLOAD"))
+ if (len == 8 && strEQ(name1, "VERLOAD"))
goto yes;
break;
case 'S':
- if (len == 3 && strEQ(name, "SIG"))
+ 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(name, "\017PEN"))
+ if (strEQ(name1, "PEN"))
goto yes;
break;
case '\024': /* ${^TAINT} */
- if (strEQ(name, "\024AINT"))
+ if (strEQ(name1, "AINT"))
goto yes;
break;
case '\025': /* ${^UNICODE} */
- if (strEQ(name, "\025NICODE"))
+ if (strEQ(name1, "NICODE"))
+ goto yes;
+ if (strEQ(name1, "TF8LOCALE"))
goto yes;
break;
case '\027': /* ${^WARNING_BITS} */
- if (strEQ(name, "\027ARNING_BITS"))
+ if (strEQ(name1, "ARNING_BITS"))
goto yes;
break;
case '1':
case '8':
case '9':
{
- char *end = name + len;
+ const char *end = name + len;
while (--end > name) {
if (!isDIGIT(*end))
return FALSE;
projects / p5sagit/p5-mst-13.2.git / blobdiff