/* gv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 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. * */ /* * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure * of your inquisitiveness, I shall spend all the rest of my days answering * you. What more do you want to know?' * 'The names of all the stars, and of all living things, and the whole * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. */ /* =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" #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(72,0); return gv; } #endif GV * Perl_gv_AVadd(pTHX_ register GV *gv) 100746 { 100746 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) ###### Perl_croak(aTHX_ "Bad symbol for array"); 100746 if (!GvAV(gv)) 91455 GvAV(gv) = newAV(); 100746 return gv; } GV * Perl_gv_HVadd(pTHX_ register GV *gv) 41379 { 41379 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) ###### Perl_croak(aTHX_ "Bad symbol for hash"); 41379 if (!GvHV(gv)) 41037 GvHV(gv) = newHV(); 41379 return gv; } GV * Perl_gv_IOadd(pTHX_ register GV *gv) 37173 { 37173 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) ###### Perl_croak(aTHX_ "Bad symbol for filehandle"); 37173 if (!GvIOp(gv)) { #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); } #endif 37173 GvIOp(gv) = newIO(); } 37173 return gv; } GV * Perl_gv_fetchfile(pTHX_ const char *name) 360943 { 360943 char smallbuf[256]; 360943 char *tmpbuf; 360943 STRLEN tmplen; 360943 GV *gv; 360943 if (!PL_defstash) ###### return Nullgv; 360943 tmplen = strlen(name) + 2; 360943 if (tmplen < sizeof smallbuf) 360943 tmpbuf = smallbuf; else ###### New(603, tmpbuf, tmplen + 1, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ 360943 tmpbuf[0] = '_'; 360943 tmpbuf[1] = '<'; 360943 memcpy(tmpbuf + 2, name, tmplen - 1); 360943 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 360943 if (!isGV(gv)) { 123384 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); #ifdef PERL_DONT_CREATE_GVSV GvSV(gv) = newSVpvn(name, tmplen - 2); #else 123384 sv_setpvn(GvSV(gv), name, tmplen - 2); #endif 123384 if (PERLDB_LINE) 87 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile); } 360943 if (tmpbuf != smallbuf) ###### Safefree(tmpbuf); 360943 return gv; } void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 1325649 { dVAR; 1325649 register GP *gp; 1325649 const bool doproto = SvTYPE(gv) > SVt_NULL; 1325649 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; 1325649 sv_upgrade((SV*)gv, SVt_PVGV); 1325649 if (SvLEN(gv)) { 1887 if (proto) { 1887 SvPV_set(gv, NULL); 1887 SvLEN_set(gv, 0); 1887 SvPOK_off(gv); } else ###### Safefree(SvPVX_mutable(gv)); } 1325649 Newz(602, gp, 1, GP); 1325649 GvGP(gv) = gp_ref(gp); #ifdef PERL_DONT_CREATE_GVSV GvSV(gv) = 0; #else 1325649 GvSV(gv) = NEWSV(72,0); #endif 1325649 GvLINE(gv) = CopLINE(PL_curcop); /* XXX Ideally this cast would be replaced with a change to const char* in the struct. */ 1325649 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) ""; 1325649 GvCVGEN(gv) = 0; 1325649 GvEGV(gv) = gv; 1325649 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0); 1325649 GvSTASH(gv) = stash; 1325649 if (stash) 1295260 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); 1325649 GvNAME(gv) = savepvn(name, len); 1325649 GvNAMELEN(gv) = len; 1325649 if (multi || doproto) /* doproto means it _was_ mentioned */ 873503 GvMULTI_on(gv); 1325649 if (doproto) { /* Replicate part of newSUB here. */ 7099 SvIOK_off(gv); 7099 ENTER; /* XXX unsafe for threads if eval_owner isn't held */ 7099 start_subparse(0,0); /* Create CV in compcv. */ 7099 GvCV(gv) = PL_compcv; 7099 LEAVE; 7099 PL_sub_generation++; 7099 CvGV(GvCV(gv)) = gv; 7099 CvFILE_set_from_cop(GvCV(gv), PL_curcop); 7099 CvSTASH(GvCV(gv)) = PL_curstash; 7099 if (proto) { 1887 sv_setpv((SV*)GvCV(gv), proto); 1887 Safefree(proto); } } } STATIC void S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) 3027545 { 3027545 switch (sv_type) { case SVt_PVIO: 48570 (void)GvIOn(gv); 21844 break; case SVt_PVAV: 527550 (void)GvAVn(gv); 86889 break; case SVt_PVHV: 189985 (void)GvHVn(gv); break; #ifdef PERL_DONT_CREATE_GVSV case SVt_NULL: case SVt_PVCV: case SVt_PVFM: break; default: (void)GvSVn(gv); #endif } } /* =for apidoc gv_fetchmeth Returns the glob with the given C and a defined subroutine or C. The glob lives in the given C, or in the stashes accessible via @ISA and UNIVERSAL::. The argument C should be either 0 or -1. If C, as a side-effect creates a glob with the given C in the given C which in the case of success contains an alias for the subroutine, and sets up caching info for this glob. Similarly for all the searched stashes. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C may be a method cache entry, which is not visible to Perl code. So when calling C, you should not use the GV directly; instead, you should use the method's CV, which can be obtained from the GV with the C macro. =cut */ GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 3296226 { 3296226 AV* av; 3296226 GV* topgv; 3296226 GV* gv; 3296226 GV** gvp; 3296226 CV* cv; 3296226 const char *hvname; /* UNIVERSAL methods should be callable without a stash */ 3296226 if (!stash) { 33 level = -1; /* probably appropriate */ 33 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE))) ###### return 0; } 3296226 hvname = HvNAME_get(stash); 3296226 if (!hvname) 1 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); 3296225 if ((level > 100) || (level < -100)) ###### Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, hvname); 3296225 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); 3296225 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 3296225 if (!gvp) 2187504 topgv = Nullgv; else { 1108721 topgv = *gvp; 1108721 if (SvTYPE(topgv) != SVt_PVGV) 89645 gv_init(topgv, stash, name, len, TRUE); 1108721 if ((cv = GvCV(topgv))) { /* If genuine method or valid cache entry, use it */ 811573 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) 760999 return topgv; /* Stale cached entry: junk it */ 50574 SvREFCNT_dec(cv); 50574 GvCV(topgv) = cv = Nullcv; 50574 GvCVGEN(topgv) = 0; } 297148 else if (GvCVGEN(topgv) == PL_sub_generation) 53290 return 0; /* cache indicates sub doesn't exist */ } 2481936 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); 2481936 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; /* create and re-create @.*::SUPER::ISA on demand */ 2481936 if (!av || !SvMAGIC(av)) { 2277443 STRLEN packlen = HvNAMELEN_get(stash); 2277443 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { 423 HV* basestash; 423 packlen -= 7; 423 basestash = gv_stashpvn(hvname, packlen, TRUE); 423 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); 423 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { 419 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); 419 if (!gvp || !(gv = *gvp)) ###### Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); 419 if (SvTYPE(gv) != SVt_PVGV) 419 gv_init(gv, stash, "ISA", 3, TRUE); 419 SvREFCNT_dec(GvAV(gv)); 419 GvAV(gv) = (AV*)SvREFCNT_inc(av); } } } 2481936 if (av) { 204912 SV** svp = AvARRAY(av); /* NOTE: No support for tied ISA */ 204912 I32 items = AvFILLp(av) + 1; 323718 while (items--) { 224895 SV* sv = *svp++; 224895 HV* basestash = gv_stashsv(sv, FALSE); 224895 if (!basestash) { 2 if (ckWARN(WARN_MISC)) 1 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", sv, hvname); 1 continue; } 224893 gv = gv_fetchmeth(basestash, name, len, (level >= 0) ? level + 1 : level - 1); 224893 if (gv) 106089 goto gotcha; } } /* if at top level, try UNIVERSAL */ 2375847 if (level == 0 || level == -1) { 1131659 HV* lastchance; 1131659 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { 1131647 if ((gv = gv_fetchmeth(lastchance, name, len, (level >= 0) ? level + 1 : level - 1))) { gotcha: /* * Cache method in topgv if: * 1. topgv has no synonyms (else inheritance crosses wires) * 2. method isn't a stub (else AUTOLOAD fails spectacularly) */ 109975 if (topgv && GvREFCNT(topgv) == 1 && (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { 102197 if ((cv = GvCV(topgv))) ###### SvREFCNT_dec(cv); 102197 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); 102197 GvCVGEN(topgv) = PL_sub_generation; } 109975 return gv; } 1127761 else if (topgv && GvREFCNT(topgv) == 1) { /* cache the fact that the method is not defined */ 62900 GvCVGEN(topgv) = PL_sub_generation; } } } 2371961 return 0; } /* =for apidoc gv_fetchmeth_autoload Same as gv_fetchmeth(), but looks for autoloaded subroutines too. Returns a glob for the subroutine. For an autoloaded subroutine without a GV, will create a GV even if C. For an autoloaded subroutine without a stub, GvCV() of the result may be zero. =cut */ GV * Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 42809 { 42809 GV *gv = gv_fetchmeth(stash, name, len, level); 42809 if (!gv) { 28493 CV *cv; 28493 GV **gvp; 28493 if (!stash) ###### return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ 28493 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) ###### return Nullgv; 28493 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 28464 return Nullgv; 29 cv = GvCV(gv); 29 if (!(CvROOT(cv) || CvXSUB(cv))) ###### return Nullgv; /* Have an autoload */ 29 if (level < 0) /* Cannot do without a stub */ ###### gv_fetchmeth(stash, name, len, 0); 29 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); 29 if (!gvp) ###### return Nullgv; 29 return *gvp; } 14316 return gv; } /* =for apidoc gv_fetchmethod See L. =cut */ GV * Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) 560410 { 560410 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 on the C. In fact in the presence of autoloading this may be the glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is already setup. The third parameter of C determines whether AUTOLOAD lookup is performed if the given method is not present: non-zero means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling C is equivalent to calling C with a non-zero C parameter. These functions grant C<"SUPER"> token as a prefix of the method name. Note that if you want to keep the returned glob for a long time, you need to check for it being "AUTOLOAD", since at the later time the call may load a different subroutine due to $AUTOLOAD changing its value. Use the glob created via a side effect to do this. These functions have the same side-effects and as C with C. C should be writable if contains C<':'> or C<' ''>. The warning against passing the GV returned by C to C apply equally to these functions. =cut */ GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 652587 { 652587 register const char *nend; 652587 const char *nsplit = 0; 652587 GV* gv; 652587 HV* ostash = stash; 652587 if (stash && SvTYPE(stash) < SVt_PVHV) 24 stash = Nullhv; 4712285 for (nend = name; *nend; nend++) { 4059698 if (*nend == '\'') ###### nsplit = nend; 4059698 else if (*nend == ':' && *(nend + 1) == ':') 5105 nsplit = ++nend; } 652587 if (nsplit) { 4575 const char * const origname = name; 4575 name = nsplit + 1; 4575 if (*nsplit == ':') 4575 --nsplit; 4575 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ 3781 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", 3781 CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ 3781 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", 3781 origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ 794 stash = gv_stashpvn(origname, nsplit - origname, FALSE); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ 794 if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, FALSE)) 2 stash = gv_stashpvn(origname, nsplit - origname, TRUE); } 4575 ostash = stash; } 652587 gv = gv_fetchmeth(stash, name, nend - name, 0); 652586 if (!gv) { 56783 if (strEQ(name,"import") || strEQ(name,"unimport")) 2692 gv = (GV*)&PL_sv_yes; 54091 else if (autoload) 1727 gv = gv_autoload4(ostash, name, nend - name, TRUE); } 595803 else if (autoload) { 556002 CV* const cv = GvCV(gv); 556002 if (!CvROOT(cv) && !CvXSUB(cv)) { 143 GV* stubgv; 143 GV* autogv; 143 if (CvANON(cv)) ###### stubgv = gv; else { 143 stubgv = CvGV(cv); 143 if (GvCV(stubgv) != cv) /* orphaned import */ ###### stubgv = gv; } 143 autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); 143 if (autogv) 143 gv = autogv; } } 652586 return gv; } GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) 4957 { dVAR; 4957 GV* gv; 4957 CV* cv; 4957 HV* varstash; 4957 GV* vargv; 4957 SV* varsv; 4957 const char *packname = ""; 4957 STRLEN packname_len; 4957 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) ###### return Nullgv; 4957 if (stash) { 4955 if (SvTYPE(stash) < SVt_PVHV) { 6 packname = SvPV_const((SV*)stash, packname_len); 6 stash = Nullhv; } else { 4949 packname = HvNAME_get(stash); 4949 packname_len = HvNAMELEN_get(stash); } } 4957 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) 53 return Nullgv; 4904 cv = GvCV(gv); 4904 if (!(CvROOT(cv) || CvXSUB(cv))) 1 return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ 4903 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) 1 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); 4903 if (CvXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', * pass along the same data via some unused fields in the CV */ ###### CvSTASH(cv) = stash; ###### SvPV_set(cv, (char *)name); /* cast to lose constness warning */ ###### SvCUR_set(cv, len); ###### return gv; } /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ 4903 varstash = GvSTASH(CvGV(cv)); 4903 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); 4903 ENTER; 4903 if (!isGV(vargv)) { ###### gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); #ifdef PERL_DONT_CREATE_GVSV GvSV(vargv) = NEWSV(72,0); #endif } 4903 LEAVE; 4903 varsv = GvSVn(vargv); 4903 sv_setpvn(varsv, packname, packname_len); 4903 sv_catpvn(varsv, "::", 2); 4903 sv_catpvn(varsv, name, len); 4903 SvTAINTED_off(varsv); 4903 return gv; } /* The "gv" parameter should be the glob known to Perl code as *! * The scalar must already have been magicalized. */ STATIC void S_require_errno(pTHX_ GV *gv) 82 { dVAR; 82 HV* stash = gv_stashpvn("Errno",5,FALSE); 82 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 3 dSP; 3 PUTBACK; 3 ENTER; 3 save_scalar(gv); /* keep the value of $! */ 3 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Errno",5), Nullsv); 3 LEAVE; 3 SPAGAIN; 3 stash = gv_stashpvn("Errno",5,FALSE); 3 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) ###### Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); } } /* =for apidoc gv_stashpv Returns a pointer to the stash for a specified package. C should 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 */ HV* Perl_gv_stashpv(pTHX_ const char *name, I32 create) 1072718 { 1072718 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) 2898796 { 2898796 char smallbuf[256]; 2898796 char *tmpbuf; 2898796 HV *stash; 2898796 GV *tmpgv; 2898796 if (namelen + 3 < sizeof smallbuf) 2898796 tmpbuf = smallbuf; else ###### New(606, tmpbuf, namelen + 3, char); 2898796 Copy(name,tmpbuf,namelen,char); 2898796 tmpbuf[namelen++] = ':'; 2898796 tmpbuf[namelen++] = ':'; 2898796 tmpbuf[namelen] = '\0'; 2898796 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); 2898796 if (tmpbuf != smallbuf) ###### Safefree(tmpbuf); 2898796 if (!tmpgv) 41770 return 0; 2857026 if (!GvHV(tmpgv)) ###### GvHV(tmpgv) = newHV(); 2857026 stash = GvHV(tmpgv); 2857026 if (!HvNAME_get(stash)) ###### Perl_hv_name_set(aTHX_ stash, name, namelen, 0); 2857026 return stash; } /* =for apidoc gv_stashsv Returns a pointer to the stash for a specified package, which must be a valid UTF-8 string. See C. =cut */ HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 create) 275798 { 275798 STRLEN len; 275798 const char * const ptr = SvPV_const(sv,len); 275798 return gv_stashpvn(ptr, len, create); } GV * 10333304 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { 10333304 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); } GV * 2898895 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { 2898895 STRLEN len; 2898895 const char * const nambeg = SvPV_const(name, len); 2898895 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) 13232199 { 13232199 register const char *name = nambeg; 13232199 register GV *gv = 0; 13232199 GV**gvp; 13232199 I32 len; 13232199 register const char *namend; 13232199 HV *stash = 0; 13232199 const I32 add = flags & ~SVf_UTF8; 13232199 (void)full_len; 13232199 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ 997 name++; 142300523 for (namend = name; *namend; namend++) { 132072066 if ((*namend == ':' && namend[1] == ':') || (*namend == '\'' && namend[1])) { 7115704 if (!stash) 4752169 stash = PL_defstash; 7115704 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ ###### return Nullgv; 7115704 len = namend - name; 7115704 if (len > 0) { 7113985 char smallbuf[256]; 7113985 char *tmpbuf; 7113985 if (len + 3 < sizeof (smallbuf)) 7113981 tmpbuf = smallbuf; else 4 New(601, tmpbuf, len+3, char); 7113985 Copy(name, tmpbuf, len, char); 7113985 tmpbuf[len++] = ':'; 7113985 tmpbuf[len++] = ':'; 7113985 tmpbuf[len] = '\0'; 7113985 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); 7113985 gv = gvp ? *gvp : Nullgv; 7113985 if (gv && gv != (GV*)&PL_sv_undef) { 7021129 if (SvTYPE(gv) != SVt_PVGV) 136681 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); else 6884448 GvMULTI_on(gv); } 7113985 if (tmpbuf != smallbuf) 4 Safefree(tmpbuf); 7113985 if (!gv || gv == (GV*)&PL_sv_undef) 92856 return Nullgv; 7021129 if (!(stash = GvHV(gv))) 136681 stash = GvHV(gv) = newHV(); 7021129 if (!HvNAME_get(stash)) 136682 Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0); } 7022848 if (*namend == ':') 7021257 namend++; 7022848 namend++; 7022848 name = namend; 7022848 if (!*name) 2910886 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); } } 10228457 len = namend - name; /* No stash in name, so see how we can default */ 10228457 if (!stash) { 8480030 if (isIDFIRST_lazy(name)) { 3744977 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 */ 3744977 switch (name[1]) { case '\0': 993103 if (*name == '_') 839792 global = TRUE; 839792 break; case 'N': 93866 if (strEQ(name, "INC") || strEQ(name, "ENV")) 87044 global = TRUE; 87044 break; case 'I': 29953 if (strEQ(name, "SIG")) 13833 global = TRUE; 13833 break; case 'T': 63627 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") || strEQ(name, "STDERR")) 51698 global = TRUE; 51698 break; case 'R': 51314 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT")) 35577 global = TRUE; break; } 3744977 if (global) 1027944 stash = PL_defstash; 2717033 else if (IN_PERL_COMPILETIME) { 2615581 stash = PL_curstash; 2615581 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 && (*name == 'a' || *name == 'b')) ) { 138530 gvp = (GV**)hv_fetch(stash,name,len,0); 138530 if (!gvp || *gvp == (GV*)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { 35 stash = 0; } 138495 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) { 10 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); 10 if (GvCVu(*gvp)) ###### Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); 10 stash = 0; } } } else 101452 stash = CopSTASH(PL_curcop); } else 4735053 stash = PL_defstash; } /* By this point we should have a stash and a name */ 10228457 if (!stash) { 203418 if (add) { 45 SV * const err = Perl_mess(aTHX_ "Global symbol \"%s%s\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" 45 : ""), name); 45 if (USE_UTF8_IN_NAMES) 1 SvUTF8_on(err); 45 qerror(err); 45 stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); } else 203373 return Nullgv; } 10025084 if (!SvREFCNT(stash)) /* symbol table under destruction */ ###### return Nullgv; 10025084 gvp = (GV**)hv_fetch(stash,name,len,add); 10025084 if (!gvp || *gvp == (GV*)&PL_sv_undef) 4786894 return Nullgv; 5238190 gv = *gvp; 5238190 if (SvTYPE(gv) == SVt_PVGV) { 4267696 if (add) { 2087659 GvMULTI_on(gv); 2087659 gv_init_sv(gv, sv_type); 2087659 if (*name=='!' && sv_type == SVt_PVHV && len==1) 82 require_errno(gv); } 4267696 return gv; 970494 } else if (add & GV_NOINIT) { 30608 return gv; } /* Adding a new symbol */ 939886 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); 939886 gv_init(gv, stash, name, len, add & GV_ADDMULTI); 939886 gv_init_sv(gv, sv_type); 939886 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) 593585 GvMULTI_on(gv) ; /* set up magic where warranted */ 939886 if (len > 1) { #ifndef EBCDIC 863861 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 { 360411 const char * const name2 = name + 1; 360411 switch (*name) { case 'A': 14430 if (strEQ(name2, "RGV")) { 4500 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } 4500 break; case 'E': 40148 if (strnEQ(name2, "XPORT", 5)) 27079 GvMULTI_on(gv); 27079 break; case 'I': 33167 if (strEQ(name2, "SA")) { 24556 AV* const av = GvAVn(gv); 24556 GvMULTI_on(gv); 24556 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0); /* NOTE: No support for tied ISA */ 24556 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) { 2 const char *pname; 2 av_push(av, newSVpvn(pname = "NDBM_File",9)); 2 gv_stashpvn(pname, 9, TRUE); 2 av_push(av, newSVpvn(pname = "DB_File",7)); 2 gv_stashpvn(pname, 7, TRUE); 2 av_push(av, newSVpvn(pname = "GDBM_File",9)); 2 gv_stashpvn(pname, 9, TRUE); 2 av_push(av, newSVpvn(pname = "SDBM_File",9)); 2 gv_stashpvn(pname, 9, TRUE); 2 av_push(av, newSVpvn(pname = "ODBM_File",9)); 2 gv_stashpvn(pname, 9, TRUE); } } 2 break; case 'O': 21421 if (strEQ(name2, "VERLOAD")) { 608 HV* const hv = GvHVn(gv); 608 GvMULTI_on(gv); 608 hv_magic(hv, Nullgv, PERL_MAGIC_overload); } 608 break; case 'S': 39368 if (strEQ(name2, "IG")) { 1978 HV *hv; 1978 I32 i; 1978 if (!PL_psig_ptr) { 1978 Newz(73, PL_psig_ptr, SIG_SIZE, SV*); 1978 Newz(73, PL_psig_name, SIG_SIZE, SV*); 1978 Newz(73, PL_psig_pend, SIG_SIZE, int); } 1978 GvMULTI_on(gv); 1978 hv = GvHVn(gv); 1978 hv_magic(hv, Nullgv, PERL_MAGIC_sig); 136482 for (i = 1; i < SIG_SIZE; i++) { 134504 SV ** const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); 134504 if (init) 134504 sv_setsv(*init, &PL_sv_undef); 134504 PL_psig_ptr[i] = 0; 134504 PL_psig_name[i] = 0; 134504 PL_psig_pend[i] = 0; } } 36783 break; case 'V': 36783 if (strEQ(name2, "ERSION")) 32137 GvMULTI_on(gv); 32137 break; case '\003': /* $^CHILD_ERROR_NATIVE */ 1 if (strEQ(name2, "HILD_ERROR_NATIVE")) 1 goto magicalize; 20 break; case '\005': /* $^ENCODING */ 20 if (strEQ(name2, "NCODING")) 20 goto magicalize; 8 break; case '\017': /* $^OPEN */ 8 if (strEQ(name2, "PEN")) 8 goto magicalize; 42 break; case '\024': /* ${^TAINT} */ 42 if (strEQ(name2, "AINT")) 42 goto ro_magicalize; 13 break; case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ 13 if (strEQ(name2, "NICODE")) 12 goto ro_magicalize; 1 if (strEQ(name2, "TF8LOCALE")) 1 goto ro_magicalize; 2270 break; case '\027': /* $^WARNING_BITS */ 2270 if (strEQ(name2, "ARNING_BITS")) 2270 goto magicalize; 31 break; 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 */ 31 const char *end = name + len; 107 while (--end > name) { 94 if (!isDIGIT(*end)) return gv; } 76025 goto ro_magicalize; } } } } 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) */ 76025 switch (*name) { case '&': case '`': case '\'': 63 if ( sv_type == SVt_PVAV || sv_type == SVt_PVHV || sv_type == SVt_PVCV || sv_type == SVt_PVFM || sv_type == SVt_PVIO 63 ) { break; } 63 PL_sawampersand = TRUE; 63 goto ro_magicalize; case ':': 121 sv_setpv(GvSVn(gv),PL_chopset); 121 goto magicalize; case '?': #ifdef COMPLEX_STATUS SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif 2522 goto magicalize; 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) */ 2522 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); 2522 if (sv_type == SVt_PVHV) ###### require_errno(gv); ###### break; case '-': { 4500 AV* const av = GvAVn(gv); 4500 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0); 4500 SvREADONLY_on(av); 4500 goto magicalize; } case '*': case '#': 3 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 2 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "$%c is no longer supported", *name); 2 break; case '|': 780 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); 780 goto magicalize; case '+': { 4500 AV* const av = GvAVn(gv); 4500 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0); 4500 SvREADONLY_on(av); /* 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: 9655 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: 34327 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); 34327 break; case '\014': /* $^L */ 143 sv_setpvn(GvSVn(gv),"\f",1); 143 PL_formfeed = GvSVn(gv); 143 break; case ';': 198 sv_setpvn(GvSVn(gv),"\034",1); 198 break; case ']': { 1727 SV * const sv = GvSVn(gv); 1727 if (!sv_derived_from(PL_patchlevel, "version")) 599 (void *)upg_version(PL_patchlevel); 1727 GvSV(gv) = vnumify(PL_patchlevel); 1727 SvREADONLY_on(GvSV(gv)); 1727 SvREFCNT_dec(sv); } ###### break; case '\026': /* $^V */ { 1514 SV * const sv = GvSVn(gv); 1514 GvSV(gv) = new_version(PL_patchlevel); 1514 SvREADONLY_on(GvSV(gv)); 1514 SvREFCNT_dec(sv); } break; } } 939868 return gv; } void Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 100510 { 100510 const char *name; 100510 STRLEN namelen; 100510 const HV * const hv = GvSTASH(gv); 100510 if (!hv) { ###### SvOK_off(sv); ###### return; } 100510 sv_setpv(sv, prefix ? prefix : ""); 100510 name = HvNAME_get(hv); 100510 if (name) { 100510 namelen = HvNAMELEN_get(hv); } else { ###### name = "__ANON__"; ###### namelen = 8; } 100510 if (keepmain || strNE(name, "main")) { 100509 sv_catpvn(sv,name,namelen); 100509 sv_catpvn(sv,"::", 2); } 100510 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void 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, const GV *gv, const char *prefix, bool keepmain) 100505 { 100505 const GV *egv = GvEGV(gv); 100505 if (!egv) 10 egv = gv; 100505 gv_fullname4(sv, egv, prefix, keepmain); } void Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) ###### { ###### gv_efullname4(sv, gv, prefix, TRUE); } /* compatibility with versions <= 5.003. */ void Perl_gv_fullname(pTHX_ SV *sv, const GV *gv) ###### { ###### gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); } /* compatibility with versions <= 5.003. */ void Perl_gv_efullname(pTHX_ SV *sv, const GV *gv) ###### { ###### gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); } IO * Perl_newIO(pTHX) 37298 { 37298 GV *iogv; 37298 IO * const io = (IO*)NEWSV(0,0); 37298 sv_upgrade((SV *)io,SVt_PVIO); 37298 SvREFCNT(io) = 1; 37298 SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package name */ 37298 hv_clear(PL_stashcache); 37298 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ 37298 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) 37027 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); 37298 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); 37298 return io; } void Perl_gv_check(pTHX_ HV *stash) 61572 { 61572 register I32 i; 61572 if (!HvARRAY(stash)) ###### return; 1225716 for (i = 0; i <= (I32) HvMAX(stash); i++) { 1164144 const HE *entry; 1807005 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 642861 register GV *gv; 642861 HV *hv; 642861 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) { 61572 if (hv != PL_defstash && hv != stash) 60125 gv_check(hv); /* nested package */ } 581289 else if (isALPHA(*HeKEY(entry))) { 474106 const char *file; 474106 gv = (GV*)HeVAL(entry); 474106 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) 28 continue; 28 file = GvFILE(gv); /* performance hack: if filename is absolute and it's a standard * module, don't bother warning */ 28 if (file && PERL_FILE_IS_ABSOLUTE(file) #ifdef MACOS_TRADITIONAL && (instr(file, ":lib:") #else && (instr(file, "/lib/") #endif || instr(file, ".pm"))) { 28 continue; } 28 CopLINE_set(PL_curcop, GvLINE(gv)); #ifdef USE_ITHREADS CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else 28 CopFILEGV(PL_curcop) = gv_fetchfile(file); #endif 28 Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", HvNAME_get(stash), GvNAME(gv)); } } } } GV * Perl_newGVgen(pTHX_ const char *pack) 308 { 308 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), TRUE, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ GP* Perl_gp_ref(pTHX_ GP *gp) 1367278 { 1367278 if (!gp) ###### return (GP*)NULL; 1367278 gp->gp_refcnt++; 1367278 if (gp->gp_cv) { 10719 if (gp->gp_cvgen) { /* multi-named GPs cannot be used for method cache */ 4 SvREFCNT_dec(gp->gp_cv); 4 gp->gp_cv = Nullcv; 4 gp->gp_cvgen = 0; } else { /* Adding a new name to a subroutine invalidates method cache */ 10715 PL_sub_generation++; } } 1367278 return gp; } void Perl_gp_free(pTHX_ GV *gv) 1519911 { 1519911 GP* gp; 1519911 if (!gv || !(gp = GvGP(gv))) 137931 return; 1381980 if (gp->gp_refcnt == 0) { ###### if (ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced glob pointers" pTHX__FORMAT pTHX__VALUE); ###### return; } 1381980 if (gp->gp_cv) { /* Deleting the name of a subroutine invalidates method cache */ 654941 PL_sub_generation++; } 1381980 if (--gp->gp_refcnt > 0) { 27825 if (gp->gp_egv == gv) 17262 gp->gp_egv = 0; 17262 return; } 1354155 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv); 1354155 if (gp->gp_av) SvREFCNT_dec(gp->gp_av); /* FIXME - another reference loop GV -> symtab -> GV ? Somehow gp->gp_hv can end up pointing at freed garbage. */ 1354155 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { 155784 const char *hvname = HvNAME_get(gp->gp_hv); 155784 if (PL_stashcache && hvname) 337 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), G_DISCARD); 155784 SvREFCNT_dec(gp->gp_hv); } 1354155 if (gp->gp_io) SvREFCNT_dec(gp->gp_io); 1354155 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv); 1354155 if (gp->gp_form) SvREFCNT_dec(gp->gp_form); 1354155 Safefree(gp); 1354155 GvGP(gv) = 0; } int Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) 42881 { 42881 AMT * const amtp = (AMT*)mg->mg_ptr; 42881 PERL_UNUSED_ARG(sv); 42881 if (amtp && AMT_AMAGIC(amtp)) { 32342 int i; 2134572 for (i = 1; i < NofAMmeth; i++) { 2102230 CV * const cv = amtp->table[i]; 2102230 if (cv != Nullcv) { 133998 SvREFCNT_dec((SV *) cv); 133998 amtp->table[i] = Nullcv; } } } 42881 return 0; } /* Updates and caches the CV's */ bool Perl_Gv_AMupdate(pTHX_ HV *stash) 1459819 { 1459819 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); 1459819 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; 1459819 AMT amt; 1459819 if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) 1417010 return (bool)AMT_OVERLOADED(amtp); 42809 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); 42809 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); 42809 Zero(&amt,1,AMT); 42809 amt.was_ok_am = PL_amagic_generation; 42809 amt.was_ok_sub = PL_sub_generation; 42809 amt.fallback = AMGfallNO; 42809 amt.flags = 0; { 42809 int filled = 0, have_ovl = 0; 42809 int i, lim = 1; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ /* Try to find via inheritance. */ 42809 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); 42809 SV * const sv = gv ? GvSV(gv) : NULL; 42809 CV* cv; 42809 if (!gv) 24690 lim = DESTROY_amg; /* Skip overloading entries. */ #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { /* Equivalent to !SvTRUE and !SvOK */ } #endif 18119 else if (SvTRUE(sv)) 27 amt.fallback=AMGfallYES; 18092 else if (SvOK(sv)) ###### amt.fallback=AMGfallNEVER; 1622969 for (i = 1; i < lim; i++) 1580160 amt.table[i] = Nullcv; 2447659 for (; i < NofAMmeth; i++) { 1202425 const char *cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ 1202425 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); 1202425 const STRLEN l = strlen(cooky); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", 1202425 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. Indeed, for inheritance A -> B -> C, if C overloads "+0", then we could have created stubs for "(+0" in A and C too. But if B overloads "bool", we may want to use it for numifying instead of C's "+0". */ 1202425 if (i >= DESTROY_amg) 42809 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); else /* Autoload taken care of below */ 1159616 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); 1202425 cv = 0; 1202425 if (gv && (cv = GvCV(gv))) { 133823 const char *hvname; 133823 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && 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. */ 86 GV *ngv = Nullgv; 86 SV *gvsv = GvSV(gv); DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ "\" for overloaded \"%s\" in package \"%.256s\"\n", 86 GvSV(gv), cp, hvname) ); 86 if (!gvsv || !SvPOK(gvsv) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), FALSE))) { /* 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); } 86 cv = GvCV(gv = ngv); } DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), 133823 GvNAME(CvGV(cv))) ); 133823 filled = 1; 133823 if (i < DESTROY_amg) 119507 have_ovl = 1; 1068602 } else if (gv) { /* Autoloaded... */ 29 cv = (CV*)gv; 29 filled = 1; } 1202425 amt.table[i]=(CV*)SvREFCNT_inc(cv); } 42809 if (filled) { 32286 AMT_AMAGIC_on(&amt); 32286 if (have_ovl) 18117 AMT_OVERLOADED_on(&amt); 32286 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMT)); 32286 return have_ovl; } } /* Here we have no table: */ /* no_table: */ 10523 AMT_AMAGIC_off(&amt); 10523 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); 10523 return FALSE; } CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) 1456874 { 1456874 MAGIC *mg; 1456874 AMT *amtp; 1456874 if (!stash || !HvNAME_get(stash)) 1 return Nullcv; 1456873 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); 1456873 if (!mg) { do_update: 14038 Gv_AMupdate(stash); 14038 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); } 1468707 amtp = (AMT*)mg->mg_ptr; 1468707 if ( amtp->was_ok_am != PL_amagic_generation || amtp->was_ok_sub != PL_sub_generation ) 1456873 goto do_update; 1456873 if (AMT_AMAGIC(amtp)) { 157203 CV * const ret = amtp->table[id]; 157203 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. */ 24 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]); 24 if (gv && GvCV(gv)) 24 return GvCV(gv); } 157179 return ret; } 1299670 return Nullcv; } SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 1228344 { dVAR; 1228344 MAGIC *mg; 1228344 CV *cv=NULL; 1228344 CV **cvp=NULL, **ocvp=NULL; 1228344 AMT *amtp=NULL, *oamtp=NULL; 1228344 int off = 0, off1, lr = 0, notfound = 0; 1228344 int postpr = 0, force_cpy = 0; 1228344 int assign = AMGf_assign & flags; 1228344 const int assignshift = assign ? 1 : 0; #ifdef DEBUGGING 1228344 int fl=0; #endif 1228344 HV* stash=NULL; 1228344 if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (stash = SvSTASH(SvRV(left))) && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ ( #ifdef DEBUGGING fl = 1, #endif cv = cvp[off=method])))) { 30850 lr = -1; /* Call method for left argument */ } else { 1197494 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { 1179733 int logic; /* look for substituted methods */ /* In all the covered cases we should be called with assign==0. */ 1179733 switch (method) { case inc_amg: 7 force_cpy = 1; 7 if ((cv = cvp[off=add_ass_amg]) || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { 2 right = &PL_sv_yes; lr = -1; assign = 1; } 2 break; case dec_amg: 7 force_cpy = 1; 7 if ((cv = cvp[off = subtr_ass_amg]) || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { 2 right = &PL_sv_yes; lr = -1; assign = 1; } 2 break; case bool__amg: 583 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 3 break; case numer_amg: 3 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); ###### break; case string_amg: ###### (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); 5 break; case not_amg: 5 (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); 5 postpr = 1; 5 break; case copy_amg: { /* * SV* ref causes confusion with the interpreter variable of * the same name */ 4 SV* tmpRef=SvRV(left); 4 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { /* * Just to be extra cautious. Maybe in some * additional cases sv_setsv is safe, too. */ 4 SV* newref = newSVsv(tmpRef); 4 SvOBJECT_on(newref); 4 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); 4 return newref; } } 4 break; case abs_amg: 4 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { 2 SV* nullsv=sv_2mortal(newSViv(0)); 2 if (off1==lt_amg) { ###### SV* lessp = amagic_call(left,nullsv, ###### lt_amg,AMGf_noright); ###### logic = SvTRUE(lessp); } else { 2 SV* lessp = amagic_call(left,nullsv, 2 ncmp_amg,AMGf_noright); 2 logic = (SvNV(lessp) < 0); } 2 if (logic) { 1 if (off==subtr_amg) { 1 right = left; 1 left = nullsv; 1 lr = 1; } } else { 1 return left; } } 1 break; case neg_amg: 1 if ((cv = cvp[off=subtr_amg])) { 1 right = left; 1 left = sv_2mortal(newSViv(0)); 1 lr = 1; } 1 break; case int_amg: case iter_amg: /* XXXX Eventually should do to_gv. */ /* FAIL safe */ 1 return NULL; /* Delegate operation to standard mechanisms. */ 1179105 break; case to_sv_amg: case to_av_amg: case to_hv_amg: case to_gv_amg: case to_cv_amg: /* FAIL safe */ 1179105 return left; /* Delegate operation to standard mechanisms. */ 609 break; default: 609 goto not_found; } 609 if (!cv) goto not_found; 17761 } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (stash = SvSTASH(SvRV(right))) && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ 1085 lr=1; 16676 } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp) && (lr = -1)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(flags & AMGf_unary)) { /* We look for substitution for * comparison operations and * concatenation */ 16676 if (method==concat_amg || method==concat_ass_amg || method==repeat_amg || method==repeat_ass_amg) { 1850 return NULL; /* Delegate operation to string conversion */ } 14826 off = -1; 14826 switch (method) { case lt_amg: case le_amg: case gt_amg: case ge_amg: case eq_amg: case ne_amg: 657 postpr = 1; off=ncmp_amg; break; case slt_amg: case sle_amg: case sgt_amg: case sge_amg: case seq_amg: case sne_amg: 13054 postpr = 1; off=scmp_amg; break; } 14826 if (off != -1) cv = cvp[off]; 14826 if (!cv) { 1867 goto not_found; } } else { not_found: /* No method found, either report or croak */ 1867 switch (method) { case to_sv_amg: case to_av_amg: case to_hv_amg: case to_gv_amg: case to_cv_amg: /* FAIL safe */ ###### return left; /* Delegate operation to standard mechanisms. */ 1867 break; } 1867 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ 70 notfound = 1; lr = -1; 1797 } else if (cvp && (cv=cvp[nomethod_amg])) { 12 notfound = 1; lr = 1; } else { 1785 SV *msg; 1785 if (off==-1) off=method; 1785 msg = sv_2mortal(Perl_newSVpvf(aTHX_ "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_get(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? ",\n\tright argument in overloaded package ": (flags & AMGf_unary ? "" : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? HvNAME_get(SvSTASH(SvRV(right))): "")); 1785 if (amtp && amtp->fallback >= AMGfallYES) { 1781 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { 4 Perl_croak(aTHX_ "%"SVf, msg); } 1781 return NULL; } 82 force_cpy = force_cpy || assign; } } #ifdef DEBUGGING 45598 if (!notfound) { DEBUG_o(Perl_deb(aTHX_ "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", AMG_id2name(off), method+assignshift==off? "" : " (initially \"", method+assignshift==off? "" : AMG_id2name(method+assignshift), method+assignshift==off? "" : "\")", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", stash ? HvNAME_get(stash) : "null", 45516 fl? ",\n\tassignment variant used": "") ); } #endif /* Since we use shallow copy during assignment, we need * to dublicate the contents, probably calling user-supplied * version of copy operator */ /* We need to copy in following cases: * a) Assignment form was called. * assignshift==1, assign==T, method + 1 == off * b) Increment or decrement, called directly. * assignshift==0, assign==0, method + 0 == off * c) Increment or decrement, translated to assignment add/subtr. * assignshift==0, assign==T, * force_cpy == T * d) Increment or decrement, translated to nomethod. * assignshift==0, assign==0, * force_cpy == T * e) Assignment form translated to nomethod. * assignshift==1, assign==T, method + 1 != off * force_cpy == T */ /* off is method, method+assignshift, or a result of opcode substitution. * In the latter case assignshift==0, so only notfound case is important. */ 45598 if (( (method + assignshift == off) && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) 3560 RvDEEPCP(left); { 45597 dSP; 45597 BINOP myop; 45597 SV* res; 45597 const bool oldcatch = CATCH_GET; 45597 CATCH_SET(TRUE); 45597 Zero(&myop, 1, BINOP); 45597 myop.op_last = (OP *) &myop; 45597 myop.op_next = Nullop; 45597 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; 45597 PUSHSTACKi(PERLSI_OVERLOAD); 45597 ENTER; 45597 SAVEOP(); 45597 PL_op = (OP *) &myop; 45597 if (PERLDB_SUB && PL_curstash != PL_debstash) ###### PL_op->op_private |= OPpENTERSUB_DB; 45597 PUTBACK; 45597 pp_pushmark(); 45597 EXTEND(SP, notfound + 5); 45597 PUSHs(lr>0? right: left); 45597 PUSHs(lr>0? left: right); 45597 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); 45597 if (notfound) { 82 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); } 45597 PUSHs((SV*)cv); 45597 PUTBACK; 45597 if ((PL_op = Perl_pp_entersub(aTHX))) 42485 CALLRUNOPS(aTHX); 45583 LEAVE; 45583 SPAGAIN; 45583 res=POPs; 45583 PUTBACK; 45583 POPSTACK; 45583 CATCH_SET(oldcatch); 45583 if (postpr) { 12993 int ans; 12993 switch (method) { case le_amg: case sle_amg: 19 ans=SvIV(res)<=0; break; case lt_amg: case slt_amg: 45 ans=SvIV(res)<0; break; case ge_amg: case sge_amg: 34 ans=SvIV(res)>=0; break; case gt_amg: case sgt_amg: 51 ans=SvIV(res)>0; break; case eq_amg: case seq_amg: 12810 ans=SvIV(res)==0; break; case ne_amg: case sne_amg: 25 ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: 4 SvSetSV(left,res); return left; case not_amg: 5 ans=!SvTRUE(res); break; default: ###### ans=0; break; } 12989 return boolSV(ans); 32590 } else if (method==copy_amg) { 17 if (!SvROK(res)) { 1 Perl_croak(aTHX_ "Copy method did not return a reference"); } 16 return SvREFCNT_inc(SvRV(res)); } else { 32573 return res; } } } /* =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) 870 { 870 STRLEN len; 870 const char *temp = SvPV_const(name, len); 870 return is_gv_magical(temp, len, flags); } /* =for apidoc is_gv_magical Returns C if given the name of a magical GV. Currently only useful internally when determining if a GV should be 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_ const char *name, STRLEN len, U32 flags) 870 { 870 PERL_UNUSED_ARG(flags); 870 if (len > 1) { 828 const char * const name1 = name + 1; 828 switch (*name) { case 'I': 36 if (len == 3 && name1[1] == 'S' && name[2] == 'A') ###### goto yes; 4 break; case 'O': 4 if (len == 8 && strEQ(name1, "VERLOAD")) ###### goto yes; 19 break; case 'S': 19 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; 27 break; case '\024': /* ${^TAINT} */ 27 if (strEQ(name1, "AINT")) 27 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; 62 break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { 62 const char *end = name + len; 257 while (--end > name) { 251 if (!isDIGIT(*end)) 56 return FALSE; } 42 goto yes; } } } else { /* Because we're already assuming that name is NUL terminated below, we can treat an empty name as "\0" */ 42 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: 35 return TRUE; default: 779 break; } } 779 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: */