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, '*', name, len);
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);
439 Perl_lock(aTHX_ (SV *)varstash);
441 gv_init(vargv, varstash, autoload, autolen, FALSE);
444 Perl_lock(aTHX_ varsv);
445 sv_setpv(varsv, HvNAME(stash));
446 sv_catpvn(varsv, "::", 2);
447 sv_catpvn(varsv, name, len);
448 SvTAINTED_off(varsv);
453 =for apidoc gv_stashpv
455 Returns a pointer to the stash for a specified package. C<name> should
456 be a valid UTF-8 string. If C<create> is set then the package will be
457 created if it does not already exist. If C<create> is not set and the
458 package does not exist then NULL is returned.
464 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
466 return gv_stashpvn(name, strlen(name), create);
470 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
477 if (namelen + 3 < sizeof smallbuf)
480 New(606, tmpbuf, namelen + 3, char);
481 Copy(name,tmpbuf,namelen,char);
482 tmpbuf[namelen++] = ':';
483 tmpbuf[namelen++] = ':';
484 tmpbuf[namelen] = '\0';
485 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
486 if (tmpbuf != smallbuf)
491 GvHV(tmpgv) = newHV();
494 HvNAME(stash) = savepv(name);
499 =for apidoc gv_stashsv
501 Returns a pointer to the stash for a specified package, which must be a
502 valid UTF-8 string. See C<gv_stashpv>.
508 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
513 return gv_stashpvn(ptr, len, create);
518 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
521 register const char *name = nambeg;
525 register const char *namend;
528 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
531 for (namend = name; *namend; namend++) {
532 if ((*namend == ':' && namend[1] == ':')
533 || (*namend == '\'' && namend[1]))
537 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
545 if (len + 3 < sizeof smallbuf)
548 New(601, tmpbuf, len+3, char);
549 Copy(name, tmpbuf, len, char);
553 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
554 gv = gvp ? *gvp : Nullgv;
555 if (gv && gv != (GV*)&PL_sv_undef) {
556 if (SvTYPE(gv) != SVt_PVGV)
557 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
561 if (tmpbuf != smallbuf)
563 if (!gv || gv == (GV*)&PL_sv_undef)
566 if (!(stash = GvHV(gv)))
567 stash = GvHV(gv) = newHV();
570 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
578 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
585 /* No stash in name, so see how we can default */
588 if (isIDFIRST_lazy(name)) {
591 if (isUPPER(*name)) {
592 if (*name == 'S' && (
593 strEQ(name, "SIG") ||
594 strEQ(name, "STDIN") ||
595 strEQ(name, "STDOUT") ||
596 strEQ(name, "STDERR")))
598 else if (*name == 'I' && strEQ(name, "INC"))
600 else if (*name == 'E' && strEQ(name, "ENV"))
602 else if (*name == 'A' && (
603 strEQ(name, "ARGV") ||
604 strEQ(name, "ARGVOUT")))
607 else if (*name == '_' && !name[1])
612 else if ((COP*)PL_curcop == &PL_compiling) {
614 if (add && (PL_hints & HINT_STRICT_VARS) &&
615 sv_type != SVt_PVCV &&
616 sv_type != SVt_PVGV &&
617 sv_type != SVt_PVFM &&
618 sv_type != SVt_PVIO &&
619 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
621 gvp = (GV**)hv_fetch(stash,name,len,0);
623 *gvp == (GV*)&PL_sv_undef ||
624 SvTYPE(*gvp) != SVt_PVGV)
628 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
629 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
630 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
632 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
633 sv_type == SVt_PVAV ? '@' :
634 sv_type == SVt_PVHV ? '%' : '$',
637 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
643 stash = CopSTASH(PL_curcop);
649 /* By this point we should have a stash and a name */
653 qerror(Perl_mess(aTHX_
654 "Global symbol \"%s%s\" requires explicit package name",
655 (sv_type == SVt_PV ? "$"
656 : sv_type == SVt_PVAV ? "@"
657 : sv_type == SVt_PVHV ? "%"
659 stash = PL_nullstash;
665 if (!SvREFCNT(stash)) /* symbol table under destruction */
668 gvp = (GV**)hv_fetch(stash,name,len,add);
669 if (!gvp || *gvp == (GV*)&PL_sv_undef)
672 if (SvTYPE(gv) == SVt_PVGV) {
675 gv_init_sv(gv, sv_type);
678 } else if (add & GV_NOINIT) {
682 /* Adding a new symbol */
684 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
685 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
686 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
687 gv_init_sv(gv, sv_type);
689 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
692 /* set up magic where warranted */
695 if (strEQ(name, "ARGV")) {
696 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
700 if (strnEQ(name, "EXPORT", 6))
704 if (strEQ(name, "ISA")) {
707 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
708 /* NOTE: No support for tied ISA */
709 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
710 && AvFILLp(av) == -1)
713 av_push(av, newSVpvn(pname = "NDBM_File",9));
714 gv_stashpvn(pname, 9, TRUE);
715 av_push(av, newSVpvn(pname = "DB_File",7));
716 gv_stashpvn(pname, 7, TRUE);
717 av_push(av, newSVpvn(pname = "GDBM_File",9));
718 gv_stashpvn(pname, 9, TRUE);
719 av_push(av, newSVpvn(pname = "SDBM_File",9));
720 gv_stashpvn(pname, 9, TRUE);
721 av_push(av, newSVpvn(pname = "ODBM_File",9));
722 gv_stashpvn(pname, 9, TRUE);
727 if (strEQ(name, "OVERLOAD")) {
730 hv_magic(hv, gv, 'A');
734 if (strEQ(name, "SIG")) {
738 int sig_num[] = { SIG_NUM };
739 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
740 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
744 hv_magic(hv, gv, 'S');
745 for (i = 1; PL_sig_name[i]; i++) {
747 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
749 sv_setsv(*init, &PL_sv_undef);
756 if (strEQ(name, "VERSION"))
763 PL_sawampersand = TRUE;
769 PL_sawampersand = TRUE;
775 PL_sawampersand = TRUE;
781 sv_setpv(GvSV(gv),PL_chopset);
787 #ifdef COMPLEX_STATUS
788 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
795 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
796 HV* stash = gv_stashpvn("Errno",5,FALSE);
797 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
800 require_pv("Errno.pm");
802 stash = gv_stashpvn("Errno",5,FALSE);
803 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
804 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
813 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
818 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
819 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
835 case '\001': /* $^A */
836 case '\003': /* $^C */
837 case '\004': /* $^D */
838 case '\005': /* $^E */
839 case '\006': /* $^F */
840 case '\010': /* $^H */
841 case '\011': /* $^I, NOT \t in EBCDIC */
842 case '\017': /* $^O */
843 case '\020': /* $^P */
844 case '\024': /* $^T */
848 case '\023': /* $^S */
852 case '\027': /* $^W & $^WARNING_BITS */
853 if (len > 1 && strNE(name, "\027ARNING_BITS")
854 && strNE(name, "\027IDE_SYSTEM_CALLS"))
863 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
876 SvREADONLY_on(GvSV(gv));
878 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
881 case '\014': /* $^L */
884 sv_setpv(GvSV(gv),"\f");
885 PL_formfeed = GvSV(gv);
890 sv_setpv(GvSV(gv),"\034");
895 (void)SvUPGRADE(sv, SVt_PVNV);
896 SvNVX(sv) = SvNVX(PL_patchlevel);
898 (void)SvPV_nolen(sv);
902 case '\026': /* $^V */
905 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
914 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
916 HV *hv = GvSTASH(gv);
921 sv_setpv(sv, prefix ? prefix : "");
922 sv_catpv(sv,HvNAME(hv));
923 sv_catpvn(sv,"::", 2);
924 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
928 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
933 gv_fullname3(sv, egv, prefix);
936 /* XXX compatibility with versions <= 5.003. */
938 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
940 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
943 /* XXX compatibility with versions <= 5.003. */
945 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
947 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
957 io = (IO*)NEWSV(0,0);
958 sv_upgrade((SV *)io,SVt_PVIO);
961 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
962 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
963 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
964 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
965 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
970 Perl_gv_check(pTHX_ HV *stash)
980 for (i = 0; i <= (I32) HvMAX(stash); i++) {
981 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
982 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
983 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
985 if (hv != PL_defstash && hv != stash)
986 gv_check(hv); /* nested package */
988 else if (isALPHA(*HeKEY(entry))) {
990 gv = (GV*)HeVAL(entry);
991 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
994 /* performance hack: if filename is absolute and it's a standard
995 * module, don't bother warning */
997 && PERL_FILE_IS_ABSOLUTE(file)
998 && (instr(file, "/lib/") || instr(file, ".pm")))
1002 CopLINE_set(PL_curcop, GvLINE(gv));
1004 CopFILE(PL_curcop) = file; /* set for warning */
1006 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1008 Perl_warner(aTHX_ WARN_ONCE,
1009 "Name \"%s::%s\" used only once: possible typo",
1010 HvNAME(stash), GvNAME(gv));
1017 Perl_newGVgen(pTHX_ char *pack)
1019 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1023 /* hopefully this is only called on local symbol table entries */
1026 Perl_gp_ref(pTHX_ GP *gp)
1033 /* multi-named GPs cannot be used for method cache */
1034 SvREFCNT_dec(gp->gp_cv);
1039 /* Adding a new name to a subroutine invalidates method cache */
1040 PL_sub_generation++;
1047 Perl_gp_free(pTHX_ GV *gv)
1052 if (!gv || !(gp = GvGP(gv)))
1054 if (gp->gp_refcnt == 0) {
1055 if (ckWARN_d(WARN_INTERNAL))
1056 Perl_warner(aTHX_ WARN_INTERNAL,
1057 "Attempt to free unreferenced glob pointers");
1061 /* Deleting the name of a subroutine invalidates method cache */
1062 PL_sub_generation++;
1064 if (--gp->gp_refcnt > 0) {
1065 if (gp->gp_egv == gv)
1070 SvREFCNT_dec(gp->gp_sv);
1071 SvREFCNT_dec(gp->gp_av);
1072 SvREFCNT_dec(gp->gp_hv);
1073 SvREFCNT_dec(gp->gp_io);
1074 SvREFCNT_dec(gp->gp_cv);
1075 SvREFCNT_dec(gp->gp_form);
1081 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1085 #ifdef MICROPORT /* Microport 2.4 hack */
1089 if (GvGP(gv)->gp_av)
1090 return GvGP(gv)->gp_av;
1092 return GvGP(gv_AVadd(gv))->gp_av;
1098 if (GvGP(gv)->gp_hv)
1099 return GvGP(gv)->gp_hv;
1101 return GvGP(gv_HVadd(gv))->gp_hv;
1103 #endif /* Microport 2.4 hack */
1105 /* Updates and caches the CV's */
1108 Perl_Gv_AMupdate(pTHX_ HV *stash)
1113 MAGIC* mg=mg_find((SV*)stash,'c');
1114 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1117 #ifdef OVERLOAD_VIA_HASH
1122 if (mg && amtp->was_ok_am == PL_amagic_generation
1123 && amtp->was_ok_sub == PL_sub_generation)
1124 return AMT_AMAGIC(amtp);
1125 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1127 for (i=1; i<NofAMmeth; i++) {
1128 if (amtp->table[i]) {
1129 SvREFCNT_dec(amtp->table[i]);
1133 sv_unmagic((SV*)stash, 'c');
1135 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1137 amt.was_ok_am = PL_amagic_generation;
1138 amt.was_ok_sub = PL_sub_generation;
1139 amt.fallback = AMGfallNO;
1142 #ifdef OVERLOAD_VIA_HASH
1143 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1144 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1151 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1153 if (( cp = (char *)PL_AMG_names[0] ) &&
1154 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1155 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1156 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1158 for (i = 1; i < NofAMmeth; i++) {
1160 cp = (char *)PL_AMG_names[i];
1162 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1163 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1164 switch (SvTYPE(sv)) {
1167 if (!SvOK(sv)) break;
1168 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1169 if (gv) cv = GvCV(gv);
1173 if (SvTYPE(cv) == SVt_PVCV)
1178 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1184 if (!(cv = GvCVu((GV*)sv)))
1185 cv = sv_2cv(sv, &stash, &gv, FALSE);
1190 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1202 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1204 if ((cp = PL_AMG_names[0])) {
1205 /* Try to find via inheritance. */
1206 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1212 else if (SvTRUE(sv))
1213 amt.fallback=AMGfallYES;
1215 amt.fallback=AMGfallNEVER;
1218 for (i = 1; i < NofAMmeth; i++) {
1219 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1220 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1221 cp, HvNAME(stash)) );
1222 /* don't fill the cache while looking up! */
1223 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1225 if(gv && (cv = GvCV(gv))) {
1226 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1227 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1228 /* GvSV contains the name of the method. */
1231 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1232 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1233 if (!SvPOK(GvSV(gv))
1234 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1237 /* Can be an import stub (created by `can'). */
1239 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1240 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1243 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1244 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1247 cv = GvCV(gv = ngv);
1249 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1250 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1251 GvNAME(CvGV(cv))) );
1255 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1258 AMT_AMAGIC_on(&amt);
1259 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1263 /* Here we have no table: */
1265 AMT_AMAGIC_off(&amt);
1266 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1271 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1276 CV **cvp=NULL, **ocvp=NULL;
1278 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1279 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1281 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1282 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1283 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1284 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1286 && ((cv = cvp[off=method+assignshift])
1287 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1289 (fl = 1, cv = cvp[off=method])))) {
1290 lr = -1; /* Call method for left argument */
1292 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1295 /* look for substituted methods */
1296 /* In all the covered cases we should be called with assign==0. */
1300 if ((cv = cvp[off=add_ass_amg])
1301 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1302 right = &PL_sv_yes; lr = -1; assign = 1;
1307 if ((cv = cvp[off = subtr_ass_amg])
1308 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1309 right = &PL_sv_yes; lr = -1; assign = 1;
1313 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1316 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1319 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1322 (void)((cv = cvp[off=bool__amg])
1323 || (cv = cvp[off=numer_amg])
1324 || (cv = cvp[off=string_amg]));
1330 * SV* ref causes confusion with the interpreter variable of
1333 SV* tmpRef=SvRV(left);
1334 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1336 * Just to be extra cautious. Maybe in some
1337 * additional cases sv_setsv is safe, too.
1339 SV* newref = newSVsv(tmpRef);
1340 SvOBJECT_on(newref);
1341 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1347 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1348 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1349 SV* nullsv=sv_2mortal(newSViv(0));
1351 SV* lessp = amagic_call(left,nullsv,
1352 lt_amg,AMGf_noright);
1353 logic = SvTRUE(lessp);
1355 SV* lessp = amagic_call(left,nullsv,
1356 ncmp_amg,AMGf_noright);
1357 logic = (SvNV(lessp) < 0);
1360 if (off==subtr_amg) {
1371 if ((cv = cvp[off=subtr_amg])) {
1373 left = sv_2mortal(newSViv(0));
1377 case iter_amg: /* XXXX Eventually should do to_gv. */
1384 return NULL; /* Delegate operation to standard mechanisms. */
1389 if (!cv) goto not_found;
1390 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1391 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1392 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1393 ? (amtp = (AMT*)mg->mg_ptr)->table
1395 && (cv = cvp[off=method])) { /* Method for right
1398 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1399 && (cvp=ocvp) && (lr = -1))
1400 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1401 && !(flags & AMGf_unary)) {
1402 /* We look for substitution for
1403 * comparison operations and
1405 if (method==concat_amg || method==concat_ass_amg
1406 || method==repeat_amg || method==repeat_ass_amg) {
1407 return NULL; /* Delegate operation to string conversion */
1417 postpr = 1; off=ncmp_amg; break;
1424 postpr = 1; off=scmp_amg; break;
1426 if (off != -1) cv = cvp[off];
1431 not_found: /* No method found, either report or croak */
1432 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1433 notfound = 1; lr = -1;
1434 } else if (cvp && (cv=cvp[nomethod_amg])) {
1435 notfound = 1; lr = 1;
1438 if (off==-1) off=method;
1439 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1440 "Operation `%s': no method found,%sargument %s%s%s%s",
1441 PL_AMG_names[method + assignshift],
1442 (flags & AMGf_unary ? " " : "\n\tleft "),
1444 "in overloaded package ":
1445 "has no overloaded magic",
1447 HvNAME(SvSTASH(SvRV(left))):
1450 ",\n\tright argument in overloaded package ":
1453 : ",\n\tright argument has no overloaded magic"),
1455 HvNAME(SvSTASH(SvRV(right))):
1457 if (amtp && amtp->fallback >= AMGfallYES) {
1458 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1460 Perl_croak(aTHX_ "%"SVf, msg);
1464 force_cpy = force_cpy || assign;
1468 DEBUG_o( Perl_deb(aTHX_
1469 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1471 method+assignshift==off? "" :
1473 method+assignshift==off? "" :
1474 PL_AMG_names[method+assignshift],
1475 method+assignshift==off? "" : "')",
1476 flags & AMGf_unary? "" :
1477 lr==1 ? " for right argument": " for left argument",
1478 flags & AMGf_unary? " for argument" : "",
1480 fl? ",\n\tassignment variant used": "") );
1482 /* Since we use shallow copy during assignment, we need
1483 * to dublicate the contents, probably calling user-supplied
1484 * version of copy operator
1486 /* We need to copy in following cases:
1487 * a) Assignment form was called.
1488 * assignshift==1, assign==T, method + 1 == off
1489 * b) Increment or decrement, called directly.
1490 * assignshift==0, assign==0, method + 0 == off
1491 * c) Increment or decrement, translated to assignment add/subtr.
1492 * assignshift==0, assign==T,
1494 * d) Increment or decrement, translated to nomethod.
1495 * assignshift==0, assign==0,
1497 * e) Assignment form translated to nomethod.
1498 * assignshift==1, assign==T, method + 1 != off
1501 /* off is method, method+assignshift, or a result of opcode substitution.
1502 * In the latter case assignshift==0, so only notfound case is important.
1504 if (( (method + assignshift == off)
1505 && (assign || (method == inc_amg) || (method == dec_amg)))
1512 bool oldcatch = CATCH_GET;
1515 Zero(&myop, 1, BINOP);
1516 myop.op_last = (OP *) &myop;
1517 myop.op_next = Nullop;
1518 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1520 PUSHSTACKi(PERLSI_OVERLOAD);
1523 PL_op = (OP *) &myop;
1524 if (PERLDB_SUB && PL_curstash != PL_debstash)
1525 PL_op->op_private |= OPpENTERSUB_DB;
1529 EXTEND(SP, notfound + 5);
1530 PUSHs(lr>0? right: left);
1531 PUSHs(lr>0? left: right);
1532 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1534 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1539 if ((PL_op = Perl_pp_entersub(aTHX)))
1547 CATCH_SET(oldcatch);
1554 ans=SvIV(res)<=0; break;
1557 ans=SvIV(res)<0; break;
1560 ans=SvIV(res)>=0; break;
1563 ans=SvIV(res)>0; break;
1566 ans=SvIV(res)==0; break;
1569 ans=SvIV(res)!=0; break;
1572 SvSetSV(left,res); return left;
1574 ans=!SvTRUE(res); break;
1577 } else if (method==copy_amg) {
1579 Perl_croak(aTHX_ "Copy method did not return a reference");
1581 return SvREFCNT_inc(SvRV(res));
1589 =for apidoc is_gv_magical
1591 Returns C<TRUE> if given the name of a magical GV.
1593 Currently only useful internally when determining if a GV should be
1594 created even in rvalue contexts.
1596 C<flags> is not used at present but available for future extension to
1597 allow selecting particular classes of magical variable.
1602 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1609 if (len == 3 && strEQ(name, "ISA"))
1613 if (len == 8 && strEQ(name, "OVERLOAD"))
1617 if (len == 3 && strEQ(name, "SIG"))
1620 case '\027': /* $^W & $^WARNING_BITS */
1622 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1623 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1655 case '\001': /* $^A */
1656 case '\003': /* $^C */
1657 case '\004': /* $^D */
1658 case '\005': /* $^E */
1659 case '\006': /* $^F */
1660 case '\010': /* $^H */
1661 case '\011': /* $^I, NOT \t in EBCDIC */
1662 case '\014': /* $^L */
1663 case '\017': /* $^O */
1664 case '\020': /* $^P */
1665 case '\023': /* $^S */
1666 case '\024': /* $^T */
1667 case '\026': /* $^V */
1681 char *end = name + len;
1682 while (--end > name) {