X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/70ec62655df91a127fc208eb77497a9be5917f1b..1a5b3db469280dd5cf664d996d7209b0219449ef:/gv.c diff --git a/gv.c b/gv.c index 5ea5141..555260f 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, 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. @@ -34,6 +34,22 @@ Perl stores its global variables. #define PERL_IN_GV_C #include "perl.h" +static const char S_autoload[] = "AUTOLOAD"; +static const STRLEN S_autolen = sizeof(S_autoload)-1; + + +#ifdef PERL_DONT_CREATE_GVSV +GV * +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(0); + return gv; +} +#endif + GV * Perl_gv_AVadd(pTHX_ register GV *gv) { @@ -57,8 +73,22 @@ Perl_gv_HVadd(pTHX_ register GV *gv) GV * Perl_gv_IOadd(pTHX_ register GV *gv) { - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for filehandle"); + 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 || + PL_op->op_type == OP_TELLDIR || + PL_op->op_type == OP_SEEKDIR || + PL_op->op_type == OP_REWINDDIR || + PL_op->op_type == OP_CLOSEDIR ? + "dirhandle" : "filehandle"; + Perl_croak(aTHX_ "Bad symbol for %s", fh); + } + if (!GvIOp(gv)) { #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { @@ -73,60 +103,111 @@ 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) tmpbuf = smallbuf; else - New(603, tmpbuf, tmplen + 1, char); + Newx(tmpbuf, tmplen + 1, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; - strcpy(tmpbuf + 2, name); + memcpy(tmpbuf + 2, name, tmplen - 1); gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); if (!isGV(gv)) { gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); - sv_setpv(GvSV(gv), name); +#ifdef PERL_DONT_CREATE_GVSV + GvSV(gv) = newSVpvn(name, tmplen - 2); +#else + 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); return gv; } +/* +=for apidoc gv_const_sv + +If C is a typeglob whose subroutine entry is a constant sub eligible for +inlining, or C is a placeholder reference that would be promoted to such +a typeglob, then returns the value returned by the sub. Otherwise, returns +NULL. + +=cut +*/ + +SV * +Perl_gv_const_sv(pTHX_ GV *gv) +{ + if (SvTYPE(gv) == SVt_PVGV) + return cv_const_sv(GvCVu(gv)); + return SvROK(gv) ? SvRV(gv) : NULL; +} + void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { + dVAR; register GP *gp; - bool doproto = SvTYPE(gv) > SVt_NULL; - char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + const bool doproto = SvTYPE(gv) > SVt_NULL; + const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; + SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; + + assert (!(proto && has_constant)); + + if (has_constant) { + /* The constant has to be a simple scalar type. */ + switch (SvTYPE(has_constant)) { + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", + sv_reftype(has_constant, 0)); + } + SvRV_set(gv, NULL); + SvROK_off(gv); + } 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)); + Safefree(SvPVX_mutable(gv)); } - Newz(602, gp, 1, GP); + Newxz(gp, 1, GP); GvGP(gv) = gp_ref(gp); - GvSV(gv) = NEWSV(72,0); +#ifdef PERL_DONT_CREATE_GVSV + GvSV(gv) = NULL; +#else + GvSV(gv) = newSV(0); +#endif 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); - GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); + sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, NULL, 0); + GvSTASH(gv) = stash; + if (stash) + Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi || doproto) /* doproto means it _was_ mentioned */ @@ -134,9 +215,14 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) if (doproto) { /* Replicate part of newSUB here. */ SvIOK_off(gv); ENTER; - /* XXX unsafe for threads if eval_owner isn't held */ - start_subparse(0,0); /* Create CV in compcv. */ - GvCV(gv) = PL_compcv; + if (has_constant) { + /* newCONSTSUB takes ownership of the reference from us. */ + GvCV(gv) = newCONSTSUB(stash, name, has_constant); + } else { + /* XXX unsafe for threads if eval_owner isn't held */ + (void) start_subparse(0,0); /* Create empty CV in compcv. */ + GvCV(gv) = PL_compcv; + } LEAVE; PL_sub_generation++; @@ -163,6 +249,15 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) case SVt_PVHV: (void)GvHVn(gv); break; +#ifdef PERL_DONT_CREATE_GVSV + case SVt_NULL: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVGV: + break; + default: + (void)GvSVn(gv); +#endif } } @@ -190,32 +285,35 @@ 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; GV** gvp; CV* cv; + const char *hvname; /* 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; } - if (!HvNAME(stash)) + hvname = HvNAME_get(stash); + if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", - name, HvNAME(stash)); + name, hvname); - DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) - topgv = Nullgv; + topgv = NULL; else { topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) @@ -226,31 +324,30 @@ 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); - av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; + 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 */ if (!av || !SvMAGIC(av)) { - char* packname = HvNAME(stash); - STRLEN packlen = strlen(packname); + STRLEN packlen = HvNAMELEN_get(stash); - if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; - basestash = gv_stashpvn(packname, packlen, TRUE); - gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); + basestash = gv_stashpvn(hvname, packlen, TRUE); + 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(stash)); + Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); @@ -264,12 +361,12 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* NOTE: No support for tied ISA */ I32 items = AvFILLp(av) + 1; while (items--) { - SV* sv = *svp++; - HV* basestash = gv_stashsv(sv, FALSE); + SV* const sv = *svp++; + HV* const basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", - sv, HvNAME(stash)); + sv, hvname); continue; } gv = gv_fetchmeth(basestash, name, len, @@ -282,9 +379,9 @@ 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* lastchance; + HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE); - if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { + if (lastchance) { if ((gv = gv_fetchmeth(lastchance, name, len, (level >= 0) ? level + 1 : level - 1))) { @@ -335,46 +432,30 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le GV *gv = gv_fetchmeth(stash, name, len, level); if (!gv) { - char autoload[] = "AUTOLOAD"; - STRLEN autolen = sizeof(autoload)-1; CV *cv; GV **gvp; if (!stash) - return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ - if (len == autolen && strnEQ(name, autoload, autolen)) - return Nullgv; - if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) - return Nullgv; + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ + if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) + return NULL; + if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + 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; } /* -=for apidoc gv_fetchmethod - -See L. - -=cut -*/ - -GV * -Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) -{ - return gv_fetchmethod_autoload(stash, name, TRUE); -} - -/* =for apidoc gv_fetchmethod_autoload Returns the glob which contains the subroutine to call to invoke the method @@ -405,13 +486,14 @@ 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 = 0; + const char *nsplit = NULL; GV* gv; HV* ostash = stash; if (stash && SvTYPE(stash) < SVt_PVHV) - stash = Nullhv; + stash = NULL; for (nend = name; *nend; nend++) { if (*nend == '\'') @@ -420,7 +502,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) nsplit = ++nend; } if (nsplit) { - const char *origname = name; + const char * const origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; @@ -429,9 +511,9 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ - stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); + stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvNAME(stash), name) ); + origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ @@ -455,7 +537,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); } else if (autoload) { - CV* cv = GvCV(gv); + CV* const cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; @@ -480,38 +562,40 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { - char autoload[] = "AUTOLOAD"; - STRLEN autolen = sizeof(autoload)-1; + dVAR; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; - char *packname = ""; + const char *packname = ""; + STRLEN packname_len; - if (len == autolen && strnEQ(name, autoload, autolen)) - return Nullgv; + if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) + return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { - packname = SvPV_nolen((SV*)stash); - stash = Nullhv; + packname = SvPV_const((SV*)stash, packname_len); + stash = NULL; } else { - packname = HvNAME(stash); + packname = HvNAME_get(stash); + packname_len = HvNAMELEN_get(stash); } } - if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) - return Nullgv; + if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return Nullgv; + return NULL; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && - (GvCVGEN(gv) || GvSTASH(gv) != stash)) + if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) + && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) + ) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); @@ -523,8 +607,8 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * 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; } @@ -535,15 +619,19 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); - vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); ENTER; - if (!isGV(vargv)) - gv_init(vargv, varstash, autoload, autolen, FALSE); + if (!isGV(vargv)) { + gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); +#ifdef PERL_DONT_CREATE_GVSV + GvSV(vargv) = newSV(0); +#endif + } LEAVE; - varsv = GvSV(vargv); - sv_setpv(varsv, packname); - sv_catpvn(varsv, "::", 2); + varsv = GvSVn(vargv); + sv_setpvn(varsv, packname, packname_len); + sv_catpvs(varsv, "::"); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; @@ -555,18 +643,19 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) STATIC void S_require_errno(pTHX_ GV *gv) { - HV* stash = gv_stashpvn("Errno",5,FALSE); + dVAR; + HV* stash = gv_stashpvs("Errno", FALSE); - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { dSP; PUTBACK; 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"); } @@ -576,9 +665,9 @@ S_require_errno(pTHX_ GV *gv) =for apidoc gv_stashpv Returns a pointer to the stash for a specified package. C should -be a valid UTF-8 string. If C is set then the package will be -created if it does not already exist. If C 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 is set +then the package will be created if it does not already exist. If C +is not set and the package does not exist then NULL is returned. =cut */ @@ -589,10 +678,22 @@ Perl_gv_stashpv(pTHX_ const char *name, I32 create) return gv_stashpvn(name, strlen(name), create); } +/* +=for apidoc gv_stashpvn + +Returns a pointer to the stash for a specified package. C should +be a valid UTF-8 string. The C parameter indicates the length of +the C, in bytes. If C is set then the package will be +created if it does not already exist. If C 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) { - char smallbuf[256]; + char smallbuf[128]; char *tmpbuf; HV *stash; GV *tmpgv; @@ -600,12 +701,12 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) if (namelen + 3 < sizeof smallbuf) tmpbuf = smallbuf; else - New(606, tmpbuf, namelen + 3, char); + Newx(tmpbuf, namelen + 3, char); Copy(name,tmpbuf,namelen,char); tmpbuf[namelen++] = ':'; tmpbuf[namelen++] = ':'; tmpbuf[namelen] = '\0'; - tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); + tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV); if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!tmpgv) @@ -613,8 +714,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); - if (!HvNAME(stash)) - HvNAME(stash) = savepv(name); + if (!HvNAME_get(stash)) + hv_name_set(stash, name, namelen, 0); return stash; } @@ -630,50 +731,78 @@ valid UTF-8 string. See C. HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 create) { - register char *ptr; STRLEN len; - ptr = SvPV(sv,len); + const char * const ptr = SvPV_const(sv,len); return gv_stashpvn(ptr, len, 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) { + return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); +} + +GV * +Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { + STRLEN len; + const char * const nambeg = SvPV_const(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) { + dVAR; register const char *name = nambeg; - register GV *gv = 0; + register GV *gv = NULL; GV**gvp; I32 len; - register const char *namend; - HV *stash = 0; + 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 & ~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[256]; + char smallbuf[128]; char *tmpbuf; if (len + 3 < sizeof (smallbuf)) tmpbuf = smallbuf; else - New(601, tmpbuf, len+3, char); + Newx(tmpbuf, len+3, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; 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)); @@ -683,53 +812,66 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) 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(stash)) - HvNAME(stash) = savepvn(nambeg, namend - nambeg); + if (!HvNAME_get(stash)) + 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; - - /* $_ should always be in main:: even when our'ed */ - if (*name == '_' && !name[1]) - stash = PL_defstash; + 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; - if (isUPPER(*name)) { - if (*name == 'S' && ( - strEQ(name, "SIG") || - strEQ(name, "STDIN") || - strEQ(name, "STDOUT") || - strEQ(name, "STDERR"))) + switch (len) { + case 1: + if (*name == '_') global = TRUE; - else if (*name == 'I' && strEQ(name, "INC")) + break; + 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; - else if (*name == 'E' && strEQ(name, "ENV")) + break; + case 4: + if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' + && name[3] == 'V') global = TRUE; - else if (*name == 'A' && ( - strEQ(name, "ARGV") || - strEQ(name, "ARGVOUT"))) + break; + case 5: + if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' + && name[3] == 'I' && name[4] == 'N') global = TRUE; + break; + 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; } - else if (*name == '_' && !name[1]) - global = TRUE; if (global) stash = PL_defstash; @@ -775,7 +917,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (!stash) { if (add) { - register SV *err = Perl_mess(aTHX_ + SV * const err = Perl_mess(aTHX_ "Global symbol \"%s%s\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" @@ -784,18 +926,18 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); - stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); + 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) { @@ -805,7 +947,9 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) require_errno(gv); } return gv; - } else if (add & GV_NOINIT) { + } else if (no_init) { + return gv; + } else if (no_expand && SvROK(gv)) { return gv; } @@ -816,361 +960,343 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) + if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) 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' ) { + /*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 + the common case of lower case variable names. */ + } else +#endif + { + const char * const 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* const av = GvAVn(gv); + GvMULTI_on(gv); + 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) + { + 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* const hv = GvHVn(gv); + GvMULTI_on(gv); + hv_magic(hv, NULL, PERL_MAGIC_overload); + } + break; + case 'S': + if (strEQ(name2, "IG")) { + HV *hv; + I32 i; + if (!PL_psig_ptr) { + Newxz(PL_psig_ptr, SIG_SIZE, SV*); + Newxz(PL_psig_name, SIG_SIZE, SV*); + Newxz(PL_psig_pend, SIG_SIZE, int); + } + GvMULTI_on(gv); + hv = GvHVn(gv); + 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) + 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 '\003': /* $^CHILD_ERROR_NATIVE */ + if (strEQ(name2, "HILD_ERROR_NATIVE")) + goto magicalize; + 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); - } - } - 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); + /* 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; } - 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(GvSVn(gv),PL_chopset); + goto magicalize; + + case '?': #ifdef COMPLEX_STATUS - (void)SvUPGRADE(GvSV(gv), SVt_PVLV); + SvUPGRADE(GvSVn(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(GvSVn(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 { - AV* av = GvAVn(gv); - sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0); + case '-': + { + AV* const av = GvAVn(gv); + sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 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") - ) + goto magicalize; + } + case '*': + case '#': + if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "$%c is no longer supported", *name); break; - goto magicalize; + case '|': + sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); + goto magicalize; - case '+': - if (len > 1) - break; - else { - AV* av = GvAVn(gv); - sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0); + case '+': + { + AV* const av = GvAVn(gv); + sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 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(GvSVn(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(GvSVn(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_setpvn(GvSVn(gv),"\f",1); + PL_formfeed = GvSVn(gv); break; - sv_setpv(GvSV(gv),"\f"); - PL_formfeed = GvSV(gv); - break; - case ';': - if (len > 1) + case ';': + sv_setpvn(GvSVn(gv),"\034",1); break; - sv_setpv(GvSV(gv),"\034"); - break; - case ']': - if (len == 1) { - SV *sv = GvSV(gv); + case ']': + { + SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) - (void *)upg_version(PL_patchlevel); + 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); + case '\026': /* $^V */ + { + SV * const sv = GvSVn(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; + STRLEN namelen; + const HV * const hv = GvSTASH(gv); if (!hv) { SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); - - if (!HvNAME(hv)) + + name = HvNAME_get(hv); + if (name) { + namelen = HvNAMELEN_get(hv); + } else { name = "__ANON__"; - else - name = HvNAME(hv); + namelen = 8; + } + if (keepmain || strNE(name, "main")) { - sv_catpv(sv,name); - sv_catpvn(sv,"::", 2); + sv_catpvn(sv,name,namelen); + sv_catpvs(sv,"::"); } sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void -Perl_gv_fullname3(pTHX_ SV *sv, 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); - if (!egv) - egv = gv; - gv_fullname4(sv, egv, prefix, keepmain); -} - -void -Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) -{ - gv_efullname4(sv, gv, prefix, TRUE); -} - -/* XXX compatibility with versions <= 5.003. */ -void -Perl_gv_fullname(pTHX_ SV *sv, GV *gv) -{ - gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : ""); -} - -/* XXX compatibility with versions <= 5.003. */ -void -Perl_gv_efullname(pTHX_ SV *sv, GV *gv) -{ - gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); + const GV * const egv = GvEGV(gv); + gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } IO * Perl_newIO(pTHX) { - IO *io; + dVAR; GV *iogv; + IO * const io = (IO*)newSV(0); - io = (IO*)NEWSV(0,0); sv_upgrade((SV *)io,SVt_PVIO); - SvREFCNT(io) = 1; + /* This used to read SvREFCNT(io) = 1; + It's not clear why the reference count needed an explicit reset. NWC + */ + assert (SvREFCNT(io) == 1); SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a - package name */ + /* Clear the stashcache because a new IO could overrule a package name */ hv_clear(PL_stashcache); - iogv = gv_fetchpv("FileHandle::", FALSE, 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_fetchpv("IO::Handle::", TRUE, SVt_PVHV); - SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); + iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); + SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); return io; } void Perl_gv_check(pTHX_ HV *stash) { - register HE *entry; + dVAR; 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)) { + register GV *gv; + HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) { @@ -1178,41 +1304,42 @@ Perl_gv_check(pTHX_ HV *stash) 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; file = GvFILE(gv); /* performance hack: if filename is absolute and it's a standard * module, don't bother warning */ - if (file - && PERL_FILE_IS_ABSOLUTE(file) #ifdef MACOS_TRADITIONAL - && (instr(file, ":lib:") +# define LIB_COMPONENT ":lib:" #else - && (instr(file, "/lib/") +# define LIB_COMPONENT "/lib/" #endif - || instr(file, ".pm"))) + if (file + && PERL_FILE_IS_ABSOLUTE(file) + && (instr(file, LIB_COMPONENT) || instr(file, ".pm"))) { 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 Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", - HvNAME(stash), GvNAME(gv)); + HvNAME_get(stash), GvNAME(gv)); } } } } GV * -Perl_newGVgen(pTHX_ char *pack) +Perl_newGVgen(pTHX_ const char *pack) { + dVAR; return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), TRUE, SVt_PVGV); } @@ -1222,6 +1349,7 @@ Perl_newGVgen(pTHX_ char *pack) GP* Perl_gp_ref(pTHX_ GP *gp) { + dVAR; if (!gp) return (GP*)NULL; gp->gp_refcnt++; @@ -1229,7 +1357,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 { @@ -1243,6 +1371,7 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { + dVAR; GP* gp; if (!gv || !(gp = GvGP(gv))) @@ -1266,12 +1395,14 @@ Perl_gp_free(pTHX_ GV *gv) 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); + /* FIXME - another reference loop GV -> symtab -> GV ? + Somehow gp->gp_hv can end up pointing at freed garbage. */ + if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { + const char *hvname = HvNAME_get(gp->gp_hv); + if (PL_stashcache && hvname) + hv_delete(PL_stashcache, hvname, HvNAMELEN_get(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); @@ -1284,14 +1415,16 @@ Perl_gp_free(pTHX_ GV *gv) int Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) { - AMT *amtp = (AMT*)mg->mg_ptr; + AMT * const amtp = (AMT*)mg->mg_ptr; + PERL_UNUSED_ARG(sv); + if (amtp && AMT_AMAGIC(amtp)) { int i; for (i = 1; i < NofAMmeth; i++) { - CV *cv = amtp->table[i]; - if (cv != Nullcv) { + CV * const cv = amtp->table[i]; + if (cv != NULL) { SvREFCNT_dec((SV *) cv); - amtp->table[i] = Nullcv; + amtp->table[i] = NULL; } } } @@ -1303,10 +1436,9 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - GV* gv; - CV* cv; - MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table); - AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; + dVAR; + MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; if (mg && amtp->was_ok_am == PL_amagic_generation @@ -1314,7 +1446,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return (bool)AMT_OVERLOADED(amtp); sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); - DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; @@ -1325,32 +1457,36 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) { int filled = 0, have_ovl = 0; int i, lim = 1; - SV* sv = NULL; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); - if (gv) - sv = GvSV(gv); + GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + SV * const sv = gv ? GvSV(gv) : NULL; + CV* cv; if (!gv) lim = DESTROY_amg; /* Skip overloading entries. */ +#ifdef PERL_DONT_CREATE_GVSV + else if (!sv) { + /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */ + } +#endif else if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; for (i = 1; i < lim; i++) - amt.table[i] = Nullcv; + amt.table[i] = NULL; for (; i < NofAMmeth; i++) { - char *cooky = (char*)PL_AMG_names[i]; + const char * const 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 * 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", - cp, HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", + cp, HvNAME_get(stash)) ); /* don't fill the cache while looking up! Creation of inheritance stubs in intermediate packages may conflict with the logic of runtime method substitution. @@ -1364,33 +1500,34 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); cv = 0; if (gv && (cv = GvCV(gv))) { + const char *hvname; if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { /* 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; - - DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\ - "' for overloaded `%s' in package `%.256s'\n", - GvSV(gv), cp, HvNAME(stash)) ); - if (!SvPOK(GvSV(gv)) - || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), + GV *ngv = NULL; + SV *gvsv = GvSV(gv); + + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ + "\" for overloaded \"%s\" in package \"%.256s\"\n", + GvSV(gv), cp, hvname) ); + if (!gvsv || !SvPOK(gvsv) + || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), FALSE))) { - /* Can be an import stub (created by `can'). */ - SV *gvsv = GvSV(gv); - const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???"; - Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\ - "in package `%.256s'", + /* Can be an import stub (created by "can"). */ + const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; + Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ + "in package \"%.256s\"", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), - name, cp, HvNAME(stash)); + name, cp, hvname); } cv = GvCV(gv = ngv); } - DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", - cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; if (i < DESTROY_amg) @@ -1422,12 +1559,12 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { + dVAR; MAGIC *mg; AMT *amtp; - CV *ret; - if (!stash || !HvNAME(stash)) - return Nullcv; + if (!stash || !HvNAME_get(stash)) + return NULL; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: @@ -1439,33 +1576,36 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) || amtp->was_ok_sub != PL_sub_generation ) goto do_update; if (AMT_AMAGIC(amtp)) { - ret = amtp->table[id]; + CV * const ret = amtp->table[id]; if (ret && isGV(ret)) { /* Autoloading stab */ /* Passing it through may have resulted in a warning "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 * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); if (gv && GvCV(gv)) return GvCV(gv); } return ret; } - - return Nullcv; + + return NULL; } SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { + dVAR; MAGIC *mg; CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; AMT *amtp=NULL, *oamtp=NULL; - int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0; - int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; + int off = 0, off1, lr = 0, notfound = 0; + int postpr = 0, force_cpy = 0; + int assign = AMGf_assign & flags; + const int assignshift = assign ? 1 : 0; #ifdef DEBUGGING int fl=0; #endif @@ -1482,7 +1622,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) ( #ifdef DEBUGGING fl = 1, -#endif +#endif cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { @@ -1515,27 +1655,27 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case string_amg: (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); break; - case not_amg: - (void)((cv = cvp[off=bool__amg]) - || (cv = cvp[off=numer_amg]) - || (cv = cvp[off=string_amg])); - postpr = 1; - break; + case not_amg: + (void)((cv = cvp[off=bool__amg]) + || (cv = cvp[off=numer_amg]) + || (cv = cvp[off=string_amg])); + postpr = 1; + break; case copy_amg: { /* * SV* ref causes confusion with the interpreter variable of * the same name */ - SV* tmpRef=SvRV(left); + SV* const tmpRef=SvRV(left); if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { /* * Just to be extra cautious. Maybe in some * additional cases sv_setsv is safe, too. */ - SV* newref = newSVsv(tmpRef); + SV* const newref = newSVsv(tmpRef); SvOBJECT_on(newref); - SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef)); + SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); return newref; } } @@ -1543,13 +1683,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case abs_amg: if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { - SV* nullsv=sv_2mortal(newSViv(0)); + SV* const nullsv=sv_2mortal(newSViv(0)); if (off1==lt_amg) { - SV* lessp = amagic_call(left,nullsv, + SV* const lessp = amagic_call(left,nullsv, lt_amg,AMGf_noright); logic = SvTRUE(lessp); } else { - SV* lessp = amagic_call(left,nullsv, + SV* const lessp = amagic_call(left,nullsv, ncmp_amg,AMGf_noright); logic = (SvNV(lessp) < 0); } @@ -1649,14 +1789,14 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *msg; if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation `%s': no method found,%sargument %s%s%s%s", + "Operation \"%s\": no method found,%sargument %s%s%s%s", AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", SvAMAGIC(left)? - HvNAME(SvSTASH(SvRV(left))): + HvNAME_get(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? ",\n\tright argument in overloaded package ": @@ -1664,10 +1804,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) ? "" : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? - HvNAME(SvSTASH(SvRV(right))): + HvNAME_get(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { - DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, msg); } @@ -1679,17 +1819,17 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", AMG_id2name(off), method+assignshift==off? "" : - " (initially `", + " (initially \"", method+assignshift==off? "" : AMG_id2name(method+assignshift), - method+assignshift==off? "" : "')", + method+assignshift==off? "" : "\")", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - stash ? HvNAME(stash) : "null", + stash ? HvNAME_get(stash) : "null", fl? ",\n\tassignment variant used": "") ); } #endif @@ -1723,7 +1863,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) dSP; BINOP myop; SV* res; - bool oldcatch = CATCH_GET; + const bool oldcatch = CATCH_GET; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); @@ -1761,7 +1901,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CATCH_SET(oldcatch); if (postpr) { - int ans=0; + int ans; switch (method) { case le_amg: case sle_amg: @@ -1786,6 +1926,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SvSetSV(left,res); return left; case not_amg: ans=!SvTRUE(res); break; + default: + ans=0; break; } return boolSV(ans); } else if (method==copy_amg) { @@ -1800,6 +1942,22 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } /* +=for apidoc is_gv_magical_sv + +Returns C 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 * const temp = SvPV_const(name, len); + return is_gv_magical(temp, len, flags); +} + +/* =for apidoc is_gv_magical Returns C if given the name of a magical GV. @@ -1810,110 +1968,139 @@ created even in rvalue contexts. C is not used at present but available for future extension to allow selecting particular classes of magical variable. +Currently assumes that C 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")) - ) + PERL_UNUSED_ARG(flags); + + if (len > 1) { + const char * const 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; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */