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)))
425 * Inheriting AUTOLOAD for non-methods works ... for now.
427 if (ckWARN(WARN_DEPRECATED) && !method &&
428 (GvCVGEN(gv) || GvSTASH(gv) != stash))
429 Perl_warner(aTHX_ WARN_DEPRECATED,
430 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
431 HvNAME(stash), (int)len, name);
434 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
435 * The subroutine's original name may not be "AUTOLOAD", so we don't
436 * use that, but for lack of anything better we will use the sub's
437 * original package to look up $AUTOLOAD.
439 varstash = GvSTASH(CvGV(cv));
440 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
444 sv_lock((SV *)varstash);
447 gv_init(vargv, varstash, autoload, autolen, FALSE);
453 sv_setpv(varsv, HvNAME(stash));
454 sv_catpvn(varsv, "::", 2);
455 sv_catpvn(varsv, name, len);
456 SvTAINTED_off(varsv);
461 =for apidoc gv_stashpv
463 Returns a pointer to the stash for a specified package. C<name> should
464 be a valid UTF-8 string. If C<create> is set then the package will be
465 created if it does not already exist. If C<create> is not set and the
466 package does not exist then NULL is returned.
472 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
474 return gv_stashpvn(name, strlen(name), create);
478 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
485 if (namelen + 3 < sizeof smallbuf)
488 New(606, tmpbuf, namelen + 3, char);
489 Copy(name,tmpbuf,namelen,char);
490 tmpbuf[namelen++] = ':';
491 tmpbuf[namelen++] = ':';
492 tmpbuf[namelen] = '\0';
493 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
494 if (tmpbuf != smallbuf)
499 GvHV(tmpgv) = newHV();
502 HvNAME(stash) = savepv(name);
507 =for apidoc gv_stashsv
509 Returns a pointer to the stash for a specified package, which must be a
510 valid UTF-8 string. See C<gv_stashpv>.
516 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
521 return gv_stashpvn(ptr, len, create);
526 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
529 register const char *name = nambeg;
533 register const char *namend;
536 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
539 for (namend = name; *namend; namend++) {
540 if ((*namend == ':' && namend[1] == ':')
541 || (*namend == '\'' && namend[1]))
545 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
553 if (len + 3 < sizeof smallbuf)
556 New(601, tmpbuf, len+3, char);
557 Copy(name, tmpbuf, len, char);
561 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
562 gv = gvp ? *gvp : Nullgv;
563 if (gv && gv != (GV*)&PL_sv_undef) {
564 if (SvTYPE(gv) != SVt_PVGV)
565 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
569 if (tmpbuf != smallbuf)
571 if (!gv || gv == (GV*)&PL_sv_undef)
574 if (!(stash = GvHV(gv)))
575 stash = GvHV(gv) = newHV();
578 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
586 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
593 /* No stash in name, so see how we can default */
596 if (isIDFIRST_lazy(name)) {
599 if (isUPPER(*name)) {
600 if (*name == 'S' && (
601 strEQ(name, "SIG") ||
602 strEQ(name, "STDIN") ||
603 strEQ(name, "STDOUT") ||
604 strEQ(name, "STDERR")))
606 else if (*name == 'I' && strEQ(name, "INC"))
608 else if (*name == 'E' && strEQ(name, "ENV"))
610 else if (*name == 'A' && (
611 strEQ(name, "ARGV") ||
612 strEQ(name, "ARGVOUT")))
615 else if (*name == '_' && !name[1])
620 else if ((COP*)PL_curcop == &PL_compiling) {
622 if (add && (PL_hints & HINT_STRICT_VARS) &&
623 sv_type != SVt_PVCV &&
624 sv_type != SVt_PVGV &&
625 sv_type != SVt_PVFM &&
626 sv_type != SVt_PVIO &&
627 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
629 gvp = (GV**)hv_fetch(stash,name,len,0);
631 *gvp == (GV*)&PL_sv_undef ||
632 SvTYPE(*gvp) != SVt_PVGV)
636 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
637 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
638 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
640 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
641 sv_type == SVt_PVAV ? '@' :
642 sv_type == SVt_PVHV ? '%' : '$',
645 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
651 stash = CopSTASH(PL_curcop);
657 /* By this point we should have a stash and a name */
661 qerror(Perl_mess(aTHX_
662 "Global symbol \"%s%s\" requires explicit package name",
663 (sv_type == SVt_PV ? "$"
664 : sv_type == SVt_PVAV ? "@"
665 : sv_type == SVt_PVHV ? "%"
667 stash = PL_nullstash;
673 if (!SvREFCNT(stash)) /* symbol table under destruction */
676 gvp = (GV**)hv_fetch(stash,name,len,add);
677 if (!gvp || *gvp == (GV*)&PL_sv_undef)
680 if (SvTYPE(gv) == SVt_PVGV) {
683 gv_init_sv(gv, sv_type);
686 } else if (add & GV_NOINIT) {
690 /* Adding a new symbol */
692 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
693 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
694 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
695 gv_init_sv(gv, sv_type);
697 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
700 /* set up magic where warranted */
703 if (strEQ(name, "ARGV")) {
704 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
708 if (strnEQ(name, "EXPORT", 6))
712 if (strEQ(name, "ISA")) {
715 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
716 /* NOTE: No support for tied ISA */
717 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
718 && AvFILLp(av) == -1)
721 av_push(av, newSVpvn(pname = "NDBM_File",9));
722 gv_stashpvn(pname, 9, TRUE);
723 av_push(av, newSVpvn(pname = "DB_File",7));
724 gv_stashpvn(pname, 7, TRUE);
725 av_push(av, newSVpvn(pname = "GDBM_File",9));
726 gv_stashpvn(pname, 9, TRUE);
727 av_push(av, newSVpvn(pname = "SDBM_File",9));
728 gv_stashpvn(pname, 9, TRUE);
729 av_push(av, newSVpvn(pname = "ODBM_File",9));
730 gv_stashpvn(pname, 9, TRUE);
735 if (strEQ(name, "OVERLOAD")) {
738 hv_magic(hv, gv, 'A');
742 if (strEQ(name, "SIG")) {
746 int sig_num[] = { SIG_NUM };
747 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
748 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
752 hv_magic(hv, gv, 'S');
753 for (i = 1; PL_sig_name[i]; i++) {
755 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
757 sv_setsv(*init, &PL_sv_undef);
764 if (strEQ(name, "VERSION"))
771 PL_sawampersand = TRUE;
777 PL_sawampersand = TRUE;
783 PL_sawampersand = TRUE;
789 sv_setpv(GvSV(gv),PL_chopset);
795 #ifdef COMPLEX_STATUS
796 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
803 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
804 HV* stash = gv_stashpvn("Errno",5,FALSE);
805 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
808 require_pv("Errno.pm");
810 stash = gv_stashpvn("Errno",5,FALSE);
811 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
812 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
821 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
826 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
827 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
843 case '\001': /* $^A */
844 case '\003': /* $^C */
845 case '\004': /* $^D */
846 case '\005': /* $^E */
847 case '\006': /* $^F */
848 case '\010': /* $^H */
849 case '\011': /* $^I, NOT \t in EBCDIC */
850 case '\017': /* $^O */
851 case '\020': /* $^P */
852 case '\024': /* $^T */
856 case '\023': /* $^S */
860 case '\027': /* $^W & $^WARNING_BITS */
861 if (len > 1 && strNE(name, "\027ARNING_BITS")
862 && strNE(name, "\027IDE_SYSTEM_CALLS"))
871 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
884 SvREADONLY_on(GvSV(gv));
886 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
889 case '\014': /* $^L */
892 sv_setpv(GvSV(gv),"\f");
893 PL_formfeed = GvSV(gv);
898 sv_setpv(GvSV(gv),"\034");
903 (void)SvUPGRADE(sv, SVt_PVNV);
904 SvNVX(sv) = SvNVX(PL_patchlevel);
906 (void)SvPV_nolen(sv);
910 case '\026': /* $^V */
913 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
922 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
924 HV *hv = GvSTASH(gv);
929 sv_setpv(sv, prefix ? prefix : "");
930 sv_catpv(sv,HvNAME(hv));
931 sv_catpvn(sv,"::", 2);
932 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
936 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
941 gv_fullname3(sv, egv, prefix);
944 /* XXX compatibility with versions <= 5.003. */
946 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
948 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
951 /* XXX compatibility with versions <= 5.003. */
953 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
955 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
965 io = (IO*)NEWSV(0,0);
966 sv_upgrade((SV *)io,SVt_PVIO);
969 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
970 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
971 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
972 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
973 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
978 Perl_gv_check(pTHX_ HV *stash)
988 for (i = 0; i <= (I32) HvMAX(stash); i++) {
989 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
990 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
991 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
993 if (hv != PL_defstash && hv != stash)
994 gv_check(hv); /* nested package */
996 else if (isALPHA(*HeKEY(entry))) {
998 gv = (GV*)HeVAL(entry);
999 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1002 /* performance hack: if filename is absolute and it's a standard
1003 * module, don't bother warning */
1005 && PERL_FILE_IS_ABSOLUTE(file)
1006 && (instr(file, "/lib/") || instr(file, ".pm")))
1010 CopLINE_set(PL_curcop, GvLINE(gv));
1012 CopFILE(PL_curcop) = file; /* set for warning */
1014 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1016 Perl_warner(aTHX_ WARN_ONCE,
1017 "Name \"%s::%s\" used only once: possible typo",
1018 HvNAME(stash), GvNAME(gv));
1025 Perl_newGVgen(pTHX_ char *pack)
1027 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1031 /* hopefully this is only called on local symbol table entries */
1034 Perl_gp_ref(pTHX_ GP *gp)
1041 /* multi-named GPs cannot be used for method cache */
1042 SvREFCNT_dec(gp->gp_cv);
1047 /* Adding a new name to a subroutine invalidates method cache */
1048 PL_sub_generation++;
1055 Perl_gp_free(pTHX_ GV *gv)
1060 if (!gv || !(gp = GvGP(gv)))
1062 if (gp->gp_refcnt == 0) {
1063 if (ckWARN_d(WARN_INTERNAL))
1064 Perl_warner(aTHX_ WARN_INTERNAL,
1065 "Attempt to free unreferenced glob pointers");
1069 /* Deleting the name of a subroutine invalidates method cache */
1070 PL_sub_generation++;
1072 if (--gp->gp_refcnt > 0) {
1073 if (gp->gp_egv == gv)
1078 SvREFCNT_dec(gp->gp_sv);
1079 SvREFCNT_dec(gp->gp_av);
1080 SvREFCNT_dec(gp->gp_hv);
1081 SvREFCNT_dec(gp->gp_io);
1082 SvREFCNT_dec(gp->gp_cv);
1083 SvREFCNT_dec(gp->gp_form);
1089 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1093 #ifdef MICROPORT /* Microport 2.4 hack */
1097 if (GvGP(gv)->gp_av)
1098 return GvGP(gv)->gp_av;
1100 return GvGP(gv_AVadd(gv))->gp_av;
1106 if (GvGP(gv)->gp_hv)
1107 return GvGP(gv)->gp_hv;
1109 return GvGP(gv_HVadd(gv))->gp_hv;
1111 #endif /* Microport 2.4 hack */
1113 /* Updates and caches the CV's */
1116 Perl_Gv_AMupdate(pTHX_ HV *stash)
1121 MAGIC* mg=mg_find((SV*)stash,'c');
1122 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1125 #ifdef OVERLOAD_VIA_HASH
1130 if (mg && amtp->was_ok_am == PL_amagic_generation
1131 && amtp->was_ok_sub == PL_sub_generation)
1132 return AMT_AMAGIC(amtp);
1133 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1135 for (i=1; i<NofAMmeth; i++) {
1136 if (amtp->table[i]) {
1137 SvREFCNT_dec(amtp->table[i]);
1141 sv_unmagic((SV*)stash, 'c');
1143 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1145 amt.was_ok_am = PL_amagic_generation;
1146 amt.was_ok_sub = PL_sub_generation;
1147 amt.fallback = AMGfallNO;
1150 #ifdef OVERLOAD_VIA_HASH
1151 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1152 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1159 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1161 if (( cp = (char *)PL_AMG_names[0] ) &&
1162 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1163 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1164 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1166 for (i = 1; i < NofAMmeth; i++) {
1168 cp = (char *)PL_AMG_names[i];
1170 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1171 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1172 switch (SvTYPE(sv)) {
1175 if (!SvOK(sv)) break;
1176 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1177 if (gv) cv = GvCV(gv);
1181 if (SvTYPE(cv) == SVt_PVCV)
1186 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1192 if (!(cv = GvCVu((GV*)sv)))
1193 cv = sv_2cv(sv, &stash, &gv, FALSE);
1198 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1210 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1212 if ((cp = PL_AMG_names[0])) {
1213 /* Try to find via inheritance. */
1214 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1220 else if (SvTRUE(sv))
1221 amt.fallback=AMGfallYES;
1223 amt.fallback=AMGfallNEVER;
1226 for (i = 1; i < NofAMmeth; i++) {
1227 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1228 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1229 cp, HvNAME(stash)) );
1230 /* don't fill the cache while looking up! */
1231 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1233 if(gv && (cv = GvCV(gv))) {
1234 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1235 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1236 /* GvSV contains the name of the method. */
1239 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1240 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1241 if (!SvPOK(GvSV(gv))
1242 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1245 /* Can be an import stub (created by `can'). */
1247 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1248 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1251 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1252 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1255 cv = GvCV(gv = ngv);
1257 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1258 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1259 GvNAME(CvGV(cv))) );
1263 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1266 AMT_AMAGIC_on(&amt);
1267 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1271 /* Here we have no table: */
1273 AMT_AMAGIC_off(&amt);
1274 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1279 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1284 CV **cvp=NULL, **ocvp=NULL;
1286 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1287 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1289 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1290 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1291 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1292 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1294 && ((cv = cvp[off=method+assignshift])
1295 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1297 (fl = 1, cv = cvp[off=method])))) {
1298 lr = -1; /* Call method for left argument */
1300 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1303 /* look for substituted methods */
1304 /* In all the covered cases we should be called with assign==0. */
1308 if ((cv = cvp[off=add_ass_amg])
1309 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1310 right = &PL_sv_yes; lr = -1; assign = 1;
1315 if ((cv = cvp[off = subtr_ass_amg])
1316 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1317 right = &PL_sv_yes; lr = -1; assign = 1;
1321 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1324 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1327 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1330 (void)((cv = cvp[off=bool__amg])
1331 || (cv = cvp[off=numer_amg])
1332 || (cv = cvp[off=string_amg]));
1338 * SV* ref causes confusion with the interpreter variable of
1341 SV* tmpRef=SvRV(left);
1342 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1344 * Just to be extra cautious. Maybe in some
1345 * additional cases sv_setsv is safe, too.
1347 SV* newref = newSVsv(tmpRef);
1348 SvOBJECT_on(newref);
1349 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1355 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1356 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1357 SV* nullsv=sv_2mortal(newSViv(0));
1359 SV* lessp = amagic_call(left,nullsv,
1360 lt_amg,AMGf_noright);
1361 logic = SvTRUE(lessp);
1363 SV* lessp = amagic_call(left,nullsv,
1364 ncmp_amg,AMGf_noright);
1365 logic = (SvNV(lessp) < 0);
1368 if (off==subtr_amg) {
1379 if ((cv = cvp[off=subtr_amg])) {
1381 left = sv_2mortal(newSViv(0));
1385 case iter_amg: /* XXXX Eventually should do to_gv. */
1392 return NULL; /* Delegate operation to standard mechanisms. */
1397 if (!cv) goto not_found;
1398 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1399 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1400 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1401 ? (amtp = (AMT*)mg->mg_ptr)->table
1403 && (cv = cvp[off=method])) { /* Method for right
1406 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1407 && (cvp=ocvp) && (lr = -1))
1408 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1409 && !(flags & AMGf_unary)) {
1410 /* We look for substitution for
1411 * comparison operations and
1413 if (method==concat_amg || method==concat_ass_amg
1414 || method==repeat_amg || method==repeat_ass_amg) {
1415 return NULL; /* Delegate operation to string conversion */
1425 postpr = 1; off=ncmp_amg; break;
1432 postpr = 1; off=scmp_amg; break;
1434 if (off != -1) cv = cvp[off];
1439 not_found: /* No method found, either report or croak */
1440 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1441 notfound = 1; lr = -1;
1442 } else if (cvp && (cv=cvp[nomethod_amg])) {
1443 notfound = 1; lr = 1;
1446 if (off==-1) off=method;
1447 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1448 "Operation `%s': no method found,%sargument %s%s%s%s",
1449 PL_AMG_names[method + assignshift],
1450 (flags & AMGf_unary ? " " : "\n\tleft "),
1452 "in overloaded package ":
1453 "has no overloaded magic",
1455 HvNAME(SvSTASH(SvRV(left))):
1458 ",\n\tright argument in overloaded package ":
1461 : ",\n\tright argument has no overloaded magic"),
1463 HvNAME(SvSTASH(SvRV(right))):
1465 if (amtp && amtp->fallback >= AMGfallYES) {
1466 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1468 Perl_croak(aTHX_ "%"SVf, msg);
1472 force_cpy = force_cpy || assign;
1476 DEBUG_o( Perl_deb(aTHX_
1477 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1479 method+assignshift==off? "" :
1481 method+assignshift==off? "" :
1482 PL_AMG_names[method+assignshift],
1483 method+assignshift==off? "" : "')",
1484 flags & AMGf_unary? "" :
1485 lr==1 ? " for right argument": " for left argument",
1486 flags & AMGf_unary? " for argument" : "",
1488 fl? ",\n\tassignment variant used": "") );
1490 /* Since we use shallow copy during assignment, we need
1491 * to dublicate the contents, probably calling user-supplied
1492 * version of copy operator
1494 /* We need to copy in following cases:
1495 * a) Assignment form was called.
1496 * assignshift==1, assign==T, method + 1 == off
1497 * b) Increment or decrement, called directly.
1498 * assignshift==0, assign==0, method + 0 == off
1499 * c) Increment or decrement, translated to assignment add/subtr.
1500 * assignshift==0, assign==T,
1502 * d) Increment or decrement, translated to nomethod.
1503 * assignshift==0, assign==0,
1505 * e) Assignment form translated to nomethod.
1506 * assignshift==1, assign==T, method + 1 != off
1509 /* off is method, method+assignshift, or a result of opcode substitution.
1510 * In the latter case assignshift==0, so only notfound case is important.
1512 if (( (method + assignshift == off)
1513 && (assign || (method == inc_amg) || (method == dec_amg)))
1520 bool oldcatch = CATCH_GET;
1523 Zero(&myop, 1, BINOP);
1524 myop.op_last = (OP *) &myop;
1525 myop.op_next = Nullop;
1526 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1528 PUSHSTACKi(PERLSI_OVERLOAD);
1531 PL_op = (OP *) &myop;
1532 if (PERLDB_SUB && PL_curstash != PL_debstash)
1533 PL_op->op_private |= OPpENTERSUB_DB;
1537 EXTEND(SP, notfound + 5);
1538 PUSHs(lr>0? right: left);
1539 PUSHs(lr>0? left: right);
1540 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1542 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1547 if ((PL_op = Perl_pp_entersub(aTHX)))
1555 CATCH_SET(oldcatch);
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 ans=SvIV(res)!=0; break;
1580 SvSetSV(left,res); return left;
1582 ans=!SvTRUE(res); break;
1585 } else if (method==copy_amg) {
1587 Perl_croak(aTHX_ "Copy method did not return a reference");
1589 return SvREFCNT_inc(SvRV(res));
1597 =for apidoc is_gv_magical
1599 Returns C<TRUE> if given the name of a magical GV.
1601 Currently only useful internally when determining if a GV should be
1602 created even in rvalue contexts.
1604 C<flags> is not used at present but available for future extension to
1605 allow selecting particular classes of magical variable.
1610 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1617 if (len == 3 && strEQ(name, "ISA"))
1621 if (len == 8 && strEQ(name, "OVERLOAD"))
1625 if (len == 3 && strEQ(name, "SIG"))
1628 case '\027': /* $^W & $^WARNING_BITS */
1630 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1631 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1663 case '\001': /* $^A */
1664 case '\003': /* $^C */
1665 case '\004': /* $^D */
1666 case '\005': /* $^E */
1667 case '\006': /* $^F */
1668 case '\010': /* $^H */
1669 case '\011': /* $^I, NOT \t in EBCDIC */
1670 case '\014': /* $^L */
1671 case '\017': /* $^O */
1672 case '\020': /* $^P */
1673 case '\023': /* $^S */
1674 case '\024': /* $^T */
1675 case '\026': /* $^V */
1689 char *end = name + len;
1690 while (--end > name) {