/* gv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 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.
/*
=head1 GV Functions
+
+A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
+It is a structure that holds a pointer to a scalar, an array, a hash etc,
+corresponding to $foo, @foo, %foo.
+
+GVs are usually found as values in stashes (symbol table hashes) where
+Perl stores its global variables.
+
+=cut
*/
#include "EXTERN.h"
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);
if (SvLEN(gv)) {
if (proto) {
- SvPVX(gv) = NULL;
- SvLEN(gv) = 0;
+ SvPV_set(gv, NULL);
+ SvLEN_set(gv, 0);
SvPOK_off(gv);
} else
Safefree(SvPVX(gv));
GvGP(gv) = gp_ref(gp);
GvSV(gv) = NEWSV(72,0);
GvLINE(gv) = CopLINE(PL_curcop);
- GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
+ /* XXX Ideally this cast would be replaced with a change to const char*
+ in the struct. */
+ GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
HV* varstash;
GV* vargv;
SV* varsv;
- char *packname = "";
+ const char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
- SvPVX(cv) = (char *)name; /* cast to lose constness warning */
- SvCUR(cv) = len;
+ SvPV_set(cv, (char *)name); /* cast to lose constness warning */
+ SvCUR_set(cv, len);
return gv;
}
=for apidoc gv_stashpv
Returns a pointer to the stash for a specified package. C<name> should
-be a valid UTF-8 string. If C<create> is set then the package will be
-created if it does not already exist. If C<create> is not set and the
-package does not exist then NULL is returned.
+be a valid UTF-8 string and must be null-terminated. If C<create> is set
+then the package will be created if it does not already exist. If C<create>
+is not set and the package does not exist then NULL is returned.
=cut
*/
return gv_stashpvn(name, strlen(name), create);
}
+/*
+=for apidoc gv_stashpvn
+
+Returns a pointer to the stash for a specified package. C<name> should
+be a valid UTF-8 string. The C<namelen> parameter indicates the length of
+the C<name>, in bytes. If C<create> is set then the package will be
+created if it does not already exist. If C<create> is not set and the
+package does not exist then NULL is returned.
+
+=cut
+*/
+
HV*
Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
{
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++;
if (isIDFIRST_lazy(name)) {
bool global = FALSE;
- if (isUPPER(*name)) {
- if (*name == 'S' && (
- strEQ(name, "SIG") ||
- strEQ(name, "STDIN") ||
- strEQ(name, "STDOUT") ||
- strEQ(name, "STDERR")))
+ /* name is always \0 terminated, and initial \0 wouldn't return
+ true from isIDFIRST_lazy, so we know that name[1] is defined */
+ switch (name[1]) {
+ case '\0':
+ if (*name == '_')
global = TRUE;
- else if (*name == 'I' && strEQ(name, "INC"))
+ break;
+ case 'N':
+ if (strEQ(name, "INC") || strEQ(name, "ENV"))
global = TRUE;
- else if (*name == 'E' && strEQ(name, "ENV"))
+ break;
+ case 'I':
+ if (strEQ(name, "SIG"))
global = TRUE;
- else if (*name == 'A' && (
- strEQ(name, "ARGV") ||
- strEQ(name, "ARGVOUT")))
+ break;
+ case 'T':
+ if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
+ strEQ(name, "STDERR"))
global = TRUE;
+ break;
+ case 'R':
+ if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
+ global = TRUE;
+ break;
}
- else if (*name == '_' && !name[1])
- global = TRUE;
if (global)
stash = PL_defstash;
- else if ((COP*)PL_curcop == &PL_compiling) {
+ else if (IN_PERL_COMPILETIME) {
stash = PL_curstash;
if (add && (PL_hints & HINT_STRICT_VARS) &&
sv_type != SVt_PVCV &&
sv_type != SVt_PVGV &&
sv_type != SVt_PVFM &&
sv_type != SVt_PVIO &&
- !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
+ !(len == 1 && sv_type == SVt_PV &&
+ (*name == 'a' || *name == 'b')) )
{
gvp = (GV**)hv_fetch(stash,name,len,0);
if (!gvp ||
if (!stash) {
if (add) {
- qerror(Perl_mess(aTHX_
+ register SV *err = Perl_mess(aTHX_
"Global symbol \"%s%s\" requires explicit package name",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), name));
+ : ""), name);
+ if (USE_UTF8_IN_NAMES)
+ SvUTF8_on(err);
+ qerror(err);
stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
}
else
GvMULTI_on(gv) ;
/* set up magic where warranted */
- switch (*name) {
- case 'A':
- if (strEQ(name, "ARGV")) {
- IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
- }
- break;
- case 'E':
- if (strnEQ(name, "EXPORT", 6))
- GvMULTI_on(gv);
- break;
- case 'I':
- if (strEQ(name, "ISA")) {
- AV* av = GvAVn(gv);
- GvMULTI_on(gv);
- sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
- /* NOTE: No support for tied ISA */
- if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
- && AvFILLp(av) == -1)
+ 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
+#endif
+ {
+ const char *name2 = name + 1;
+ switch (*name) {
+ case 'A':
+ if (strEQ(name2, "RGV")) {
+ IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
+ }
+ break;
+ case 'E':
+ if (strnEQ(name2, "XPORT", 5))
+ GvMULTI_on(gv);
+ break;
+ case 'I':
+ if (strEQ(name2, "SA")) {
+ AV* av = GvAVn(gv);
+ GvMULTI_on(gv);
+ sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
+ /* NOTE: No support for tied ISA */
+ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+ && AvFILLp(av) == -1)
+ {
+ const char *pname;
+ av_push(av, newSVpvn(pname = "NDBM_File",9));
+ gv_stashpvn(pname, 9, TRUE);
+ av_push(av, newSVpvn(pname = "DB_File",7));
+ gv_stashpvn(pname, 7, TRUE);
+ av_push(av, newSVpvn(pname = "GDBM_File",9));
+ gv_stashpvn(pname, 9, TRUE);
+ av_push(av, newSVpvn(pname = "SDBM_File",9));
+ gv_stashpvn(pname, 9, TRUE);
+ av_push(av, newSVpvn(pname = "ODBM_File",9));
+ gv_stashpvn(pname, 9, TRUE);
+ }
+ }
+ break;
+ case 'O':
+ if (strEQ(name2, "VERLOAD")) {
+ HV* hv = GvHVn(gv);
+ GvMULTI_on(gv);
+ hv_magic(hv, Nullgv, PERL_MAGIC_overload);
+ }
+ break;
+ case 'S':
+ if (strEQ(name2, "IG")) {
+ HV *hv;
+ I32 i;
+ if (!PL_psig_ptr) {
+ Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
+ Newz(73, PL_psig_name, SIG_SIZE, SV*);
+ Newz(73, PL_psig_pend, SIG_SIZE, int);
+ }
+ GvMULTI_on(gv);
+ hv = GvHVn(gv);
+ hv_magic(hv, Nullgv, PERL_MAGIC_sig);
+ for (i = 1; i < SIG_SIZE; i++) {
+ SV ** init;
+ init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
+ if (init)
+ sv_setsv(*init, &PL_sv_undef);
+ PL_psig_ptr[i] = 0;
+ PL_psig_name[i] = 0;
+ PL_psig_pend[i] = 0;
+ }
+ }
+ break;
+ case 'V':
+ if (strEQ(name2, "ERSION"))
+ GvMULTI_on(gv);
+ break;
+ case '\005': /* $^ENCODING */
+ if (strEQ(name2, "NCODING"))
+ goto magicalize;
+ break;
+ case '\017': /* $^OPEN */
+ if (strEQ(name2, "PEN"))
+ goto magicalize;
+ break;
+ case '\024': /* ${^TAINT} */
+ if (strEQ(name2, "AINT"))
+ goto ro_magicalize;
+ break;
+ 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"))
+ goto magicalize;
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
{
- char *pname;
- av_push(av, newSVpvn(pname = "NDBM_File",9));
- gv_stashpvn(pname, 9, TRUE);
- av_push(av, newSVpvn(pname = "DB_File",7));
- gv_stashpvn(pname, 7, TRUE);
- av_push(av, newSVpvn(pname = "GDBM_File",9));
- gv_stashpvn(pname, 9, TRUE);
- av_push(av, newSVpvn(pname = "SDBM_File",9));
- gv_stashpvn(pname, 9, TRUE);
- av_push(av, newSVpvn(pname = "ODBM_File",9));
- gv_stashpvn(pname, 9, TRUE);
+ /* ensures variable is only digits */
+ /* ${"1foo"} fails this test (and is thus writeable) */
+ /* added by japhy, but borrowed from is_gv_magical */
+ const char *end = name + len;
+ while (--end > name) {
+ if (!isDIGIT(*end)) return gv;
+ }
+ goto ro_magicalize;
}
- }
- break;
- case 'O':
- if (strEQ(name, "OVERLOAD")) {
- HV* hv = GvHVn(gv);
- GvMULTI_on(gv);
- hv_magic(hv, Nullgv, PERL_MAGIC_overload);
- }
- break;
- case 'S':
- if (strEQ(name, "SIG")) {
- HV *hv;
- I32 i;
- if (!PL_psig_ptr) {
- Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
- Newz(73, PL_psig_name, SIG_SIZE, SV*);
- Newz(73, PL_psig_pend, SIG_SIZE, int);
- }
- GvMULTI_on(gv);
- hv = GvHVn(gv);
- hv_magic(hv, Nullgv, PERL_MAGIC_sig);
- for (i = 1; i < SIG_SIZE; i++) {
- SV ** init;
- init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
- if (init)
- sv_setsv(*init, &PL_sv_undef);
- PL_psig_ptr[i] = 0;
- PL_psig_name[i] = 0;
- PL_psig_pend[i] = 0;
}
}
- break;
- case 'V':
- if (strEQ(name, "VERSION"))
- GvMULTI_on(gv);
- break;
-
- case '&':
- case '`':
- case '\'':
- if (
- len > 1 ||
- sv_type == SVt_PVAV ||
- sv_type == SVt_PVHV ||
- sv_type == SVt_PVCV ||
- sv_type == SVt_PVFM ||
- sv_type == SVt_PVIO
- ) { break; }
- PL_sawampersand = TRUE;
- goto ro_magicalize;
-
- case ':':
- if (len > 1)
- break;
- sv_setpv(GvSV(gv),PL_chopset);
- goto magicalize;
-
- case '?':
- if (len > 1)
- break;
+ } 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 '`':
+ case '\'':
+ if (
+ sv_type == SVt_PVAV ||
+ sv_type == SVt_PVHV ||
+ sv_type == SVt_PVCV ||
+ sv_type == SVt_PVFM ||
+ sv_type == SVt_PVIO
+ ) { break; }
+ PL_sawampersand = TRUE;
+ goto ro_magicalize;
+
+ case ':':
+ sv_setpv(GvSV(gv),PL_chopset);
+ goto magicalize;
+
+ case '?':
#ifdef COMPLEX_STATUS
- (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
+ (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
#endif
- goto magicalize;
+ goto magicalize;
- case '!':
- if (len > 1)
- break;
+ case '!':
- /* If %! has been used, automatically load Errno.pm.
- The require will itself set errno, so in order to
- preserve its value we have to set up the magic
- now (rather than going to magicalize)
- */
+ /* If %! has been used, automatically load Errno.pm.
+ The require will itself set errno, so in order to
+ preserve its value we have to set up the magic
+ now (rather than going to magicalize)
+ */
- sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
- if (sv_type == SVt_PVHV)
- require_errno(gv);
+ if (sv_type == SVt_PVHV)
+ require_errno(gv);
- break;
- case '-':
- if (len > 1)
break;
- else {
+ case '-':
+ {
AV* av = GvAVn(gv);
sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
- }
- goto magicalize;
- case '*':
- if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$* is no longer supported");
- break;
- case '#':
- if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
- Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Use of $# is deprecated");
- /* FALL THROUGH */
- case '[':
- case '^':
- case '~':
- case '=':
- case '%':
- case '.':
- case '(':
- case ')':
- case '<':
- case '>':
- case ',':
- case '\\':
- case '/':
- case '\001': /* $^A */
- case '\003': /* $^C */
- case '\004': /* $^D */
- case '\006': /* $^F */
- case '\010': /* $^H */
- case '\011': /* $^I, NOT \t in EBCDIC */
- case '\016': /* $^N */
- case '\020': /* $^P */
- if (len > 1)
- break;
- goto magicalize;
- case '|':
- if (len > 1)
- break;
- sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
- goto magicalize;
- case '\005': /* $^E && $^ENCODING */
- if (len > 1 && strNE(name, "\005NCODING"))
- break;
- goto magicalize;
-
- case '\017': /* $^O & $^OPEN */
- if (len > 1 && strNE(name, "\017PEN"))
- break;
- goto magicalize;
- case '\023': /* $^S */
- if (len > 1)
- break;
- goto ro_magicalize;
- case '\024': /* $^T, ${^TAINT} */
- if (len == 1)
- goto magicalize;
- else if (strEQ(name, "\024AINT"))
- goto ro_magicalize;
- else
- break;
- case '\025':
- if (len > 1 && strNE(name, "\025NICODE"))
- break;
- goto ro_magicalize;
-
- case '\027': /* $^W & $^WARNING_BITS */
- if (len > 1
- && strNE(name, "\027ARNING_BITS")
- )
- break;
- goto magicalize;
-
- case '+':
- if (len > 1)
+ goto magicalize;
+ }
+ case '*':
+ if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ "$* is no longer supported");
break;
- else {
- AV* av = GvAVn(gv);
+ case '#':
+ if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ "Use of $# is deprecated");
+ goto magicalize;
+ case '|':
+ sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
+ goto magicalize;
+
+ case '+':
+ {
+ AV* av = GvAVn(gv);
sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
- }
- /* FALL THROUGH */
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- /* ensures variable is only digits */
- /* ${"1foo"} fails this test (and is thus writeable) */
- /* added by japhy, but borrowed from is_gv_magical */
-
- if (len > 1) {
- const char *end = name + len;
- while (--end > name) {
- if (!isDIGIT(*end)) return gv;
- }
+ /* FALL THROUGH */
}
+ case '\023': /* $^S */
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ ro_magicalize:
+ SvREADONLY_on(GvSV(gv));
+ /* FALL THROUGH */
+ 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 '\016': /* $^N */
+ case '\017': /* $^O */
+ case '\020': /* $^P */
+ case '\024': /* $^T */
+ case '\027': /* $^W */
+ magicalize:
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+ break;
- ro_magicalize:
- SvREADONLY_on(GvSV(gv));
- magicalize:
- sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
- break;
-
- case '\014': /* $^L */
- if (len > 1)
+ case '\014': /* $^L */
+ sv_setpv(GvSV(gv),"\f");
+ PL_formfeed = GvSV(gv);
break;
- sv_setpv(GvSV(gv),"\f");
- PL_formfeed = GvSV(gv);
- break;
- case ';':
- if (len > 1)
+ case ';':
+ sv_setpv(GvSV(gv),"\034");
break;
- sv_setpv(GvSV(gv),"\034");
- break;
- case ']':
- if (len == 1) {
+ case ']':
+ {
SV *sv = GvSV(gv);
- (void)SvUPGRADE(sv, SVt_PVNV);
- Perl_sv_setpvf(aTHX_ sv,
-#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
- "%8.6"
-#else
- "%5.3"
-#endif
- NVff,
- SvNVX(PL_patchlevel));
- SvNVX(sv) = SvNVX(PL_patchlevel);
- SvNOK_on(sv);
- SvREADONLY_on(sv);
+ if (!sv_derived_from(PL_patchlevel, "version"))
+ (void *)upg_version(PL_patchlevel);
+ GvSV(gv) = vnumify(PL_patchlevel);
+ SvREADONLY_on(GvSV(gv));
+ SvREFCNT_dec(sv);
}
break;
- case '\026': /* $^V */
- if (len == 1) {
- SV *sv = GvSV(gv);
- GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
+ case '\026': /* $^V */
+ {
+ SV * const sv = GvSV(gv);
+ GvSV(gv) = new_version(PL_patchlevel);
+ SvREADONLY_on(GvSV(gv));
SvREFCNT_dec(sv);
}
break;
+ }
}
return gv;
}
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) {
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return;
}
sv_setpv(sv, prefix ? prefix : "");
- if (!HvNAME(hv))
+ name = HvNAME(hv);
+ if (!name)
name = "__ANON__";
- else
- name = HvNAME(hv);
+
if (keepmain || strNE(name, "main")) {
sv_catpv(sv,name);
sv_catpvn(sv,"::", 2);
}
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 *
/* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
- SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
+ SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
return 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);
if (gp->gp_refcnt == 0) {
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free unreferenced glob pointers");
+ "Attempt to free unreferenced glob pointers"
+ pTHX__FORMAT pTHX__VALUE);
return;
}
if (gp->gp_cv) {
return;
}
- SvREFCNT_dec(gp->gp_sv);
- SvREFCNT_dec(gp->gp_av);
- if(gp->gp_hv && HvNAME(gp->gp_hv) && PL_stashcache)
- hv_delete(PL_stashcache, HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), G_DISCARD);
- SvREFCNT_dec(gp->gp_hv);
- SvREFCNT_dec(gp->gp_io);
- SvREFCNT_dec(gp->gp_cv);
- SvREFCNT_dec(gp->gp_form);
+ if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
+ if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
+ if (gp->gp_hv) {
+ if (PL_stashcache && HvNAME(gp->gp_hv))
+ hv_delete(PL_stashcache,
+ HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
+ G_DISCARD);
+ SvREFCNT_dec(gp->gp_hv);
+ }
+ if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
+ if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
+ if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
Safefree(gp);
GvGP(gv) = 0;
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);
*/
SV* newref = newSVsv(tmpRef);
SvOBJECT_on(newref);
- SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
+ SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
return newref;
}
}
}
/*
+=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.
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"))
- )
+ (void)flags;
+ 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;
}
https://perl5.git.perl.org / perl5.git / blobdiff