X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=d02f741e44c1442b08f56bfe988663ed6dde65f7;hb=c5375c28ff9f285618d7079f4044f72aad1773ab;hp=06982bdd9dcb066fec721d10c4f20da85f9eb6e2;hpb=8b5be85c6c6a87e2cf6fc80a9ccc8056a4d1bbf9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 06982bd..d02f741 100644 --- a/gv.c +++ b/gv.c @@ -1,7 +1,7 @@ /* gv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -45,7 +45,7 @@ Perl_gv_SVadd(pTHX_ GV *gv) if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for scalar"); if (!GvSV(gv)) - GvSV(gv) = NEWSV(72,0); + GvSV(gv) = newSV(0); return gv; } #endif @@ -73,13 +73,15 @@ Perl_gv_HVadd(pTHX_ register GV *gv) GV * Perl_gv_IOadd(pTHX_ register GV *gv) { + dVAR; if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) { /* * if it walks like a dirhandle, then let's assume that * this is a dirhandle. */ - const char *fh = PL_op->op_type == OP_READDIR || + const char * const fh = + PL_op->op_type == OP_READDIR || PL_op->op_type == OP_TELLDIR || PL_op->op_type == OP_SEEKDIR || PL_op->op_type == OP_REWINDDIR || @@ -102,13 +104,14 @@ Perl_gv_IOadd(pTHX_ register GV *gv) GV * Perl_gv_fetchfile(pTHX_ const char *name) { + dVAR; char smallbuf[256]; char *tmpbuf; STRLEN tmplen; GV *gv; if (!PL_defstash) - return Nullgv; + return NULL; tmplen = strlen(name) + 2; if (tmplen < sizeof smallbuf) @@ -128,7 +131,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) sv_setpvn(GvSV(gv), name, tmplen - 2); #endif if (PERLDB_LINE) - hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile); + hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); } if (tmpbuf != smallbuf) Safefree(tmpbuf); @@ -159,7 +162,8 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { dVAR; register GP *gp; - const bool doproto = SvTYPE(gv) > SVt_NULL; + const U32 old_type = SvTYPE(gv); + const bool doproto = old_type > SVt_NULL; const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; @@ -180,7 +184,12 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) SvROK_off(gv); } - sv_upgrade((SV*)gv, SVt_PVGV); + + if (old_type < SVt_PVGV) { + if (old_type >= SVt_PV) + SvCUR_set(gv, 0); + sv_upgrade((SV*)gv, SVt_PVGV); + } if (SvLEN(gv)) { if (proto) { SvPV_set(gv, NULL); @@ -190,11 +199,12 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) Safefree(SvPVX_mutable(gv)); } Newxz(gp, 1, GP); + SvSCREAM_on(gv); GvGP(gv) = gp_ref(gp); #ifdef PERL_DONT_CREATE_GVSV GvSV(gv) = NULL; #else - GvSV(gv) = NEWSV(72,0); + GvSV(gv) = newSV(0); #endif GvLINE(gv) = CopLINE(PL_curcop); /* XXX Ideally this cast would be replaced with a change to const char* @@ -202,12 +212,10 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 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); GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); - GvNAME(gv) = savepvn(name, len); - GvNAMELEN(gv) = len; + gv_name_set(gv, name, len, GV_ADD); if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ @@ -251,6 +259,7 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) case SVt_NULL: case SVt_PVCV: case SVt_PVFM: + case SVt_PVGV: break; default: (void)GvSVn(gv); @@ -282,6 +291,7 @@ obtained from the GV with the C macro. GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { + dVAR; AV* av; GV* topgv; GV* gv; @@ -292,7 +302,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* UNIVERSAL methods should be callable without a stash */ if (!stash) { level = -1; /* probably appropriate */ - if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE))) + if(!(stash = gv_stashpvs("UNIVERSAL", FALSE))) return 0; } @@ -309,7 +319,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) - topgv = Nullgv; + topgv = NULL; else { topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) @@ -320,14 +330,14 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) return topgv; /* Stale cached entry: junk it */ SvREFCNT_dec(cv); - GvCV(topgv) = cv = Nullcv; + GvCV(topgv) = cv = NULL; GvCVGEN(topgv) = 0; } else if (GvCVGEN(topgv) == PL_sub_generation) return 0; /* cache indicates sub doesn't exist */ } - gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; /* create and re-create @.*::SUPER::ISA on demand */ @@ -339,15 +349,15 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) packlen -= 7; basestash = gv_stashpvn(hvname, packlen, TRUE); - gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); + gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { - gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); + gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); if (!gvp || !(gv = *gvp)) Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); - GvAV(gv) = (AV*)SvREFCNT_inc(av); + GvAV(gv) = (AV*)SvREFCNT_inc_simple(av); } } } @@ -375,7 +385,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* if at top level, try UNIVERSAL */ if (level == 0 || level == -1) { - HV* const lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE); + HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE); if (lastchance) { if ((gv = gv_fetchmeth(lastchance, name, len, @@ -432,20 +442,20 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le GV **gvp; if (!stash) - return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) - return Nullgv; + return NULL; if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) - return Nullgv; + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return Nullgv; + return NULL; /* Have an autoload */ if (level < 0) /* Cannot do without a stub */ gv_fetchmeth(stash, name, len, 0); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) - return Nullgv; + return NULL; return *gvp; } return gv; @@ -482,6 +492,7 @@ C apply equally to these functions. GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { + dVAR; register const char *nend; const char *nsplit = NULL; GV* gv; @@ -503,7 +514,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ - SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", + SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); @@ -567,7 +578,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) STRLEN packname_len; if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) - return Nullgv; + return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { packname = SvPV_const((SV*)stash, packname_len); @@ -579,11 +590,11 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) } } if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) - return Nullgv; + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return Nullgv; + return NULL; /* * Inheriting AUTOLOAD for non-methods works ... for now. @@ -595,7 +606,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); - if (CvXSUB(cv)) { + if (CvISXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', @@ -620,13 +631,13 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) if (!isGV(vargv)) { gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); #ifdef PERL_DONT_CREATE_GVSV - GvSV(vargv) = NEWSV(72,0); + GvSV(vargv) = newSV(0); #endif } LEAVE; varsv = GvSVn(vargv); sv_setpvn(varsv, packname, packname_len); - sv_catpvn(varsv, "::", 2); + sv_catpvs(varsv, "::"); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; @@ -639,7 +650,7 @@ STATIC void S_require_errno(pTHX_ GV *gv) { dVAR; - HV* stash = gv_stashpvn("Errno",5,FALSE); + HV* stash = gv_stashpvs("Errno", FALSE); if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { dSP; @@ -647,10 +658,10 @@ S_require_errno(pTHX_ GV *gv) ENTER; save_scalar(gv); /* keep the value of $! */ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvn("Errno",5), Nullsv); + newSVpvs("Errno"), NULL); LEAVE; SPAGAIN; - stash = gv_stashpvn("Errno",5,FALSE); + stash = gv_stashpvs("Errno", FALSE); if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); } @@ -748,31 +759,42 @@ GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, I32 sv_type) { + dVAR; register const char *name = nambeg; register GV *gv = NULL; GV**gvp; I32 len; - register const char *namend; + register const char *name_cursor; HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; - const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND; - - PERL_UNUSED_ARG(full_len); + const I32 add = + flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL; + const char *const name_end = nambeg + full_len; + const char *const name_em1 = name_end - 1; + + if (flags & GV_NOTQUAL) { + /* Caller promised that there is no stash, so we can skip the check. */ + len = full_len; + goto no_stash; + } - if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ + if (full_len > 2 && *name == '*' && isALPHA(name[1])) { + /* accidental stringify on a GV? */ name++; + } - for (namend = name; *namend; namend++) { - if ((*namend == ':' && namend[1] == ':') - || (*namend == '\'' && namend[1])) + for (name_cursor = name; name_cursor < name_end; name_cursor++) { + if ((*name_cursor == ':' && name_cursor < name_em1 + && name_cursor[1] == ':') + || (*name_cursor == '\'' && name_cursor[1])) { if (!stash) stash = PL_defstash; if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ - return Nullgv; + return NULL; - len = namend - name; + len = name_cursor - name; if (len > 0) { char smallbuf[128]; char *tmpbuf; @@ -786,7 +808,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, tmpbuf[len++] = ':'; tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); - gv = gvp ? *gvp : Nullgv; + gv = gvp ? *gvp : NULL; if (gv && gv != (GV*)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); @@ -796,53 +818,63 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!gv || gv == (GV*)&PL_sv_undef) - return Nullgv; + return NULL; if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); if (!HvNAME_get(stash)) - hv_name_set(stash, nambeg, namend - nambeg, 0); + hv_name_set(stash, nambeg, name_cursor - nambeg, 0); } - if (*namend == ':') - namend++; - namend++; - name = namend; - if (!*name) - return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); + if (*name_cursor == ':') + name_cursor++; + name_cursor++; + name = name_cursor; + if (name == name_end) + return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE); } } - len = namend - name; + len = name_cursor - name; /* No stash in name, so see how we can default */ if (!stash) { - if (isIDFIRST_lazy(name)) { + no_stash: + if (len && isIDFIRST_lazy(name)) { bool global = FALSE; - /* 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': + switch (len) { + case 1: if (*name == '_') global = TRUE; break; - case 'N': - if (strEQ(name, "INC") || strEQ(name, "ENV")) + case 3: + if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') + || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') + || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) global = TRUE; break; - case 'I': - if (strEQ(name, "SIG")) + case 4: + if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' + && name[3] == 'V') global = TRUE; break; - case 'T': - if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") || - strEQ(name, "STDERR")) + case 5: + if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' + && name[3] == 'I' && name[4] == 'N') global = TRUE; break; - case 'R': - if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT")) + case 6: + if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') + &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') + ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) + global = TRUE; + break; + case 7: + if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' + && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' + && name[6] == 'T') global = TRUE; break; } @@ -903,15 +935,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, stash = GvHV(gv_fetchpvn_flags("::", 8, GV_ADDMULTI, SVt_PVHV)); } else - return Nullgv; + return NULL; } if (!SvREFCNT(stash)) /* symbol table under destruction */ - return Nullgv; + return NULL; gvp = (GV**)hv_fetch(stash,name,len,add); if (!gvp || *gvp == (GV*)&PL_sv_undef) - return Nullgv; + return NULL; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { if (add) { @@ -942,6 +974,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (len > 1) { #ifndef EBCDIC if (*name > 'V' ) { + /*EMPTY*/; /* 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 @@ -964,7 +997,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "SA")) { AV* const av = GvAVn(gv); GvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0); + sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0); /* NOTE: No support for tied ISA */ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) @@ -987,7 +1020,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "VERLOAD")) { HV* const hv = GvHVn(gv); GvMULTI_on(gv); - hv_magic(hv, Nullgv, PERL_MAGIC_overload); + hv_magic(hv, NULL, PERL_MAGIC_overload); } break; case 'S': @@ -1001,7 +1034,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } GvMULTI_on(gv); hv = GvHVn(gv); - hv_magic(hv, Nullgv, PERL_MAGIC_sig); + hv_magic(hv, NULL, PERL_MAGIC_sig); for (i = 1; i < SIG_SIZE; i++) { SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); if (init) @@ -1107,7 +1140,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '-': { AV* const av = GvAVn(gv); - sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0); + sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0); SvREADONLY_on(av); goto magicalize; } @@ -1124,7 +1157,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '+': { AV* const av = GvAVn(gv); - sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0); + sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0); SvREADONLY_on(av); /* FALL THROUGH */ } @@ -1222,7 +1255,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) if (keepmain || strNE(name, "main")) { sv_catpvn(sv,name,namelen); - sv_catpvn(sv,"::", 2); + sv_catpvs(sv,"::"); } sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } @@ -1237,8 +1270,9 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain IO * Perl_newIO(pTHX) { + dVAR; GV *iogv; - IO * const io = (IO*)NEWSV(0,0); + IO * const io = (IO*)newSV(0); sv_upgrade((SV *)io,SVt_PVIO); /* This used to read SvREFCNT(io) = 1; @@ -1248,10 +1282,10 @@ Perl_newIO(pTHX) SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package name */ hv_clear(PL_stashcache); - iogv = gv_fetchpvn_flags("FileHandle::", 12, 0, SVt_PVHV); + iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpvn_flags("IO::Handle::", 12, TRUE, SVt_PVHV); + iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); return io; } @@ -1259,6 +1293,7 @@ Perl_newIO(pTHX) void Perl_gv_check(pTHX_ HV *stash) { + dVAR; register I32 i; if (!HvARRAY(stash)) @@ -1310,6 +1345,7 @@ Perl_gv_check(pTHX_ HV *stash) GV * Perl_newGVgen(pTHX_ const char *pack) { + dVAR; return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), TRUE, SVt_PVGV); } @@ -1319,6 +1355,7 @@ Perl_newGVgen(pTHX_ const char *pack) GP* Perl_gp_ref(pTHX_ GP *gp) { + dVAR; if (!gp) return (GP*)NULL; gp->gp_refcnt++; @@ -1326,7 +1363,7 @@ Perl_gp_ref(pTHX_ GP *gp) if (gp->gp_cvgen) { /* multi-named GPs cannot be used for method cache */ SvREFCNT_dec(gp->gp_cv); - gp->gp_cv = Nullcv; + gp->gp_cv = NULL; gp->gp_cvgen = 0; } else { @@ -1340,9 +1377,10 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { + dVAR; GP* gp; - if (!gv || !(gp = GvGP(gv))) + if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { if (ckWARN_d(WARN_INTERNAL)) @@ -1358,6 +1396,7 @@ Perl_gp_free(pTHX_ GV *gv) if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; + GvGP(gv) = 0; return; } @@ -1390,9 +1429,9 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) int i; for (i = 1; i < NofAMmeth; i++) { CV * const cv = amtp->table[i]; - if (cv != Nullcv) { + if (cv) { SvREFCNT_dec((SV *) cv); - amtp->table[i] = Nullcv; + amtp->table[i] = NULL; } } } @@ -1404,6 +1443,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) bool Perl_Gv_AMupdate(pTHX_ HV *stash) { + dVAR; MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; @@ -1436,7 +1476,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) lim = DESTROY_amg; /* Skip overloading entries. */ #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { - /* Equivalent to !SvTRUE and !SvOK */ + /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */ } #endif else if (SvTRUE(sv)) @@ -1445,11 +1485,11 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) amt.fallback=AMGfallNEVER; for (i = 1; i < lim; i++) - amt.table[i] = Nullcv; + amt.table[i] = NULL; for (; i < NofAMmeth; i++) { - const char *cooky = PL_AMG_names[i]; + const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ - const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); + const char * const 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", @@ -1473,7 +1513,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ - GV *ngv = Nullgv; + GV *ngv = NULL; SV *gvsv = GvSV(gv); DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ @@ -1503,7 +1543,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cv = (CV*)gv; filled = 1; } - amt.table[i]=(CV*)SvREFCNT_inc(cv); + amt.table[i]=(CV*)SvREFCNT_inc_simple(cv); } if (filled) { AMT_AMAGIC_on(&amt); @@ -1526,11 +1566,12 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { + dVAR; MAGIC *mg; AMT *amtp; if (!stash || !HvNAME_get(stash)) - return Nullcv; + return NULL; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: @@ -1556,7 +1597,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) return ret; } - return Nullcv; + return NULL; } @@ -1834,7 +1875,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; - myop.op_next = Nullop; + myop.op_next = NULL; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; PUSHSTACKi(PERLSI_OVERLOAD); @@ -1943,6 +1984,7 @@ pointers returned by SvPV. bool Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) { + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(flags); if (len > 1) { @@ -2061,6 +2103,25 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) return FALSE; } +void +Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) +{ + dVAR; + U32 hash; + + PERL_UNUSED_ARG(flags); + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); + + if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { + unshare_hek(GvNAME_HEK(gv)); + } + + PERL_HASH(hash, name, len); + GvNAME_HEK(gv) = name ? share_hek(name, len, hash) : 0; +} + /* * Local variables: * c-indentation-style: bsd