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)), Nullgv, '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") || strEQ(name,"unimport"))
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, Nullgv, '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, Nullgv, '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);
827 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
828 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
844 case '\001': /* $^A */
845 case '\003': /* $^C */
846 case '\004': /* $^D */
847 case '\005': /* $^E */
848 case '\006': /* $^F */
849 case '\010': /* $^H */
850 case '\011': /* $^I, NOT \t in EBCDIC */
851 case '\020': /* $^P */
852 case '\024': /* $^T */
856 case '\017': /* $^O & $^OPEN */
857 if (len > 1 && strNE(name, "\017PEN"))
860 case '\023': /* $^S */
864 case '\027': /* $^W & $^WARNING_BITS */
865 if (len > 1 && strNE(name, "\027ARNING_BITS")
866 && strNE(name, "\027IDE_SYSTEM_CALLS"))
875 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
889 SvREADONLY_on(GvSV(gv));
891 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
894 case '\014': /* $^L */
897 sv_setpv(GvSV(gv),"\f");
898 PL_formfeed = GvSV(gv);
903 sv_setpv(GvSV(gv),"\034");
908 (void)SvUPGRADE(sv, SVt_PVNV);
909 Perl_sv_setpvf(aTHX_ sv,
910 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
916 SvNVX(PL_patchlevel));
917 SvNVX(sv) = SvNVX(PL_patchlevel);
922 case '\026': /* $^V */
925 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
934 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
936 HV *hv = GvSTASH(gv);
941 sv_setpv(sv, prefix ? prefix : "");
942 if (keepmain || strNE(HvNAME(hv), "main")) {
943 sv_catpv(sv,HvNAME(hv));
944 sv_catpvn(sv,"::", 2);
946 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
950 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
952 HV *hv = GvSTASH(gv);
957 sv_setpv(sv, prefix ? prefix : "");
958 sv_catpv(sv,HvNAME(hv));
959 sv_catpvn(sv,"::", 2);
960 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
964 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
969 gv_fullname4(sv, egv, prefix, keepmain);
973 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
978 gv_fullname3(sv, egv, prefix);
981 /* XXX compatibility with versions <= 5.003. */
983 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
985 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
988 /* XXX compatibility with versions <= 5.003. */
990 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
992 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1002 io = (IO*)NEWSV(0,0);
1003 sv_upgrade((SV *)io,SVt_PVIO);
1006 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1007 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1008 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1009 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1010 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1015 Perl_gv_check(pTHX_ HV *stash)
1023 if (!HvARRAY(stash))
1025 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1026 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1027 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1028 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1030 if (hv != PL_defstash && hv != stash)
1031 gv_check(hv); /* nested package */
1033 else if (isALPHA(*HeKEY(entry))) {
1035 gv = (GV*)HeVAL(entry);
1036 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1039 /* performance hack: if filename is absolute and it's a standard
1040 * module, don't bother warning */
1042 && PERL_FILE_IS_ABSOLUTE(file)
1043 && (instr(file, "/lib/") || instr(file, ".pm")))
1047 CopLINE_set(PL_curcop, GvLINE(gv));
1049 CopFILE(PL_curcop) = file; /* set for warning */
1051 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1053 Perl_warner(aTHX_ WARN_ONCE,
1054 "Name \"%s::%s\" used only once: possible typo",
1055 HvNAME(stash), GvNAME(gv));
1062 Perl_newGVgen(pTHX_ char *pack)
1064 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1068 /* hopefully this is only called on local symbol table entries */
1071 Perl_gp_ref(pTHX_ GP *gp)
1078 /* multi-named GPs cannot be used for method cache */
1079 SvREFCNT_dec(gp->gp_cv);
1084 /* Adding a new name to a subroutine invalidates method cache */
1085 PL_sub_generation++;
1092 Perl_gp_free(pTHX_ GV *gv)
1097 if (!gv || !(gp = GvGP(gv)))
1099 if (gp->gp_refcnt == 0) {
1100 if (ckWARN_d(WARN_INTERNAL))
1101 Perl_warner(aTHX_ WARN_INTERNAL,
1102 "Attempt to free unreferenced glob pointers");
1106 /* Deleting the name of a subroutine invalidates method cache */
1107 PL_sub_generation++;
1109 if (--gp->gp_refcnt > 0) {
1110 if (gp->gp_egv == gv)
1115 SvREFCNT_dec(gp->gp_sv);
1116 SvREFCNT_dec(gp->gp_av);
1117 SvREFCNT_dec(gp->gp_hv);
1118 SvREFCNT_dec(gp->gp_io);
1119 SvREFCNT_dec(gp->gp_cv);
1120 SvREFCNT_dec(gp->gp_form);
1126 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1130 #ifdef MICROPORT /* Microport 2.4 hack */
1134 if (GvGP(gv)->gp_av)
1135 return GvGP(gv)->gp_av;
1137 return GvGP(gv_AVadd(gv))->gp_av;
1143 if (GvGP(gv)->gp_hv)
1144 return GvGP(gv)->gp_hv;
1146 return GvGP(gv_HVadd(gv))->gp_hv;
1148 #endif /* Microport 2.4 hack */
1150 /* Updates and caches the CV's */
1153 Perl_Gv_AMupdate(pTHX_ HV *stash)
1158 MAGIC* mg=mg_find((SV*)stash,'c');
1159 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1162 #ifdef OVERLOAD_VIA_HASH
1167 if (mg && amtp->was_ok_am == PL_amagic_generation
1168 && amtp->was_ok_sub == PL_sub_generation)
1169 return AMT_AMAGIC(amtp);
1170 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1172 for (i=1; i<NofAMmeth; i++) {
1173 if (amtp->table[i]) {
1174 SvREFCNT_dec(amtp->table[i]);
1178 sv_unmagic((SV*)stash, 'c');
1180 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1182 amt.was_ok_am = PL_amagic_generation;
1183 amt.was_ok_sub = PL_sub_generation;
1184 amt.fallback = AMGfallNO;
1187 #ifdef OVERLOAD_VIA_HASH
1188 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1189 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1196 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1198 if (( cp = (char *)PL_AMG_names[0] ) &&
1199 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1200 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1201 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1203 for (i = 1; i < NofAMmeth; i++) {
1205 cp = (char *)PL_AMG_names[i];
1207 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1208 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1209 switch (SvTYPE(sv)) {
1212 if (!SvOK(sv)) break;
1213 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1214 if (gv) cv = GvCV(gv);
1218 if (SvTYPE(cv) == SVt_PVCV)
1223 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1229 if (!(cv = GvCVu((GV*)sv)))
1230 cv = sv_2cv(sv, &stash, &gv, FALSE);
1235 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1247 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1249 if ((cp = PL_AMG_names[0])) {
1250 /* Try to find via inheritance. */
1251 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1257 else if (SvTRUE(sv))
1258 amt.fallback=AMGfallYES;
1260 amt.fallback=AMGfallNEVER;
1263 for (i = 1; i < NofAMmeth; i++) {
1264 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1265 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1266 cp, HvNAME(stash)) );
1267 /* don't fill the cache while looking up! */
1268 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1270 if(gv && (cv = GvCV(gv))) {
1271 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1272 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1273 /* GvSV contains the name of the method. */
1276 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1277 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1278 if (!SvPOK(GvSV(gv))
1279 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1282 /* Can be an import stub (created by `can'). */
1284 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1285 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1288 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1289 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1292 cv = GvCV(gv = ngv);
1294 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1295 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1296 GvNAME(CvGV(cv))) );
1300 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1303 AMT_AMAGIC_on(&amt);
1304 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1308 /* Here we have no table: */
1310 AMT_AMAGIC_off(&amt);
1311 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1316 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1321 CV **cvp=NULL, **ocvp=NULL;
1323 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1324 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1326 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1327 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1328 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1329 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1331 && ((cv = cvp[off=method+assignshift])
1332 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1334 (fl = 1, cv = cvp[off=method])))) {
1335 lr = -1; /* Call method for left argument */
1337 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1340 /* look for substituted methods */
1341 /* In all the covered cases we should be called with assign==0. */
1345 if ((cv = cvp[off=add_ass_amg])
1346 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1347 right = &PL_sv_yes; lr = -1; assign = 1;
1352 if ((cv = cvp[off = subtr_ass_amg])
1353 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1354 right = &PL_sv_yes; lr = -1; assign = 1;
1358 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1361 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1364 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1367 (void)((cv = cvp[off=bool__amg])
1368 || (cv = cvp[off=numer_amg])
1369 || (cv = cvp[off=string_amg]));
1375 * SV* ref causes confusion with the interpreter variable of
1378 SV* tmpRef=SvRV(left);
1379 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1381 * Just to be extra cautious. Maybe in some
1382 * additional cases sv_setsv is safe, too.
1384 SV* newref = newSVsv(tmpRef);
1385 SvOBJECT_on(newref);
1386 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1392 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1393 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1394 SV* nullsv=sv_2mortal(newSViv(0));
1396 SV* lessp = amagic_call(left,nullsv,
1397 lt_amg,AMGf_noright);
1398 logic = SvTRUE(lessp);
1400 SV* lessp = amagic_call(left,nullsv,
1401 ncmp_amg,AMGf_noright);
1402 logic = (SvNV(lessp) < 0);
1405 if (off==subtr_amg) {
1416 if ((cv = cvp[off=subtr_amg])) {
1418 left = sv_2mortal(newSViv(0));
1422 case iter_amg: /* XXXX Eventually should do to_gv. */
1424 return NULL; /* Delegate operation to standard mechanisms. */
1432 return left; /* Delegate operation to standard mechanisms. */
1437 if (!cv) goto not_found;
1438 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1439 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1440 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1441 ? (amtp = (AMT*)mg->mg_ptr)->table
1443 && (cv = cvp[off=method])) { /* Method for right
1446 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1447 && (cvp=ocvp) && (lr = -1))
1448 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1449 && !(flags & AMGf_unary)) {
1450 /* We look for substitution for
1451 * comparison operations and
1453 if (method==concat_amg || method==concat_ass_amg
1454 || method==repeat_amg || method==repeat_ass_amg) {
1455 return NULL; /* Delegate operation to string conversion */
1465 postpr = 1; off=ncmp_amg; break;
1472 postpr = 1; off=scmp_amg; break;
1474 if (off != -1) cv = cvp[off];
1479 not_found: /* No method found, either report or croak */
1487 return left; /* Delegate operation to standard mechanisms. */
1490 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1491 notfound = 1; lr = -1;
1492 } else if (cvp && (cv=cvp[nomethod_amg])) {
1493 notfound = 1; lr = 1;
1496 if (off==-1) off=method;
1497 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1498 "Operation `%s': no method found,%sargument %s%s%s%s",
1499 PL_AMG_names[method + assignshift],
1500 (flags & AMGf_unary ? " " : "\n\tleft "),
1502 "in overloaded package ":
1503 "has no overloaded magic",
1505 HvNAME(SvSTASH(SvRV(left))):
1508 ",\n\tright argument in overloaded package ":
1511 : ",\n\tright argument has no overloaded magic"),
1513 HvNAME(SvSTASH(SvRV(right))):
1515 if (amtp && amtp->fallback >= AMGfallYES) {
1516 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1518 Perl_croak(aTHX_ "%"SVf, msg);
1522 force_cpy = force_cpy || assign;
1526 DEBUG_o( Perl_deb(aTHX_
1527 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1529 method+assignshift==off? "" :
1531 method+assignshift==off? "" :
1532 PL_AMG_names[method+assignshift],
1533 method+assignshift==off? "" : "')",
1534 flags & AMGf_unary? "" :
1535 lr==1 ? " for right argument": " for left argument",
1536 flags & AMGf_unary? " for argument" : "",
1538 fl? ",\n\tassignment variant used": "") );
1540 /* Since we use shallow copy during assignment, we need
1541 * to dublicate the contents, probably calling user-supplied
1542 * version of copy operator
1544 /* We need to copy in following cases:
1545 * a) Assignment form was called.
1546 * assignshift==1, assign==T, method + 1 == off
1547 * b) Increment or decrement, called directly.
1548 * assignshift==0, assign==0, method + 0 == off
1549 * c) Increment or decrement, translated to assignment add/subtr.
1550 * assignshift==0, assign==T,
1552 * d) Increment or decrement, translated to nomethod.
1553 * assignshift==0, assign==0,
1555 * e) Assignment form translated to nomethod.
1556 * assignshift==1, assign==T, method + 1 != off
1559 /* off is method, method+assignshift, or a result of opcode substitution.
1560 * In the latter case assignshift==0, so only notfound case is important.
1562 if (( (method + assignshift == off)
1563 && (assign || (method == inc_amg) || (method == dec_amg)))
1570 bool oldcatch = CATCH_GET;
1573 Zero(&myop, 1, BINOP);
1574 myop.op_last = (OP *) &myop;
1575 myop.op_next = Nullop;
1576 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1578 PUSHSTACKi(PERLSI_OVERLOAD);
1581 PL_op = (OP *) &myop;
1582 if (PERLDB_SUB && PL_curstash != PL_debstash)
1583 PL_op->op_private |= OPpENTERSUB_DB;
1587 EXTEND(SP, notfound + 5);
1588 PUSHs(lr>0? right: left);
1589 PUSHs(lr>0? left: right);
1590 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1592 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1597 if ((PL_op = Perl_pp_entersub(aTHX)))
1605 CATCH_SET(oldcatch);
1612 ans=SvIV(res)<=0; break;
1615 ans=SvIV(res)<0; break;
1618 ans=SvIV(res)>=0; break;
1621 ans=SvIV(res)>0; break;
1624 ans=SvIV(res)==0; break;
1627 ans=SvIV(res)!=0; break;
1630 SvSetSV(left,res); return left;
1632 ans=!SvTRUE(res); break;
1635 } else if (method==copy_amg) {
1637 Perl_croak(aTHX_ "Copy method did not return a reference");
1639 return SvREFCNT_inc(SvRV(res));
1647 =for apidoc is_gv_magical
1649 Returns C<TRUE> if given the name of a magical GV.
1651 Currently only useful internally when determining if a GV should be
1652 created even in rvalue contexts.
1654 C<flags> is not used at present but available for future extension to
1655 allow selecting particular classes of magical variable.
1660 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1667 if (len == 3 && strEQ(name, "ISA"))
1671 if (len == 8 && strEQ(name, "OVERLOAD"))
1675 if (len == 3 && strEQ(name, "SIG"))
1678 case '\017': /* $^O & $^OPEN */
1680 || (len == 4 && strEQ(name, "\027PEN")))
1685 case '\027': /* $^W & $^WARNING_BITS */
1687 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1688 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1720 case '\001': /* $^A */
1721 case '\003': /* $^C */
1722 case '\004': /* $^D */
1723 case '\005': /* $^E */
1724 case '\006': /* $^F */
1725 case '\010': /* $^H */
1726 case '\011': /* $^I, NOT \t in EBCDIC */
1727 case '\014': /* $^L */
1728 case '\020': /* $^P */
1729 case '\023': /* $^S */
1730 case '\024': /* $^T */
1731 case '\026': /* $^V */
1745 char *end = name + len;
1746 while (--end > name) {