3 * Copyright (c) 1991-1999, 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<perl_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)) {
273 * Cache method in topgv if:
274 * 1. topgv has no synonyms (else inheritance crosses wires)
275 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
278 GvREFCNT(topgv) == 1 &&
280 (CvROOT(cv) || CvXSUB(cv)))
282 if (cv = GvCV(topgv))
284 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
285 GvCVGEN(topgv) = PL_sub_generation;
289 else if (topgv && GvREFCNT(topgv) == 1) {
290 /* cache the fact that the method is not defined */
291 GvCVGEN(topgv) = PL_sub_generation;
300 =for apidoc gv_fetchmethod
302 See L<gv_fetchmethod_autoload.
308 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
310 return gv_fetchmethod_autoload(stash, name, TRUE);
314 =for apidoc gv_fetchmethod_autoload
316 Returns the glob which contains the subroutine to call to invoke the method
317 on the C<stash>. In fact in the presence of autoloading this may be the
318 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
321 The third parameter of C<gv_fetchmethod_autoload> determines whether
322 AUTOLOAD lookup is performed if the given method is not present: non-zero
323 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
324 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
325 with a non-zero C<autoload> parameter.
327 These functions grant C<"SUPER"> token as a prefix of the method name. Note
328 that if you want to keep the returned glob for a long time, you need to
329 check for it being "AUTOLOAD", since at the later time the call may load a
330 different subroutine due to $AUTOLOAD changing its value. Use the glob
331 created via a side effect to do this.
333 These functions have the same side-effects and as C<gv_fetchmeth> with
334 C<level==0>. C<name> should be writable if contains C<':'> or C<'
335 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
336 C<perl_call_sv> apply equally to these functions.
342 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
345 register const char *nend;
346 const char *nsplit = 0;
349 for (nend = name; *nend; nend++) {
352 else if (*nend == ':' && *(nend + 1) == ':')
356 const char *origname = name;
360 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
361 /* ->SUPER::method should really be looked up in original stash */
362 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
363 CopSTASHPV(PL_curcop)));
364 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
365 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
366 origname, HvNAME(stash), name) );
369 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
372 gv = gv_fetchmeth(stash, name, nend - name, 0);
374 if (strEQ(name,"import"))
375 gv = (GV*)&PL_sv_yes;
377 gv = gv_autoload4(stash, name, nend - name, TRUE);
381 if (!CvROOT(cv) && !CvXSUB(cv)) {
389 if (GvCV(stubgv) != cv) /* orphaned import */
392 autogv = gv_autoload4(GvSTASH(stubgv),
393 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
403 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
406 static char autoload[] = "AUTOLOAD";
407 static STRLEN autolen = 8;
414 if (len == autolen && strnEQ(name, autoload, autolen))
416 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
421 * Inheriting AUTOLOAD for non-methods works ... for now.
423 if (ckWARN(WARN_DEPRECATED) && !method &&
424 (GvCVGEN(gv) || GvSTASH(gv) != stash))
425 Perl_warner(aTHX_ WARN_DEPRECATED,
426 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
427 HvNAME(stash), (int)len, name);
430 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
431 * The subroutine's original name may not be "AUTOLOAD", so we don't
432 * use that, but for lack of anything better we will use the sub's
433 * original package to look up $AUTOLOAD.
435 varstash = GvSTASH(CvGV(cv));
436 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
438 gv_init(vargv, varstash, autoload, autolen, FALSE);
440 sv_setpv(varsv, HvNAME(stash));
441 sv_catpvn(varsv, "::", 2);
442 sv_catpvn(varsv, name, len);
443 SvTAINTED_off(varsv);
448 =for apidoc gv_stashpv
450 Returns a pointer to the stash for a specified package. If C<create> is
451 set then the package will be created if it does not already exist. If
452 C<create> is not set and the package does not exist then NULL is
459 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
461 return gv_stashpvn(name, strlen(name), create);
465 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
472 if (namelen + 3 < sizeof smallbuf)
475 New(606, tmpbuf, namelen + 3, char);
476 Copy(name,tmpbuf,namelen,char);
477 tmpbuf[namelen++] = ':';
478 tmpbuf[namelen++] = ':';
479 tmpbuf[namelen] = '\0';
480 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
481 if (tmpbuf != smallbuf)
486 GvHV(tmpgv) = newHV();
489 HvNAME(stash) = savepv(name);
494 =for apidoc gv_stashsv
496 Returns a pointer to the stash for a specified package. See
503 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
508 return gv_stashpvn(ptr, len, create);
513 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
516 register const char *name = nambeg;
520 register const char *namend;
524 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
527 for (namend = name; *namend; namend++) {
528 if ((*namend == ':' && namend[1] == ':')
529 || (*namend == '\'' && namend[1]))
533 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
541 if (len + 3 < sizeof smallbuf)
544 New(601, tmpbuf, len+3, char);
545 Copy(name, tmpbuf, len, char);
549 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
550 gv = gvp ? *gvp : Nullgv;
551 if (gv && gv != (GV*)&PL_sv_undef) {
552 if (SvTYPE(gv) != SVt_PVGV)
553 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
557 if (tmpbuf != smallbuf)
559 if (!gv || gv == (GV*)&PL_sv_undef)
562 if (!(stash = GvHV(gv)))
563 stash = GvHV(gv) = newHV();
566 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
574 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
581 /* No stash in name, so see how we can default */
585 || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name)))
589 if (isUPPER(*name)) {
590 if (*name == 'S' && (
591 strEQ(name, "SIG") ||
592 strEQ(name, "STDIN") ||
593 strEQ(name, "STDOUT") ||
594 strEQ(name, "STDERR")))
596 else if (*name == 'I' && strEQ(name, "INC"))
598 else if (*name == 'E' && strEQ(name, "ENV"))
600 else if (*name == 'A' && (
601 strEQ(name, "ARGV") ||
602 strEQ(name, "ARGVOUT")))
605 else if (*name == '_' && !name[1])
610 else if ((COP*)PL_curcop == &PL_compiling) {
612 if (add && (PL_hints & HINT_STRICT_VARS) &&
613 sv_type != SVt_PVCV &&
614 sv_type != SVt_PVGV &&
615 sv_type != SVt_PVFM &&
616 sv_type != SVt_PVIO &&
617 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
619 gvp = (GV**)hv_fetch(stash,name,len,0);
621 *gvp == (GV*)&PL_sv_undef ||
622 SvTYPE(*gvp) != SVt_PVGV)
626 else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) ||
627 sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
628 sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
630 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
631 sv_type == SVt_PVAV ? '@' :
632 sv_type == SVt_PVHV ? '%' : '$',
635 Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name);
641 stash = CopSTASH(PL_curcop);
647 /* By this point we should have a stash and a name */
651 qerror(Perl_mess(aTHX_
652 "Global symbol \"%s%s\" requires explicit package name",
653 (sv_type == SVt_PV ? "$"
654 : sv_type == SVt_PVAV ? "@"
655 : sv_type == SVt_PVHV ? "%"
661 if (!SvREFCNT(stash)) /* symbol table under destruction */
664 gvp = (GV**)hv_fetch(stash,name,len,add);
665 if (!gvp || *gvp == (GV*)&PL_sv_undef)
668 if (SvTYPE(gv) == SVt_PVGV) {
671 gv_init_sv(gv, sv_type);
674 } else if (add & GV_NOINIT) {
678 /* Adding a new symbol */
680 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
681 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
682 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
683 gv_init_sv(gv, sv_type);
684 GvFLAGS(gv) |= add_gvflags;
686 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
689 /* set up magic where warranted */
692 if (strEQ(name, "ARGV")) {
693 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
697 if (strnEQ(name, "EXPORT", 6))
701 if (strEQ(name, "ISA")) {
704 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
705 /* NOTE: No support for tied ISA */
706 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
707 && AvFILLp(av) == -1)
710 av_push(av, newSVpvn(pname = "NDBM_File",9));
711 gv_stashpvn(pname, 9, TRUE);
712 av_push(av, newSVpvn(pname = "DB_File",7));
713 gv_stashpvn(pname, 7, TRUE);
714 av_push(av, newSVpvn(pname = "GDBM_File",9));
715 gv_stashpvn(pname, 9, TRUE);
716 av_push(av, newSVpvn(pname = "SDBM_File",9));
717 gv_stashpvn(pname, 9, TRUE);
718 av_push(av, newSVpvn(pname = "ODBM_File",9));
719 gv_stashpvn(pname, 9, TRUE);
724 if (strEQ(name, "OVERLOAD")) {
727 hv_magic(hv, gv, 'A');
731 if (strEQ(name, "SIG")) {
735 int sig_num[] = { SIG_NUM };
736 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
737 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
741 hv_magic(hv, gv, 'S');
742 for (i = 1; PL_sig_name[i]; i++) {
744 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
746 sv_setsv(*init, &PL_sv_undef);
753 if (strEQ(name, "VERSION"))
760 PL_sawampersand = TRUE;
766 PL_sawampersand = TRUE;
772 PL_sawampersand = TRUE;
778 sv_setpv(GvSV(gv),PL_chopset);
784 #ifdef COMPLEX_STATUS
785 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
792 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
793 HV* stash = gv_stashpvn("Errno",5,FALSE);
794 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
797 require_pv("Errno.pm");
799 stash = gv_stashpvn("Errno",5,FALSE);
800 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
801 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
810 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
815 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
816 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
832 case '\001': /* $^A */
833 case '\003': /* $^C */
834 case '\004': /* $^D */
835 case '\005': /* $^E */
836 case '\006': /* $^F */
837 case '\010': /* $^H */
838 case '\011': /* $^I, NOT \t in EBCDIC */
839 case '\017': /* $^O */
840 case '\020': /* $^P */
841 case '\024': /* $^T */
845 case '\023': /* $^S */
849 case '\027': /* $^W & $^Warnings */
850 if (len > 1 && strNE(name, "\027arnings"))
859 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
872 SvREADONLY_on(GvSV(gv));
874 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
877 case '\014': /* $^L */
880 sv_setpv(GvSV(gv),"\f");
881 PL_formfeed = GvSV(gv);
886 sv_setpv(GvSV(gv),"\034");
891 (void)SvUPGRADE(sv, SVt_PVNV);
892 SvNVX(sv) = SvNVX(PL_patchlevel);
894 (void)SvPV_nolen(sv);
898 case '\026': /* $^V */
901 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
910 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
912 HV *hv = GvSTASH(gv);
917 sv_setpv(sv, prefix ? prefix : "");
918 sv_catpv(sv,HvNAME(hv));
919 sv_catpvn(sv,"::", 2);
920 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
924 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
929 gv_fullname3(sv, egv, prefix);
932 /* XXX compatibility with versions <= 5.003. */
934 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
936 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
939 /* XXX compatibility with versions <= 5.003. */
941 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
943 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
953 io = (IO*)NEWSV(0,0);
954 sv_upgrade((SV *)io,SVt_PVIO);
957 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
958 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
959 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
960 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
961 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
966 Perl_gv_check(pTHX_ HV *stash)
976 for (i = 0; i <= (I32) HvMAX(stash); i++) {
977 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
978 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
979 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
981 if (hv != PL_defstash && hv != stash)
982 gv_check(hv); /* nested package */
984 else if (isALPHA(*HeKEY(entry))) {
986 gv = (GV*)HeVAL(entry);
987 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
990 /* performance hack: if filename is absolute and it's a standard
991 * module, don't bother warning */
993 && PERL_FILE_IS_ABSOLUTE(file)
994 && (instr(file, "/lib/") || instr(file, ".pm")))
998 CopLINE_set(PL_curcop, GvLINE(gv));
1000 CopFILE(PL_curcop) = file; /* set for warning */
1002 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1004 Perl_warner(aTHX_ WARN_ONCE,
1005 "Name \"%s::%s\" used only once: possible typo",
1006 HvNAME(stash), GvNAME(gv));
1013 Perl_newGVgen(pTHX_ char *pack)
1015 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1019 /* hopefully this is only called on local symbol table entries */
1022 Perl_gp_ref(pTHX_ GP *gp)
1029 /* multi-named GPs cannot be used for method cache */
1030 SvREFCNT_dec(gp->gp_cv);
1035 /* Adding a new name to a subroutine invalidates method cache */
1036 PL_sub_generation++;
1043 Perl_gp_free(pTHX_ GV *gv)
1049 if (!gv || !(gp = GvGP(gv)))
1051 if (gp->gp_refcnt == 0) {
1052 if (ckWARN_d(WARN_INTERNAL))
1053 Perl_warner(aTHX_ WARN_INTERNAL,
1054 "Attempt to free unreferenced glob pointers");
1058 /* Deleting the name of a subroutine invalidates method cache */
1059 PL_sub_generation++;
1061 if (--gp->gp_refcnt > 0) {
1062 if (gp->gp_egv == gv)
1067 SvREFCNT_dec(gp->gp_sv);
1068 SvREFCNT_dec(gp->gp_av);
1069 SvREFCNT_dec(gp->gp_hv);
1070 SvREFCNT_dec(gp->gp_io);
1071 SvREFCNT_dec(gp->gp_cv);
1072 SvREFCNT_dec(gp->gp_form);
1078 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1082 #ifdef MICROPORT /* Microport 2.4 hack */
1086 if (GvGP(gv)->gp_av)
1087 return GvGP(gv)->gp_av;
1089 return GvGP(gv_AVadd(gv))->gp_av;
1095 if (GvGP(gv)->gp_hv)
1096 return GvGP(gv)->gp_hv;
1098 return GvGP(gv_HVadd(gv))->gp_hv;
1100 #endif /* Microport 2.4 hack */
1102 /* Updates and caches the CV's */
1105 Perl_Gv_AMupdate(pTHX_ HV *stash)
1112 MAGIC* mg=mg_find((SV*)stash,'c');
1113 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1117 if (mg && amtp->was_ok_am == PL_amagic_generation
1118 && amtp->was_ok_sub == PL_sub_generation)
1119 return AMT_AMAGIC(amtp);
1120 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1122 for (i=1; i<NofAMmeth; i++) {
1123 if (amtp->table[i]) {
1124 SvREFCNT_dec(amtp->table[i]);
1128 sv_unmagic((SV*)stash, 'c');
1130 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1132 amt.was_ok_am = PL_amagic_generation;
1133 amt.was_ok_sub = PL_sub_generation;
1134 amt.fallback = AMGfallNO;
1137 #ifdef OVERLOAD_VIA_HASH
1138 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1139 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1146 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1148 if (( cp = (char *)PL_AMG_names[0] ) &&
1149 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1150 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1151 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1153 for (i = 1; i < NofAMmeth; i++) {
1155 cp = (char *)PL_AMG_names[i];
1157 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1158 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1159 switch (SvTYPE(sv)) {
1162 if (!SvOK(sv)) break;
1163 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1164 if (gv) cv = GvCV(gv);
1168 if (SvTYPE(cv) == SVt_PVCV)
1173 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1179 if (!(cv = GvCVu((GV*)sv)))
1180 cv = sv_2cv(sv, &stash, &gv, FALSE);
1185 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1198 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1200 if ( cp = PL_AMG_names[0] ) {
1201 /* Try to find via inheritance. */
1202 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1203 if (gv) sv = GvSV(gv);
1205 if (!gv) goto no_table;
1206 else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1207 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1210 for (i = 1; i < NofAMmeth; i++) {
1211 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1212 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1213 cp, HvNAME(stash)) );
1214 /* don't fill the cache while looking up! */
1215 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1217 if(gv && (cv = GvCV(gv))) {
1218 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1219 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1220 /* GvSV contains the name of the method. */
1223 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1224 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1225 if (!SvPOK(GvSV(gv))
1226 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1229 /* Can be an import stub (created by `can'). */
1231 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1232 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1235 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1236 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1239 cv = GvCV(gv = ngv);
1241 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1242 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1243 GvNAME(CvGV(cv))) );
1247 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1250 AMT_AMAGIC_on(&amt);
1251 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1255 /* Here we have no table: */
1257 AMT_AMAGIC_off(&amt);
1258 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1263 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1268 CV **cvp=NULL, **ocvp=NULL;
1270 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1271 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1273 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1274 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1275 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1276 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1278 && ((cv = cvp[off=method+assignshift])
1279 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1281 (fl = 1, cv = cvp[off=method])))) {
1282 lr = -1; /* Call method for left argument */
1284 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1287 /* look for substituted methods */
1288 /* In all the covered cases we should be called with assign==0. */
1292 if ((cv = cvp[off=add_ass_amg])
1293 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1294 right = &PL_sv_yes; lr = -1; assign = 1;
1299 if ((cv = cvp[off = subtr_ass_amg])
1300 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1301 right = &PL_sv_yes; lr = -1; assign = 1;
1305 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1308 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1311 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1314 (void)((cv = cvp[off=bool__amg])
1315 || (cv = cvp[off=numer_amg])
1316 || (cv = cvp[off=string_amg]));
1322 * SV* ref causes confusion with the interpreter variable of
1325 SV* tmpRef=SvRV(left);
1326 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1328 * Just to be extra cautious. Maybe in some
1329 * additional cases sv_setsv is safe, too.
1331 SV* newref = newSVsv(tmpRef);
1332 SvOBJECT_on(newref);
1333 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1339 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1340 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1341 SV* nullsv=sv_2mortal(newSViv(0));
1343 SV* lessp = amagic_call(left,nullsv,
1344 lt_amg,AMGf_noright);
1345 logic = SvTRUE(lessp);
1347 SV* lessp = amagic_call(left,nullsv,
1348 ncmp_amg,AMGf_noright);
1349 logic = (SvNV(lessp) < 0);
1352 if (off==subtr_amg) {
1363 if (cv = cvp[off=subtr_amg]) {
1365 left = sv_2mortal(newSViv(0));
1369 case iter_amg: /* XXXX Eventually should do to_gv. */
1376 return NULL; /* Delegate operation to standard mechanisms. */
1381 if (!cv) goto not_found;
1382 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1383 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1384 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1385 ? (amtp = (AMT*)mg->mg_ptr)->table
1387 && (cv = cvp[off=method])) { /* Method for right
1390 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1391 && (cvp=ocvp) && (lr = -1))
1392 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1393 && !(flags & AMGf_unary)) {
1394 /* We look for substitution for
1395 * comparison operations and
1397 if (method==concat_amg || method==concat_ass_amg
1398 || method==repeat_amg || method==repeat_ass_amg) {
1399 return NULL; /* Delegate operation to string conversion */
1409 postpr = 1; off=ncmp_amg; break;
1416 postpr = 1; off=scmp_amg; break;
1418 if (off != -1) cv = cvp[off];
1423 not_found: /* No method found, either report or croak */
1424 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1425 notfound = 1; lr = -1;
1426 } else if (cvp && (cv=cvp[nomethod_amg])) {
1427 notfound = 1; lr = 1;
1430 if (off==-1) off=method;
1431 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1432 "Operation `%s': no method found,%sargument %s%s%s%s",
1433 PL_AMG_names[method + assignshift],
1434 (flags & AMGf_unary ? " " : "\n\tleft "),
1436 "in overloaded package ":
1437 "has no overloaded magic",
1439 HvNAME(SvSTASH(SvRV(left))):
1442 ",\n\tright argument in overloaded package ":
1445 : ",\n\tright argument has no overloaded magic"),
1447 HvNAME(SvSTASH(SvRV(right))):
1449 if (amtp && amtp->fallback >= AMGfallYES) {
1450 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1452 Perl_croak(aTHX_ "%"SVf, msg);
1456 force_cpy = force_cpy || assign;
1460 DEBUG_o( Perl_deb(aTHX_
1461 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1463 method+assignshift==off? "" :
1465 method+assignshift==off? "" :
1466 PL_AMG_names[method+assignshift],
1467 method+assignshift==off? "" : "')",
1468 flags & AMGf_unary? "" :
1469 lr==1 ? " for right argument": " for left argument",
1470 flags & AMGf_unary? " for argument" : "",
1472 fl? ",\n\tassignment variant used": "") );
1474 /* Since we use shallow copy during assignment, we need
1475 * to dublicate the contents, probably calling user-supplied
1476 * version of copy operator
1478 /* We need to copy in following cases:
1479 * a) Assignment form was called.
1480 * assignshift==1, assign==T, method + 1 == off
1481 * b) Increment or decrement, called directly.
1482 * assignshift==0, assign==0, method + 0 == off
1483 * c) Increment or decrement, translated to assignment add/subtr.
1484 * assignshift==0, assign==T,
1486 * d) Increment or decrement, translated to nomethod.
1487 * assignshift==0, assign==0,
1489 * e) Assignment form translated to nomethod.
1490 * assignshift==1, assign==T, method + 1 != off
1493 /* off is method, method+assignshift, or a result of opcode substitution.
1494 * In the latter case assignshift==0, so only notfound case is important.
1496 if (( (method + assignshift == off)
1497 && (assign || (method == inc_amg) || (method == dec_amg)))
1504 bool oldcatch = CATCH_GET;
1507 Zero(&myop, 1, BINOP);
1508 myop.op_last = (OP *) &myop;
1509 myop.op_next = Nullop;
1510 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1512 PUSHSTACKi(PERLSI_OVERLOAD);
1515 PL_op = (OP *) &myop;
1516 if (PERLDB_SUB && PL_curstash != PL_debstash)
1517 PL_op->op_private |= OPpENTERSUB_DB;
1521 EXTEND(SP, notfound + 5);
1522 PUSHs(lr>0? right: left);
1523 PUSHs(lr>0? left: right);
1524 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1526 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1531 if (PL_op = Perl_pp_entersub(aTHX))
1539 CATCH_SET(oldcatch);
1546 ans=SvIV(res)<=0; break;
1549 ans=SvIV(res)<0; break;
1552 ans=SvIV(res)>=0; break;
1555 ans=SvIV(res)>0; break;
1558 ans=SvIV(res)==0; break;
1561 ans=SvIV(res)!=0; break;
1564 SvSetSV(left,res); return left;
1566 ans=!SvTRUE(res); break;
1569 } else if (method==copy_amg) {
1571 Perl_croak(aTHX_ "Copy method did not return a reference");
1573 return SvREFCNT_inc(SvRV(res));