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 */
584 if (isIDFIRST_lazy(name)) {
587 if (isUPPER(*name)) {
588 if (*name == 'S' && (
589 strEQ(name, "SIG") ||
590 strEQ(name, "STDIN") ||
591 strEQ(name, "STDOUT") ||
592 strEQ(name, "STDERR")))
594 else if (*name == 'I' && strEQ(name, "INC"))
596 else if (*name == 'E' && strEQ(name, "ENV"))
598 else if (*name == 'A' && (
599 strEQ(name, "ARGV") ||
600 strEQ(name, "ARGVOUT")))
603 else if (*name == '_' && !name[1])
608 else if ((COP*)PL_curcop == &PL_compiling) {
610 if (add && (PL_hints & HINT_STRICT_VARS) &&
611 sv_type != SVt_PVCV &&
612 sv_type != SVt_PVGV &&
613 sv_type != SVt_PVFM &&
614 sv_type != SVt_PVIO &&
615 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
617 gvp = (GV**)hv_fetch(stash,name,len,0);
619 *gvp == (GV*)&PL_sv_undef ||
620 SvTYPE(*gvp) != SVt_PVGV)
624 else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) ||
625 sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
626 sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
628 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
629 sv_type == SVt_PVAV ? '@' :
630 sv_type == SVt_PVHV ? '%' : '$',
633 Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name);
639 stash = CopSTASH(PL_curcop);
645 /* By this point we should have a stash and a name */
649 qerror(Perl_mess(aTHX_
650 "Global symbol \"%s%s\" requires explicit package name",
651 (sv_type == SVt_PV ? "$"
652 : sv_type == SVt_PVAV ? "@"
653 : sv_type == SVt_PVHV ? "%"
659 if (!SvREFCNT(stash)) /* symbol table under destruction */
662 gvp = (GV**)hv_fetch(stash,name,len,add);
663 if (!gvp || *gvp == (GV*)&PL_sv_undef)
666 if (SvTYPE(gv) == SVt_PVGV) {
669 gv_init_sv(gv, sv_type);
672 } else if (add & GV_NOINIT) {
676 /* Adding a new symbol */
678 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
679 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
680 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
681 gv_init_sv(gv, sv_type);
682 GvFLAGS(gv) |= add_gvflags;
684 if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
687 /* set up magic where warranted */
690 if (strEQ(name, "ARGV")) {
691 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
695 if (strnEQ(name, "EXPORT", 6))
699 if (strEQ(name, "ISA")) {
702 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
703 /* NOTE: No support for tied ISA */
704 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
705 && AvFILLp(av) == -1)
708 av_push(av, newSVpvn(pname = "NDBM_File",9));
709 gv_stashpvn(pname, 9, TRUE);
710 av_push(av, newSVpvn(pname = "DB_File",7));
711 gv_stashpvn(pname, 7, TRUE);
712 av_push(av, newSVpvn(pname = "GDBM_File",9));
713 gv_stashpvn(pname, 9, TRUE);
714 av_push(av, newSVpvn(pname = "SDBM_File",9));
715 gv_stashpvn(pname, 9, TRUE);
716 av_push(av, newSVpvn(pname = "ODBM_File",9));
717 gv_stashpvn(pname, 9, TRUE);
722 if (strEQ(name, "OVERLOAD")) {
725 hv_magic(hv, gv, 'A');
729 if (strEQ(name, "SIG")) {
733 int sig_num[] = { SIG_NUM };
734 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
735 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
739 hv_magic(hv, gv, 'S');
740 for (i = 1; PL_sig_name[i]; i++) {
742 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
744 sv_setsv(*init, &PL_sv_undef);
751 if (strEQ(name, "VERSION"))
758 PL_sawampersand = TRUE;
764 PL_sawampersand = TRUE;
770 PL_sawampersand = TRUE;
776 sv_setpv(GvSV(gv),PL_chopset);
782 #ifdef COMPLEX_STATUS
783 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
790 if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
791 HV* stash = gv_stashpvn("Errno",5,FALSE);
792 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
795 require_pv("Errno.pm");
797 stash = gv_stashpvn("Errno",5,FALSE);
798 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
799 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
808 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
813 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
814 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
830 case '\001': /* $^A */
831 case '\003': /* $^C */
832 case '\004': /* $^D */
833 case '\005': /* $^E */
834 case '\006': /* $^F */
835 case '\010': /* $^H */
836 case '\011': /* $^I, NOT \t in EBCDIC */
837 case '\017': /* $^O */
838 case '\020': /* $^P */
839 case '\024': /* $^T */
843 case '\023': /* $^S */
847 case '\027': /* $^W & $^Warnings */
848 if (len > 1 && strNE(name, "\027arnings"))
857 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
870 SvREADONLY_on(GvSV(gv));
872 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
875 case '\014': /* $^L */
878 sv_setpv(GvSV(gv),"\f");
879 PL_formfeed = GvSV(gv);
884 sv_setpv(GvSV(gv),"\034");
889 (void)SvUPGRADE(sv, SVt_PVNV);
890 SvNVX(sv) = SvNVX(PL_patchlevel);
892 (void)SvPV_nolen(sv);
896 case '\026': /* $^V */
899 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
908 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
910 HV *hv = GvSTASH(gv);
915 sv_setpv(sv, prefix ? prefix : "");
916 sv_catpv(sv,HvNAME(hv));
917 sv_catpvn(sv,"::", 2);
918 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
922 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
927 gv_fullname3(sv, egv, prefix);
930 /* XXX compatibility with versions <= 5.003. */
932 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
934 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
937 /* XXX compatibility with versions <= 5.003. */
939 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
941 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
951 io = (IO*)NEWSV(0,0);
952 sv_upgrade((SV *)io,SVt_PVIO);
955 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
956 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
957 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
958 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
959 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
964 Perl_gv_check(pTHX_ HV *stash)
974 for (i = 0; i <= (I32) HvMAX(stash); i++) {
975 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
976 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
977 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
979 if (hv != PL_defstash && hv != stash)
980 gv_check(hv); /* nested package */
982 else if (isALPHA(*HeKEY(entry))) {
984 gv = (GV*)HeVAL(entry);
985 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
988 /* performance hack: if filename is absolute and it's a standard
989 * module, don't bother warning */
991 && PERL_FILE_IS_ABSOLUTE(file)
992 && (instr(file, "/lib/") || instr(file, ".pm")))
996 CopLINE_set(PL_curcop, GvLINE(gv));
998 CopFILE(PL_curcop) = file; /* set for warning */
1000 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1002 Perl_warner(aTHX_ WARN_ONCE,
1003 "Name \"%s::%s\" used only once: possible typo",
1004 HvNAME(stash), GvNAME(gv));
1011 Perl_newGVgen(pTHX_ char *pack)
1013 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1017 /* hopefully this is only called on local symbol table entries */
1020 Perl_gp_ref(pTHX_ GP *gp)
1027 /* multi-named GPs cannot be used for method cache */
1028 SvREFCNT_dec(gp->gp_cv);
1033 /* Adding a new name to a subroutine invalidates method cache */
1034 PL_sub_generation++;
1041 Perl_gp_free(pTHX_ GV *gv)
1047 if (!gv || !(gp = GvGP(gv)))
1049 if (gp->gp_refcnt == 0) {
1050 if (ckWARN_d(WARN_INTERNAL))
1051 Perl_warner(aTHX_ WARN_INTERNAL,
1052 "Attempt to free unreferenced glob pointers");
1056 /* Deleting the name of a subroutine invalidates method cache */
1057 PL_sub_generation++;
1059 if (--gp->gp_refcnt > 0) {
1060 if (gp->gp_egv == gv)
1065 SvREFCNT_dec(gp->gp_sv);
1066 SvREFCNT_dec(gp->gp_av);
1067 SvREFCNT_dec(gp->gp_hv);
1068 SvREFCNT_dec(gp->gp_io);
1069 SvREFCNT_dec(gp->gp_cv);
1070 SvREFCNT_dec(gp->gp_form);
1076 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1080 #ifdef MICROPORT /* Microport 2.4 hack */
1084 if (GvGP(gv)->gp_av)
1085 return GvGP(gv)->gp_av;
1087 return GvGP(gv_AVadd(gv))->gp_av;
1093 if (GvGP(gv)->gp_hv)
1094 return GvGP(gv)->gp_hv;
1096 return GvGP(gv_HVadd(gv))->gp_hv;
1098 #endif /* Microport 2.4 hack */
1100 /* Updates and caches the CV's */
1103 Perl_Gv_AMupdate(pTHX_ HV *stash)
1110 MAGIC* mg=mg_find((SV*)stash,'c');
1111 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1115 if (mg && amtp->was_ok_am == PL_amagic_generation
1116 && amtp->was_ok_sub == PL_sub_generation)
1117 return AMT_AMAGIC(amtp);
1118 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1120 for (i=1; i<NofAMmeth; i++) {
1121 if (amtp->table[i]) {
1122 SvREFCNT_dec(amtp->table[i]);
1126 sv_unmagic((SV*)stash, 'c');
1128 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1130 amt.was_ok_am = PL_amagic_generation;
1131 amt.was_ok_sub = PL_sub_generation;
1132 amt.fallback = AMGfallNO;
1135 #ifdef OVERLOAD_VIA_HASH
1136 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1137 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1144 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1146 if (( cp = (char *)PL_AMG_names[0] ) &&
1147 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1148 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1149 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1151 for (i = 1; i < NofAMmeth; i++) {
1153 cp = (char *)PL_AMG_names[i];
1155 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1156 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1157 switch (SvTYPE(sv)) {
1160 if (!SvOK(sv)) break;
1161 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1162 if (gv) cv = GvCV(gv);
1166 if (SvTYPE(cv) == SVt_PVCV)
1171 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1177 if (!(cv = GvCVu((GV*)sv)))
1178 cv = sv_2cv(sv, &stash, &gv, FALSE);
1183 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1196 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1198 if ( cp = PL_AMG_names[0] ) {
1199 /* Try to find via inheritance. */
1200 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1201 if (gv) sv = GvSV(gv);
1203 if (!gv) goto no_table;
1204 else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1205 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1208 for (i = 1; i < NofAMmeth; i++) {
1209 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1210 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1211 cp, HvNAME(stash)) );
1212 /* don't fill the cache while looking up! */
1213 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1215 if(gv && (cv = GvCV(gv))) {
1216 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1217 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1218 /* GvSV contains the name of the method. */
1221 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1222 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1223 if (!SvPOK(GvSV(gv))
1224 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1227 /* Can be an import stub (created by `can'). */
1229 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1230 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1233 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1234 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1237 cv = GvCV(gv = ngv);
1239 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1240 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1241 GvNAME(CvGV(cv))) );
1245 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1248 AMT_AMAGIC_on(&amt);
1249 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1253 /* Here we have no table: */
1255 AMT_AMAGIC_off(&amt);
1256 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1261 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1266 CV **cvp=NULL, **ocvp=NULL;
1268 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1269 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1271 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1272 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1273 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1274 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1276 && ((cv = cvp[off=method+assignshift])
1277 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1279 (fl = 1, cv = cvp[off=method])))) {
1280 lr = -1; /* Call method for left argument */
1282 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1285 /* look for substituted methods */
1286 /* In all the covered cases we should be called with assign==0. */
1290 if ((cv = cvp[off=add_ass_amg])
1291 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1292 right = &PL_sv_yes; lr = -1; assign = 1;
1297 if ((cv = cvp[off = subtr_ass_amg])
1298 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1299 right = &PL_sv_yes; lr = -1; assign = 1;
1303 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1306 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1309 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1312 (void)((cv = cvp[off=bool__amg])
1313 || (cv = cvp[off=numer_amg])
1314 || (cv = cvp[off=string_amg]));
1320 * SV* ref causes confusion with the interpreter variable of
1323 SV* tmpRef=SvRV(left);
1324 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1326 * Just to be extra cautious. Maybe in some
1327 * additional cases sv_setsv is safe, too.
1329 SV* newref = newSVsv(tmpRef);
1330 SvOBJECT_on(newref);
1331 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1337 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1338 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1339 SV* nullsv=sv_2mortal(newSViv(0));
1341 SV* lessp = amagic_call(left,nullsv,
1342 lt_amg,AMGf_noright);
1343 logic = SvTRUE(lessp);
1345 SV* lessp = amagic_call(left,nullsv,
1346 ncmp_amg,AMGf_noright);
1347 logic = (SvNV(lessp) < 0);
1350 if (off==subtr_amg) {
1361 if (cv = cvp[off=subtr_amg]) {
1363 left = sv_2mortal(newSViv(0));
1367 case iter_amg: /* XXXX Eventually should do to_gv. */
1374 return NULL; /* Delegate operation to standard mechanisms. */
1379 if (!cv) goto not_found;
1380 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1381 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1382 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1383 ? (amtp = (AMT*)mg->mg_ptr)->table
1385 && (cv = cvp[off=method])) { /* Method for right
1388 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1389 && (cvp=ocvp) && (lr = -1))
1390 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1391 && !(flags & AMGf_unary)) {
1392 /* We look for substitution for
1393 * comparison operations and
1395 if (method==concat_amg || method==concat_ass_amg
1396 || method==repeat_amg || method==repeat_ass_amg) {
1397 return NULL; /* Delegate operation to string conversion */
1407 postpr = 1; off=ncmp_amg; break;
1414 postpr = 1; off=scmp_amg; break;
1416 if (off != -1) cv = cvp[off];
1421 not_found: /* No method found, either report or croak */
1422 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1423 notfound = 1; lr = -1;
1424 } else if (cvp && (cv=cvp[nomethod_amg])) {
1425 notfound = 1; lr = 1;
1428 if (off==-1) off=method;
1429 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1430 "Operation `%s': no method found,%sargument %s%s%s%s",
1431 PL_AMG_names[method + assignshift],
1432 (flags & AMGf_unary ? " " : "\n\tleft "),
1434 "in overloaded package ":
1435 "has no overloaded magic",
1437 HvNAME(SvSTASH(SvRV(left))):
1440 ",\n\tright argument in overloaded package ":
1443 : ",\n\tright argument has no overloaded magic"),
1445 HvNAME(SvSTASH(SvRV(right))):
1447 if (amtp && amtp->fallback >= AMGfallYES) {
1448 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1450 Perl_croak(aTHX_ "%"SVf, msg);
1454 force_cpy = force_cpy || assign;
1458 DEBUG_o( Perl_deb(aTHX_
1459 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1461 method+assignshift==off? "" :
1463 method+assignshift==off? "" :
1464 PL_AMG_names[method+assignshift],
1465 method+assignshift==off? "" : "')",
1466 flags & AMGf_unary? "" :
1467 lr==1 ? " for right argument": " for left argument",
1468 flags & AMGf_unary? " for argument" : "",
1470 fl? ",\n\tassignment variant used": "") );
1472 /* Since we use shallow copy during assignment, we need
1473 * to dublicate the contents, probably calling user-supplied
1474 * version of copy operator
1476 /* We need to copy in following cases:
1477 * a) Assignment form was called.
1478 * assignshift==1, assign==T, method + 1 == off
1479 * b) Increment or decrement, called directly.
1480 * assignshift==0, assign==0, method + 0 == off
1481 * c) Increment or decrement, translated to assignment add/subtr.
1482 * assignshift==0, assign==T,
1484 * d) Increment or decrement, translated to nomethod.
1485 * assignshift==0, assign==0,
1487 * e) Assignment form translated to nomethod.
1488 * assignshift==1, assign==T, method + 1 != off
1491 /* off is method, method+assignshift, or a result of opcode substitution.
1492 * In the latter case assignshift==0, so only notfound case is important.
1494 if (( (method + assignshift == off)
1495 && (assign || (method == inc_amg) || (method == dec_amg)))
1502 bool oldcatch = CATCH_GET;
1505 Zero(&myop, 1, BINOP);
1506 myop.op_last = (OP *) &myop;
1507 myop.op_next = Nullop;
1508 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1510 PUSHSTACKi(PERLSI_OVERLOAD);
1513 PL_op = (OP *) &myop;
1514 if (PERLDB_SUB && PL_curstash != PL_debstash)
1515 PL_op->op_private |= OPpENTERSUB_DB;
1519 EXTEND(SP, notfound + 5);
1520 PUSHs(lr>0? right: left);
1521 PUSHs(lr>0? left: right);
1522 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1524 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1529 if (PL_op = Perl_pp_entersub(aTHX))
1537 CATCH_SET(oldcatch);
1544 ans=SvIV(res)<=0; break;
1547 ans=SvIV(res)<0; break;
1550 ans=SvIV(res)>=0; break;
1553 ans=SvIV(res)>0; break;
1556 ans=SvIV(res)==0; break;
1559 ans=SvIV(res)!=0; break;
1562 SvSetSV(left,res); return left;
1564 ans=!SvTRUE(res); break;
1567 } else if (method==copy_amg) {
1569 Perl_croak(aTHX_ "Copy method did not return a reference");
1571 return SvREFCNT_inc(SvRV(res));