3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
12 * of your inquisitiveness, I shall spend all the rest of my days answering
13 * you. What more do you want to know?'
14 * 'The names of all the stars, and of all living things, and the whole
15 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
24 Perl_gv_AVadd(pTHX_ register GV *gv)
26 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
27 Perl_croak(aTHX_ "Bad symbol for array");
34 Perl_gv_HVadd(pTHX_ register GV *gv)
36 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
37 Perl_croak(aTHX_ "Bad symbol for hash");
44 Perl_gv_IOadd(pTHX_ register GV *gv)
46 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
47 Perl_croak(aTHX_ "Bad symbol for filehandle");
54 Perl_gv_fetchfile(pTHX_ const char *name)
65 tmplen = strlen(name) + 2;
66 if (tmplen < sizeof smallbuf)
69 New(603, tmpbuf, tmplen + 1, char);
72 strcpy(tmpbuf + 2, name);
73 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
75 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
76 sv_setpv(GvSV(gv), name);
78 hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
80 if (tmpbuf != smallbuf)
86 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
90 bool doproto = SvTYPE(gv) > SVt_NULL;
91 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
93 sv_upgrade((SV*)gv, SVt_PVGV);
102 Newz(602, gp, 1, GP);
103 GvGP(gv) = gp_ref(gp);
104 GvSV(gv) = NEWSV(72,0);
105 GvLINE(gv) = CopLINE(PL_curcop);
106 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
109 sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
110 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
111 GvNAME(gv) = savepvn(name, len);
113 if (multi || doproto) /* doproto means it _was_ mentioned */
115 if (doproto) { /* Replicate part of newSUB here. */
118 /* XXX unsafe for threads if eval_owner isn't held */
119 start_subparse(0,0); /* Create CV in compcv. */
120 GvCV(gv) = PL_compcv;
124 CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
125 CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
126 CvSTASH(GvCV(gv)) = PL_curstash;
128 CvOWNER(GvCV(gv)) = 0;
129 if (!CvMUTEXP(GvCV(gv))) {
130 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
131 MUTEX_INIT(CvMUTEXP(GvCV(gv)));
133 #endif /* USE_THREADS */
135 sv_setpv((SV*)GvCV(gv), proto);
142 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
158 =for apidoc gv_fetchmeth
160 Returns the glob with the given C<name> and a defined subroutine or
161 C<NULL>. The glob lives in the given C<stash>, or in the stashes
162 accessible via @ISA and @UNIVERSAL.
164 The argument C<level> should be either 0 or -1. If C<level==0>, as a
165 side-effect creates a glob with the given C<name> in the given C<stash>
166 which in the case of success contains an alias for the subroutine, and sets
167 up caching info for this glob. Similarly for all the searched stashes.
169 This function grants C<"SUPER"> token as a postfix of the stash name. The
170 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
171 visible to Perl code. So when calling C<call_sv>, you should not use
172 the GV directly; instead, you should use the method's CV, which can be
173 obtained from the GV with the C<GvCV> macro.
179 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
189 if ((level > 100) || (level < -100))
190 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
191 name, HvNAME(stash));
193 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
195 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
200 if (SvTYPE(topgv) != SVt_PVGV)
201 gv_init(topgv, stash, name, len, TRUE);
202 if ((cv = GvCV(topgv))) {
203 /* If genuine method or valid cache entry, use it */
204 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
206 /* Stale cached entry: junk it */
208 GvCV(topgv) = cv = Nullcv;
211 else if (GvCVGEN(topgv) == PL_sub_generation)
212 return 0; /* cache indicates sub doesn't exist */
215 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
216 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
218 /* create and re-create @.*::SUPER::ISA on demand */
219 if (!av || !SvMAGIC(av)) {
220 char* packname = HvNAME(stash);
221 STRLEN packlen = strlen(packname);
223 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
227 basestash = gv_stashpvn(packname, packlen, TRUE);
228 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
229 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
230 dTHR; /* just for SvREFCNT_dec */
231 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
232 if (!gvp || !(gv = *gvp))
233 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
234 if (SvTYPE(gv) != SVt_PVGV)
235 gv_init(gv, stash, "ISA", 3, TRUE);
236 SvREFCNT_dec(GvAV(gv));
237 GvAV(gv) = (AV*)SvREFCNT_inc(av);
243 SV** svp = AvARRAY(av);
244 /* NOTE: No support for tied ISA */
245 I32 items = AvFILLp(av) + 1;
248 HV* basestash = gv_stashsv(sv, FALSE);
250 dTHR; /* just for ckWARN */
251 if (ckWARN(WARN_MISC))
252 Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
253 SvPVX(sv), HvNAME(stash));
256 gv = gv_fetchmeth(basestash, name, len,
257 (level >= 0) ? level + 1 : level - 1);
263 /* if at top level, try UNIVERSAL */
265 if (level == 0 || level == -1) {
268 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
269 if ((gv = gv_fetchmeth(lastchance, name, len,
270 (level >= 0) ? level + 1 : level - 1)))
274 * Cache method in topgv if:
275 * 1. topgv has no synonyms (else inheritance crosses wires)
276 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
279 GvREFCNT(topgv) == 1 &&
281 (CvROOT(cv) || CvXSUB(cv)))
283 if ((cv = GvCV(topgv)))
285 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
286 GvCVGEN(topgv) = PL_sub_generation;
290 else if (topgv && GvREFCNT(topgv) == 1) {
291 /* cache the fact that the method is not defined */
292 GvCVGEN(topgv) = PL_sub_generation;
301 =for apidoc gv_fetchmethod
303 See L<gv_fetchmethod_autoload>.
309 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
311 return gv_fetchmethod_autoload(stash, name, TRUE);
315 =for apidoc gv_fetchmethod_autoload
317 Returns the glob which contains the subroutine to call to invoke the method
318 on the C<stash>. In fact in the presence of autoloading this may be the
319 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
322 The third parameter of C<gv_fetchmethod_autoload> determines whether
323 AUTOLOAD lookup is performed if the given method is not present: non-zero
324 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
325 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
326 with a non-zero C<autoload> parameter.
328 These functions grant C<"SUPER"> token as a prefix of the method name. Note
329 that if you want to keep the returned glob for a long time, you need to
330 check for it being "AUTOLOAD", since at the later time the call may load a
331 different subroutine due to $AUTOLOAD changing its value. Use the glob
332 created via a side effect to do this.
334 These functions have the same side-effects and as C<gv_fetchmeth> with
335 C<level==0>. C<name> should be writable if contains C<':'> or C<'
336 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
337 C<call_sv> apply equally to these functions.
343 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
346 register const char *nend;
347 const char *nsplit = 0;
350 for (nend = name; *nend; nend++) {
353 else if (*nend == ':' && *(nend + 1) == ':')
357 const char *origname = name;
361 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
362 /* ->SUPER::method should really be looked up in original stash */
363 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
364 CopSTASHPV(PL_curcop)));
365 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
366 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
367 origname, HvNAME(stash), name) );
370 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
373 gv = gv_fetchmeth(stash, name, nend - name, 0);
375 if (strEQ(name,"import"))
376 gv = (GV*)&PL_sv_yes;
378 gv = gv_autoload4(stash, name, nend - name, TRUE);
382 if (!CvROOT(cv) && !CvXSUB(cv)) {
390 if (GvCV(stubgv) != cv) /* orphaned import */
393 autogv = gv_autoload4(GvSTASH(stubgv),
394 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
404 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
407 static char autoload[] = "AUTOLOAD";
408 static STRLEN autolen = 8;
415 if (len == autolen && strnEQ(name, autoload, autolen))
417 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
422 * Inheriting AUTOLOAD for non-methods works ... for now.
424 if (ckWARN(WARN_DEPRECATED) && !method &&
425 (GvCVGEN(gv) || GvSTASH(gv) != stash))
426 Perl_warner(aTHX_ WARN_DEPRECATED,
427 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
428 HvNAME(stash), (int)len, name);
431 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
432 * The subroutine's original name may not be "AUTOLOAD", so we don't
433 * use that, but for lack of anything better we will use the sub's
434 * original package to look up $AUTOLOAD.
436 varstash = GvSTASH(CvGV(cv));
437 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
441 Perl_lock(aTHX_ (SV *)varstash);
444 gv_init(vargv, varstash, autoload, autolen, FALSE);
448 Perl_lock(aTHX_ varsv);
450 sv_setpv(varsv, HvNAME(stash));
451 sv_catpvn(varsv, "::", 2);
452 sv_catpvn(varsv, name, len);
453 SvTAINTED_off(varsv);
458 =for apidoc gv_stashpv
460 Returns a pointer to the stash for a specified package. C<name> should
461 be a valid UTF-8 string. If C<create> is set then the package will be
462 created if it does not already exist. If C<create> is not set and the
463 package does not exist then NULL is returned.
469 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
471 return gv_stashpvn(name, strlen(name), create);
475 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
482 if (namelen + 3 < sizeof smallbuf)
485 New(606, tmpbuf, namelen + 3, char);
486 Copy(name,tmpbuf,namelen,char);
487 tmpbuf[namelen++] = ':';
488 tmpbuf[namelen++] = ':';
489 tmpbuf[namelen] = '\0';
490 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
491 if (tmpbuf != smallbuf)
496 GvHV(tmpgv) = newHV();
499 HvNAME(stash) = savepv(name);
504 =for apidoc gv_stashsv
506 Returns a pointer to the stash for a specified package, which must be a
507 valid UTF-8 string. See C<gv_stashpv>.
513 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
518 return gv_stashpvn(ptr, len, create);
523 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
526 register const char *name = nambeg;
530 register const char *namend;
533 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
536 for (namend = name; *namend; namend++) {
537 if ((*namend == ':' && namend[1] == ':')
538 || (*namend == '\'' && namend[1]))
542 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
550 if (len + 3 < sizeof smallbuf)
553 New(601, tmpbuf, len+3, char);
554 Copy(name, tmpbuf, len, char);
558 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
559 gv = gvp ? *gvp : Nullgv;
560 if (gv && gv != (GV*)&PL_sv_undef) {
561 if (SvTYPE(gv) != SVt_PVGV)
562 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
566 if (tmpbuf != smallbuf)
568 if (!gv || gv == (GV*)&PL_sv_undef)
571 if (!(stash = GvHV(gv)))
572 stash = GvHV(gv) = newHV();
575 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
583 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
590 /* No stash in name, so see how we can default */
593 if (isIDFIRST_lazy(name)) {
596 if (isUPPER(*name)) {
597 if (*name == 'S' && (
598 strEQ(name, "SIG") ||
599 strEQ(name, "STDIN") ||
600 strEQ(name, "STDOUT") ||
601 strEQ(name, "STDERR")))
603 else if (*name == 'I' && strEQ(name, "INC"))
605 else if (*name == 'E' && strEQ(name, "ENV"))
607 else if (*name == 'A' && (
608 strEQ(name, "ARGV") ||
609 strEQ(name, "ARGVOUT")))
612 else if (*name == '_' && !name[1])
617 else if ((COP*)PL_curcop == &PL_compiling) {
619 if (add && (PL_hints & HINT_STRICT_VARS) &&
620 sv_type != SVt_PVCV &&
621 sv_type != SVt_PVGV &&
622 sv_type != SVt_PVFM &&
623 sv_type != SVt_PVIO &&
624 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
626 gvp = (GV**)hv_fetch(stash,name,len,0);
628 *gvp == (GV*)&PL_sv_undef ||
629 SvTYPE(*gvp) != SVt_PVGV)
633 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
634 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
635 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
637 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
638 sv_type == SVt_PVAV ? '@' :
639 sv_type == SVt_PVHV ? '%' : '$',
642 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
648 stash = CopSTASH(PL_curcop);
654 /* By this point we should have a stash and a name */
658 qerror(Perl_mess(aTHX_
659 "Global symbol \"%s%s\" requires explicit package name",
660 (sv_type == SVt_PV ? "$"
661 : sv_type == SVt_PVAV ? "@"
662 : sv_type == SVt_PVHV ? "%"
664 stash = PL_nullstash;
670 if (!SvREFCNT(stash)) /* symbol table under destruction */
673 gvp = (GV**)hv_fetch(stash,name,len,add);
674 if (!gvp || *gvp == (GV*)&PL_sv_undef)
677 if (SvTYPE(gv) == SVt_PVGV) {
680 gv_init_sv(gv, sv_type);
683 } else if (add & GV_NOINIT) {
687 /* Adding a new symbol */
689 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
690 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
691 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
692 gv_init_sv(gv, sv_type);
694 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
697 /* set up magic where warranted */
700 if (strEQ(name, "ARGV")) {
701 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
705 if (strnEQ(name, "EXPORT", 6))
709 if (strEQ(name, "ISA")) {
712 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
713 /* NOTE: No support for tied ISA */
714 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
715 && AvFILLp(av) == -1)
718 av_push(av, newSVpvn(pname = "NDBM_File",9));
719 gv_stashpvn(pname, 9, TRUE);
720 av_push(av, newSVpvn(pname = "DB_File",7));
721 gv_stashpvn(pname, 7, TRUE);
722 av_push(av, newSVpvn(pname = "GDBM_File",9));
723 gv_stashpvn(pname, 9, TRUE);
724 av_push(av, newSVpvn(pname = "SDBM_File",9));
725 gv_stashpvn(pname, 9, TRUE);
726 av_push(av, newSVpvn(pname = "ODBM_File",9));
727 gv_stashpvn(pname, 9, TRUE);
732 if (strEQ(name, "OVERLOAD")) {
735 hv_magic(hv, gv, 'A');
739 if (strEQ(name, "SIG")) {
743 int sig_num[] = { SIG_NUM };
744 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
745 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
749 hv_magic(hv, gv, 'S');
750 for (i = 1; PL_sig_name[i]; i++) {
752 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
754 sv_setsv(*init, &PL_sv_undef);
761 if (strEQ(name, "VERSION"))
768 PL_sawampersand = TRUE;
774 PL_sawampersand = TRUE;
780 PL_sawampersand = TRUE;
786 sv_setpv(GvSV(gv),PL_chopset);
792 #ifdef COMPLEX_STATUS
793 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
800 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
801 HV* stash = gv_stashpvn("Errno",5,FALSE);
802 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
805 require_pv("Errno.pm");
807 stash = gv_stashpvn("Errno",5,FALSE);
808 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
809 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
818 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
823 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
824 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
840 case '\001': /* $^A */
841 case '\003': /* $^C */
842 case '\004': /* $^D */
843 case '\005': /* $^E */
844 case '\006': /* $^F */
845 case '\010': /* $^H */
846 case '\011': /* $^I, NOT \t in EBCDIC */
847 case '\017': /* $^O */
848 case '\020': /* $^P */
849 case '\024': /* $^T */
853 case '\023': /* $^S */
857 case '\027': /* $^W & $^WARNING_BITS */
858 if (len > 1 && strNE(name, "\027ARNING_BITS")
859 && strNE(name, "\027IDE_SYSTEM_CALLS"))
868 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
881 SvREADONLY_on(GvSV(gv));
883 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
886 case '\014': /* $^L */
889 sv_setpv(GvSV(gv),"\f");
890 PL_formfeed = GvSV(gv);
895 sv_setpv(GvSV(gv),"\034");
900 (void)SvUPGRADE(sv, SVt_PVNV);
901 SvNVX(sv) = SvNVX(PL_patchlevel);
903 (void)SvPV_nolen(sv);
907 case '\026': /* $^V */
910 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
919 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
921 HV *hv = GvSTASH(gv);
926 sv_setpv(sv, prefix ? prefix : "");
927 sv_catpv(sv,HvNAME(hv));
928 sv_catpvn(sv,"::", 2);
929 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
933 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
938 gv_fullname3(sv, egv, prefix);
941 /* XXX compatibility with versions <= 5.003. */
943 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
945 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
948 /* XXX compatibility with versions <= 5.003. */
950 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
952 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
962 io = (IO*)NEWSV(0,0);
963 sv_upgrade((SV *)io,SVt_PVIO);
966 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
967 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
968 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
969 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
970 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
975 Perl_gv_check(pTHX_ HV *stash)
985 for (i = 0; i <= (I32) HvMAX(stash); i++) {
986 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
987 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
988 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
990 if (hv != PL_defstash && hv != stash)
991 gv_check(hv); /* nested package */
993 else if (isALPHA(*HeKEY(entry))) {
995 gv = (GV*)HeVAL(entry);
996 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
999 /* performance hack: if filename is absolute and it's a standard
1000 * module, don't bother warning */
1002 && PERL_FILE_IS_ABSOLUTE(file)
1003 && (instr(file, "/lib/") || instr(file, ".pm")))
1007 CopLINE_set(PL_curcop, GvLINE(gv));
1009 CopFILE(PL_curcop) = file; /* set for warning */
1011 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1013 Perl_warner(aTHX_ WARN_ONCE,
1014 "Name \"%s::%s\" used only once: possible typo",
1015 HvNAME(stash), GvNAME(gv));
1022 Perl_newGVgen(pTHX_ char *pack)
1024 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1028 /* hopefully this is only called on local symbol table entries */
1031 Perl_gp_ref(pTHX_ GP *gp)
1038 /* multi-named GPs cannot be used for method cache */
1039 SvREFCNT_dec(gp->gp_cv);
1044 /* Adding a new name to a subroutine invalidates method cache */
1045 PL_sub_generation++;
1052 Perl_gp_free(pTHX_ GV *gv)
1057 if (!gv || !(gp = GvGP(gv)))
1059 if (gp->gp_refcnt == 0) {
1060 if (ckWARN_d(WARN_INTERNAL))
1061 Perl_warner(aTHX_ WARN_INTERNAL,
1062 "Attempt to free unreferenced glob pointers");
1066 /* Deleting the name of a subroutine invalidates method cache */
1067 PL_sub_generation++;
1069 if (--gp->gp_refcnt > 0) {
1070 if (gp->gp_egv == gv)
1075 SvREFCNT_dec(gp->gp_sv);
1076 SvREFCNT_dec(gp->gp_av);
1077 SvREFCNT_dec(gp->gp_hv);
1078 SvREFCNT_dec(gp->gp_io);
1079 SvREFCNT_dec(gp->gp_cv);
1080 SvREFCNT_dec(gp->gp_form);
1086 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1090 #ifdef MICROPORT /* Microport 2.4 hack */
1094 if (GvGP(gv)->gp_av)
1095 return GvGP(gv)->gp_av;
1097 return GvGP(gv_AVadd(gv))->gp_av;
1103 if (GvGP(gv)->gp_hv)
1104 return GvGP(gv)->gp_hv;
1106 return GvGP(gv_HVadd(gv))->gp_hv;
1108 #endif /* Microport 2.4 hack */
1110 /* Updates and caches the CV's */
1113 Perl_Gv_AMupdate(pTHX_ HV *stash)
1118 MAGIC* mg=mg_find((SV*)stash,'c');
1119 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1122 #ifdef OVERLOAD_VIA_HASH
1127 if (mg && amtp->was_ok_am == PL_amagic_generation
1128 && amtp->was_ok_sub == PL_sub_generation)
1129 return AMT_AMAGIC(amtp);
1130 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1132 for (i=1; i<NofAMmeth; i++) {
1133 if (amtp->table[i]) {
1134 SvREFCNT_dec(amtp->table[i]);
1138 sv_unmagic((SV*)stash, 'c');
1140 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1142 amt.was_ok_am = PL_amagic_generation;
1143 amt.was_ok_sub = PL_sub_generation;
1144 amt.fallback = AMGfallNO;
1147 #ifdef OVERLOAD_VIA_HASH
1148 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1149 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1156 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1158 if (( cp = (char *)PL_AMG_names[0] ) &&
1159 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1160 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1161 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1163 for (i = 1; i < NofAMmeth; i++) {
1165 cp = (char *)PL_AMG_names[i];
1167 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1168 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1169 switch (SvTYPE(sv)) {
1172 if (!SvOK(sv)) break;
1173 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1174 if (gv) cv = GvCV(gv);
1178 if (SvTYPE(cv) == SVt_PVCV)
1183 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1189 if (!(cv = GvCVu((GV*)sv)))
1190 cv = sv_2cv(sv, &stash, &gv, FALSE);
1195 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1207 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1209 if ((cp = PL_AMG_names[0])) {
1210 /* Try to find via inheritance. */
1211 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1217 else if (SvTRUE(sv))
1218 amt.fallback=AMGfallYES;
1220 amt.fallback=AMGfallNEVER;
1223 for (i = 1; i < NofAMmeth; i++) {
1224 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1225 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1226 cp, HvNAME(stash)) );
1227 /* don't fill the cache while looking up! */
1228 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1230 if(gv && (cv = GvCV(gv))) {
1231 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1232 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1233 /* GvSV contains the name of the method. */
1236 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1237 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1238 if (!SvPOK(GvSV(gv))
1239 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1242 /* Can be an import stub (created by `can'). */
1244 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1245 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1248 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1249 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1252 cv = GvCV(gv = ngv);
1254 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1255 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1256 GvNAME(CvGV(cv))) );
1260 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1263 AMT_AMAGIC_on(&amt);
1264 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1268 /* Here we have no table: */
1270 AMT_AMAGIC_off(&amt);
1271 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1276 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1281 CV **cvp=NULL, **ocvp=NULL;
1283 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1284 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1286 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1287 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1288 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1289 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1291 && ((cv = cvp[off=method+assignshift])
1292 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1294 (fl = 1, cv = cvp[off=method])))) {
1295 lr = -1; /* Call method for left argument */
1297 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1300 /* look for substituted methods */
1301 /* In all the covered cases we should be called with assign==0. */
1305 if ((cv = cvp[off=add_ass_amg])
1306 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1307 right = &PL_sv_yes; lr = -1; assign = 1;
1312 if ((cv = cvp[off = subtr_ass_amg])
1313 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1314 right = &PL_sv_yes; lr = -1; assign = 1;
1318 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1321 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1324 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1327 (void)((cv = cvp[off=bool__amg])
1328 || (cv = cvp[off=numer_amg])
1329 || (cv = cvp[off=string_amg]));
1335 * SV* ref causes confusion with the interpreter variable of
1338 SV* tmpRef=SvRV(left);
1339 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1341 * Just to be extra cautious. Maybe in some
1342 * additional cases sv_setsv is safe, too.
1344 SV* newref = newSVsv(tmpRef);
1345 SvOBJECT_on(newref);
1346 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1352 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1353 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1354 SV* nullsv=sv_2mortal(newSViv(0));
1356 SV* lessp = amagic_call(left,nullsv,
1357 lt_amg,AMGf_noright);
1358 logic = SvTRUE(lessp);
1360 SV* lessp = amagic_call(left,nullsv,
1361 ncmp_amg,AMGf_noright);
1362 logic = (SvNV(lessp) < 0);
1365 if (off==subtr_amg) {
1376 if ((cv = cvp[off=subtr_amg])) {
1378 left = sv_2mortal(newSViv(0));
1382 case iter_amg: /* XXXX Eventually should do to_gv. */
1389 return NULL; /* Delegate operation to standard mechanisms. */
1394 if (!cv) goto not_found;
1395 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1396 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1397 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1398 ? (amtp = (AMT*)mg->mg_ptr)->table
1400 && (cv = cvp[off=method])) { /* Method for right
1403 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1404 && (cvp=ocvp) && (lr = -1))
1405 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1406 && !(flags & AMGf_unary)) {
1407 /* We look for substitution for
1408 * comparison operations and
1410 if (method==concat_amg || method==concat_ass_amg
1411 || method==repeat_amg || method==repeat_ass_amg) {
1412 return NULL; /* Delegate operation to string conversion */
1422 postpr = 1; off=ncmp_amg; break;
1429 postpr = 1; off=scmp_amg; break;
1431 if (off != -1) cv = cvp[off];
1436 not_found: /* No method found, either report or croak */
1437 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1438 notfound = 1; lr = -1;
1439 } else if (cvp && (cv=cvp[nomethod_amg])) {
1440 notfound = 1; lr = 1;
1443 if (off==-1) off=method;
1444 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1445 "Operation `%s': no method found,%sargument %s%s%s%s",
1446 PL_AMG_names[method + assignshift],
1447 (flags & AMGf_unary ? " " : "\n\tleft "),
1449 "in overloaded package ":
1450 "has no overloaded magic",
1452 HvNAME(SvSTASH(SvRV(left))):
1455 ",\n\tright argument in overloaded package ":
1458 : ",\n\tright argument has no overloaded magic"),
1460 HvNAME(SvSTASH(SvRV(right))):
1462 if (amtp && amtp->fallback >= AMGfallYES) {
1463 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1465 Perl_croak(aTHX_ "%"SVf, msg);
1469 force_cpy = force_cpy || assign;
1473 DEBUG_o( Perl_deb(aTHX_
1474 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1476 method+assignshift==off? "" :
1478 method+assignshift==off? "" :
1479 PL_AMG_names[method+assignshift],
1480 method+assignshift==off? "" : "')",
1481 flags & AMGf_unary? "" :
1482 lr==1 ? " for right argument": " for left argument",
1483 flags & AMGf_unary? " for argument" : "",
1485 fl? ",\n\tassignment variant used": "") );
1487 /* Since we use shallow copy during assignment, we need
1488 * to dublicate the contents, probably calling user-supplied
1489 * version of copy operator
1491 /* We need to copy in following cases:
1492 * a) Assignment form was called.
1493 * assignshift==1, assign==T, method + 1 == off
1494 * b) Increment or decrement, called directly.
1495 * assignshift==0, assign==0, method + 0 == off
1496 * c) Increment or decrement, translated to assignment add/subtr.
1497 * assignshift==0, assign==T,
1499 * d) Increment or decrement, translated to nomethod.
1500 * assignshift==0, assign==0,
1502 * e) Assignment form translated to nomethod.
1503 * assignshift==1, assign==T, method + 1 != off
1506 /* off is method, method+assignshift, or a result of opcode substitution.
1507 * In the latter case assignshift==0, so only notfound case is important.
1509 if (( (method + assignshift == off)
1510 && (assign || (method == inc_amg) || (method == dec_amg)))
1517 bool oldcatch = CATCH_GET;
1520 Zero(&myop, 1, BINOP);
1521 myop.op_last = (OP *) &myop;
1522 myop.op_next = Nullop;
1523 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1525 PUSHSTACKi(PERLSI_OVERLOAD);
1528 PL_op = (OP *) &myop;
1529 if (PERLDB_SUB && PL_curstash != PL_debstash)
1530 PL_op->op_private |= OPpENTERSUB_DB;
1534 EXTEND(SP, notfound + 5);
1535 PUSHs(lr>0? right: left);
1536 PUSHs(lr>0? left: right);
1537 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1539 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1544 if ((PL_op = Perl_pp_entersub(aTHX)))
1552 CATCH_SET(oldcatch);
1559 ans=SvIV(res)<=0; break;
1562 ans=SvIV(res)<0; break;
1565 ans=SvIV(res)>=0; break;
1568 ans=SvIV(res)>0; break;
1571 ans=SvIV(res)==0; break;
1574 ans=SvIV(res)!=0; break;
1577 SvSetSV(left,res); return left;
1579 ans=!SvTRUE(res); break;
1582 } else if (method==copy_amg) {
1584 Perl_croak(aTHX_ "Copy method did not return a reference");
1586 return SvREFCNT_inc(SvRV(res));
1594 =for apidoc is_gv_magical
1596 Returns C<TRUE> if given the name of a magical GV.
1598 Currently only useful internally when determining if a GV should be
1599 created even in rvalue contexts.
1601 C<flags> is not used at present but available for future extension to
1602 allow selecting particular classes of magical variable.
1607 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1614 if (len == 3 && strEQ(name, "ISA"))
1618 if (len == 8 && strEQ(name, "OVERLOAD"))
1622 if (len == 3 && strEQ(name, "SIG"))
1625 case '\027': /* $^W & $^WARNING_BITS */
1627 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1628 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1660 case '\001': /* $^A */
1661 case '\003': /* $^C */
1662 case '\004': /* $^D */
1663 case '\005': /* $^E */
1664 case '\006': /* $^F */
1665 case '\010': /* $^H */
1666 case '\011': /* $^I, NOT \t in EBCDIC */
1667 case '\014': /* $^L */
1668 case '\017': /* $^O */
1669 case '\020': /* $^P */
1670 case '\023': /* $^S */
1671 case '\024': /* $^T */
1672 case '\026': /* $^V */
1686 char *end = name + len;
1687 while (--end > name) {