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);
843 case '\001': /* $^A */
844 case '\003': /* $^C */
845 case '\004': /* $^D */
846 case '\005': /* $^E */
847 case '\006': /* $^F */
848 case '\010': /* $^H */
849 case '\011': /* $^I, NOT \t in EBCDIC */
850 case '\020': /* $^P */
851 case '\024': /* $^T */
858 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
860 case '\017': /* $^O & $^OPEN */
861 if (len > 1 && strNE(name, "\017PEN"))
864 case '\023': /* $^S */
868 case '\027': /* $^W & $^WARNING_BITS */
869 if (len > 1 && strNE(name, "\027ARNING_BITS")
870 && strNE(name, "\027IDE_SYSTEM_CALLS"))
879 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
893 SvREADONLY_on(GvSV(gv));
895 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
898 case '\014': /* $^L */
901 sv_setpv(GvSV(gv),"\f");
902 PL_formfeed = GvSV(gv);
907 sv_setpv(GvSV(gv),"\034");
912 (void)SvUPGRADE(sv, SVt_PVNV);
913 Perl_sv_setpvf(aTHX_ sv,
914 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
920 SvNVX(PL_patchlevel));
921 SvNVX(sv) = SvNVX(PL_patchlevel);
926 case '\026': /* $^V */
929 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
938 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
940 HV *hv = GvSTASH(gv);
945 sv_setpv(sv, prefix ? prefix : "");
946 if (keepmain || strNE(HvNAME(hv), "main")) {
947 sv_catpv(sv,HvNAME(hv));
948 sv_catpvn(sv,"::", 2);
950 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
954 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
956 HV *hv = GvSTASH(gv);
961 sv_setpv(sv, prefix ? prefix : "");
962 sv_catpv(sv,HvNAME(hv));
963 sv_catpvn(sv,"::", 2);
964 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
968 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
973 gv_fullname4(sv, egv, prefix, keepmain);
977 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
982 gv_fullname3(sv, egv, prefix);
985 /* XXX compatibility with versions <= 5.003. */
987 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
989 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
992 /* XXX compatibility with versions <= 5.003. */
994 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
996 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1006 io = (IO*)NEWSV(0,0);
1007 sv_upgrade((SV *)io,SVt_PVIO);
1010 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1011 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1012 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1013 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1014 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1019 Perl_gv_check(pTHX_ HV *stash)
1027 if (!HvARRAY(stash))
1029 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1030 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1031 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1032 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1034 if (hv != PL_defstash && hv != stash)
1035 gv_check(hv); /* nested package */
1037 else if (isALPHA(*HeKEY(entry))) {
1039 gv = (GV*)HeVAL(entry);
1040 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1043 /* performance hack: if filename is absolute and it's a standard
1044 * module, don't bother warning */
1046 && PERL_FILE_IS_ABSOLUTE(file)
1047 && (instr(file, "/lib/") || instr(file, ".pm")))
1051 CopLINE_set(PL_curcop, GvLINE(gv));
1053 CopFILE(PL_curcop) = file; /* set for warning */
1055 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1057 Perl_warner(aTHX_ WARN_ONCE,
1058 "Name \"%s::%s\" used only once: possible typo",
1059 HvNAME(stash), GvNAME(gv));
1066 Perl_newGVgen(pTHX_ char *pack)
1068 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1072 /* hopefully this is only called on local symbol table entries */
1075 Perl_gp_ref(pTHX_ GP *gp)
1082 /* multi-named GPs cannot be used for method cache */
1083 SvREFCNT_dec(gp->gp_cv);
1088 /* Adding a new name to a subroutine invalidates method cache */
1089 PL_sub_generation++;
1096 Perl_gp_free(pTHX_ GV *gv)
1101 if (!gv || !(gp = GvGP(gv)))
1103 if (gp->gp_refcnt == 0) {
1104 if (ckWARN_d(WARN_INTERNAL))
1105 Perl_warner(aTHX_ WARN_INTERNAL,
1106 "Attempt to free unreferenced glob pointers");
1110 /* Deleting the name of a subroutine invalidates method cache */
1111 PL_sub_generation++;
1113 if (--gp->gp_refcnt > 0) {
1114 if (gp->gp_egv == gv)
1119 SvREFCNT_dec(gp->gp_sv);
1120 SvREFCNT_dec(gp->gp_av);
1121 SvREFCNT_dec(gp->gp_hv);
1122 SvREFCNT_dec(gp->gp_io);
1123 SvREFCNT_dec(gp->gp_cv);
1124 SvREFCNT_dec(gp->gp_form);
1130 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1134 #ifdef MICROPORT /* Microport 2.4 hack */
1138 if (GvGP(gv)->gp_av)
1139 return GvGP(gv)->gp_av;
1141 return GvGP(gv_AVadd(gv))->gp_av;
1147 if (GvGP(gv)->gp_hv)
1148 return GvGP(gv)->gp_hv;
1150 return GvGP(gv_HVadd(gv))->gp_hv;
1152 #endif /* Microport 2.4 hack */
1154 /* Updates and caches the CV's */
1157 Perl_Gv_AMupdate(pTHX_ HV *stash)
1162 MAGIC* mg=mg_find((SV*)stash,'c');
1163 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1166 #ifdef OVERLOAD_VIA_HASH
1171 if (mg && amtp->was_ok_am == PL_amagic_generation
1172 && amtp->was_ok_sub == PL_sub_generation)
1173 return AMT_AMAGIC(amtp);
1174 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1176 for (i=1; i<NofAMmeth; i++) {
1177 if (amtp->table[i]) {
1178 SvREFCNT_dec(amtp->table[i]);
1182 sv_unmagic((SV*)stash, 'c');
1184 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1186 amt.was_ok_am = PL_amagic_generation;
1187 amt.was_ok_sub = PL_sub_generation;
1188 amt.fallback = AMGfallNO;
1191 #ifdef OVERLOAD_VIA_HASH
1192 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1193 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1200 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1202 if (( cp = (char *)PL_AMG_names[0] ) &&
1203 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1204 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1205 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1207 for (i = 1; i < NofAMmeth; i++) {
1209 cp = (char *)PL_AMG_names[i];
1211 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1212 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1213 switch (SvTYPE(sv)) {
1216 if (!SvOK(sv)) break;
1217 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1218 if (gv) cv = GvCV(gv);
1222 if (SvTYPE(cv) == SVt_PVCV)
1227 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1233 if (!(cv = GvCVu((GV*)sv)))
1234 cv = sv_2cv(sv, &stash, &gv, FALSE);
1239 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1251 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1253 if ((cp = PL_AMG_names[0])) {
1254 /* Try to find via inheritance. */
1255 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1261 else if (SvTRUE(sv))
1262 amt.fallback=AMGfallYES;
1264 amt.fallback=AMGfallNEVER;
1267 for (i = 1; i < NofAMmeth; i++) {
1268 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1269 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1270 cp, HvNAME(stash)) );
1271 /* don't fill the cache while looking up! */
1272 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1274 if(gv && (cv = GvCV(gv))) {
1275 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1276 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1277 /* GvSV contains the name of the method. */
1280 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1281 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1282 if (!SvPOK(GvSV(gv))
1283 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1286 /* Can be an import stub (created by `can'). */
1288 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1289 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1292 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1293 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1296 cv = GvCV(gv = ngv);
1298 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1299 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1300 GvNAME(CvGV(cv))) );
1304 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1307 AMT_AMAGIC_on(&amt);
1308 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1312 /* Here we have no table: */
1314 AMT_AMAGIC_off(&amt);
1315 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1320 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1325 CV **cvp=NULL, **ocvp=NULL;
1327 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1328 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1330 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1331 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1332 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1333 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1335 && ((cv = cvp[off=method+assignshift])
1336 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1338 (fl = 1, cv = cvp[off=method])))) {
1339 lr = -1; /* Call method for left argument */
1341 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1344 /* look for substituted methods */
1345 /* In all the covered cases we should be called with assign==0. */
1349 if ((cv = cvp[off=add_ass_amg])
1350 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1351 right = &PL_sv_yes; lr = -1; assign = 1;
1356 if ((cv = cvp[off = subtr_ass_amg])
1357 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1358 right = &PL_sv_yes; lr = -1; assign = 1;
1362 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1365 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1368 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1371 (void)((cv = cvp[off=bool__amg])
1372 || (cv = cvp[off=numer_amg])
1373 || (cv = cvp[off=string_amg]));
1379 * SV* ref causes confusion with the interpreter variable of
1382 SV* tmpRef=SvRV(left);
1383 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1385 * Just to be extra cautious. Maybe in some
1386 * additional cases sv_setsv is safe, too.
1388 SV* newref = newSVsv(tmpRef);
1389 SvOBJECT_on(newref);
1390 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1396 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1397 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1398 SV* nullsv=sv_2mortal(newSViv(0));
1400 SV* lessp = amagic_call(left,nullsv,
1401 lt_amg,AMGf_noright);
1402 logic = SvTRUE(lessp);
1404 SV* lessp = amagic_call(left,nullsv,
1405 ncmp_amg,AMGf_noright);
1406 logic = (SvNV(lessp) < 0);
1409 if (off==subtr_amg) {
1420 if ((cv = cvp[off=subtr_amg])) {
1422 left = sv_2mortal(newSViv(0));
1426 case iter_amg: /* XXXX Eventually should do to_gv. */
1428 return NULL; /* Delegate operation to standard mechanisms. */
1436 return left; /* Delegate operation to standard mechanisms. */
1441 if (!cv) goto not_found;
1442 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1443 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1444 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1445 ? (amtp = (AMT*)mg->mg_ptr)->table
1447 && (cv = cvp[off=method])) { /* Method for right
1450 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1451 && (cvp=ocvp) && (lr = -1))
1452 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1453 && !(flags & AMGf_unary)) {
1454 /* We look for substitution for
1455 * comparison operations and
1457 if (method==concat_amg || method==concat_ass_amg
1458 || method==repeat_amg || method==repeat_ass_amg) {
1459 return NULL; /* Delegate operation to string conversion */
1469 postpr = 1; off=ncmp_amg; break;
1476 postpr = 1; off=scmp_amg; break;
1478 if (off != -1) cv = cvp[off];
1483 not_found: /* No method found, either report or croak */
1491 return left; /* Delegate operation to standard mechanisms. */
1494 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1495 notfound = 1; lr = -1;
1496 } else if (cvp && (cv=cvp[nomethod_amg])) {
1497 notfound = 1; lr = 1;
1500 if (off==-1) off=method;
1501 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1502 "Operation `%s': no method found,%sargument %s%s%s%s",
1503 PL_AMG_names[method + assignshift],
1504 (flags & AMGf_unary ? " " : "\n\tleft "),
1506 "in overloaded package ":
1507 "has no overloaded magic",
1509 HvNAME(SvSTASH(SvRV(left))):
1512 ",\n\tright argument in overloaded package ":
1515 : ",\n\tright argument has no overloaded magic"),
1517 HvNAME(SvSTASH(SvRV(right))):
1519 if (amtp && amtp->fallback >= AMGfallYES) {
1520 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1522 Perl_croak(aTHX_ "%"SVf, msg);
1526 force_cpy = force_cpy || assign;
1530 DEBUG_o( Perl_deb(aTHX_
1531 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1533 method+assignshift==off? "" :
1535 method+assignshift==off? "" :
1536 PL_AMG_names[method+assignshift],
1537 method+assignshift==off? "" : "')",
1538 flags & AMGf_unary? "" :
1539 lr==1 ? " for right argument": " for left argument",
1540 flags & AMGf_unary? " for argument" : "",
1542 fl? ",\n\tassignment variant used": "") );
1544 /* Since we use shallow copy during assignment, we need
1545 * to dublicate the contents, probably calling user-supplied
1546 * version of copy operator
1548 /* We need to copy in following cases:
1549 * a) Assignment form was called.
1550 * assignshift==1, assign==T, method + 1 == off
1551 * b) Increment or decrement, called directly.
1552 * assignshift==0, assign==0, method + 0 == off
1553 * c) Increment or decrement, translated to assignment add/subtr.
1554 * assignshift==0, assign==T,
1556 * d) Increment or decrement, translated to nomethod.
1557 * assignshift==0, assign==0,
1559 * e) Assignment form translated to nomethod.
1560 * assignshift==1, assign==T, method + 1 != off
1563 /* off is method, method+assignshift, or a result of opcode substitution.
1564 * In the latter case assignshift==0, so only notfound case is important.
1566 if (( (method + assignshift == off)
1567 && (assign || (method == inc_amg) || (method == dec_amg)))
1574 bool oldcatch = CATCH_GET;
1577 Zero(&myop, 1, BINOP);
1578 myop.op_last = (OP *) &myop;
1579 myop.op_next = Nullop;
1580 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1582 PUSHSTACKi(PERLSI_OVERLOAD);
1585 PL_op = (OP *) &myop;
1586 if (PERLDB_SUB && PL_curstash != PL_debstash)
1587 PL_op->op_private |= OPpENTERSUB_DB;
1591 EXTEND(SP, notfound + 5);
1592 PUSHs(lr>0? right: left);
1593 PUSHs(lr>0? left: right);
1594 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1596 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1601 if ((PL_op = Perl_pp_entersub(aTHX)))
1609 CATCH_SET(oldcatch);
1616 ans=SvIV(res)<=0; break;
1619 ans=SvIV(res)<0; break;
1622 ans=SvIV(res)>=0; break;
1625 ans=SvIV(res)>0; break;
1628 ans=SvIV(res)==0; break;
1631 ans=SvIV(res)!=0; break;
1634 SvSetSV(left,res); return left;
1636 ans=!SvTRUE(res); break;
1639 } else if (method==copy_amg) {
1641 Perl_croak(aTHX_ "Copy method did not return a reference");
1643 return SvREFCNT_inc(SvRV(res));
1651 =for apidoc is_gv_magical
1653 Returns C<TRUE> if given the name of a magical GV.
1655 Currently only useful internally when determining if a GV should be
1656 created even in rvalue contexts.
1658 C<flags> is not used at present but available for future extension to
1659 allow selecting particular classes of magical variable.
1664 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1671 if (len == 3 && strEQ(name, "ISA"))
1675 if (len == 8 && strEQ(name, "OVERLOAD"))
1679 if (len == 3 && strEQ(name, "SIG"))
1682 case '\017': /* $^O & $^OPEN */
1684 || (len == 4 && strEQ(name, "\027PEN")))
1689 case '\027': /* $^W & $^WARNING_BITS */
1691 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1692 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1724 case '\001': /* $^A */
1725 case '\003': /* $^C */
1726 case '\004': /* $^D */
1727 case '\005': /* $^E */
1728 case '\006': /* $^F */
1729 case '\010': /* $^H */
1730 case '\011': /* $^I, NOT \t in EBCDIC */
1731 case '\014': /* $^L */
1732 case '\020': /* $^P */
1733 case '\023': /* $^S */
1734 case '\024': /* $^T */
1735 case '\026': /* $^V */
1749 char *end = name + len;
1750 while (--end > name) {