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 '\017': /* $^O */
852 case '\020': /* $^P */
853 case '\024': /* $^T */
857 case '\023': /* $^S */
861 case '\027': /* $^W & $^WARNING_BITS */
862 if (len > 1 && strNE(name, "\027ARNING_BITS")
863 && strNE(name, "\027IDE_SYSTEM_CALLS"))
872 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
886 SvREADONLY_on(GvSV(gv));
888 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
891 case '\014': /* $^L */
894 sv_setpv(GvSV(gv),"\f");
895 PL_formfeed = GvSV(gv);
900 sv_setpv(GvSV(gv),"\034");
905 (void)SvUPGRADE(sv, SVt_PVNV);
906 Perl_sv_setpvf(aTHX_ sv,
907 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
913 SvNVX(PL_patchlevel));
914 SvNVX(sv) = SvNVX(PL_patchlevel);
919 case '\026': /* $^V */
922 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
931 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
933 HV *hv = GvSTASH(gv);
938 sv_setpv(sv, prefix ? prefix : "");
939 if (keepmain || strNE(HvNAME(hv), "main")) {
940 sv_catpv(sv,HvNAME(hv));
941 sv_catpvn(sv,"::", 2);
943 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
947 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
949 HV *hv = GvSTASH(gv);
954 sv_setpv(sv, prefix ? prefix : "");
955 sv_catpv(sv,HvNAME(hv));
956 sv_catpvn(sv,"::", 2);
957 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
961 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
966 gv_fullname4(sv, egv, prefix, keepmain);
970 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
975 gv_fullname3(sv, egv, prefix);
978 /* XXX compatibility with versions <= 5.003. */
980 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
982 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
985 /* XXX compatibility with versions <= 5.003. */
987 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
989 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
999 io = (IO*)NEWSV(0,0);
1000 sv_upgrade((SV *)io,SVt_PVIO);
1003 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1004 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1005 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1006 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1007 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1012 Perl_gv_check(pTHX_ HV *stash)
1020 if (!HvARRAY(stash))
1022 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1023 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1024 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1025 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1027 if (hv != PL_defstash && hv != stash)
1028 gv_check(hv); /* nested package */
1030 else if (isALPHA(*HeKEY(entry))) {
1032 gv = (GV*)HeVAL(entry);
1033 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1036 /* performance hack: if filename is absolute and it's a standard
1037 * module, don't bother warning */
1039 && PERL_FILE_IS_ABSOLUTE(file)
1040 && (instr(file, "/lib/") || instr(file, ".pm")))
1044 CopLINE_set(PL_curcop, GvLINE(gv));
1046 CopFILE(PL_curcop) = file; /* set for warning */
1048 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1050 Perl_warner(aTHX_ WARN_ONCE,
1051 "Name \"%s::%s\" used only once: possible typo",
1052 HvNAME(stash), GvNAME(gv));
1059 Perl_newGVgen(pTHX_ char *pack)
1061 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1065 /* hopefully this is only called on local symbol table entries */
1068 Perl_gp_ref(pTHX_ GP *gp)
1075 /* multi-named GPs cannot be used for method cache */
1076 SvREFCNT_dec(gp->gp_cv);
1081 /* Adding a new name to a subroutine invalidates method cache */
1082 PL_sub_generation++;
1089 Perl_gp_free(pTHX_ GV *gv)
1094 if (!gv || !(gp = GvGP(gv)))
1096 if (gp->gp_refcnt == 0) {
1097 if (ckWARN_d(WARN_INTERNAL))
1098 Perl_warner(aTHX_ WARN_INTERNAL,
1099 "Attempt to free unreferenced glob pointers");
1103 /* Deleting the name of a subroutine invalidates method cache */
1104 PL_sub_generation++;
1106 if (--gp->gp_refcnt > 0) {
1107 if (gp->gp_egv == gv)
1112 SvREFCNT_dec(gp->gp_sv);
1113 SvREFCNT_dec(gp->gp_av);
1114 SvREFCNT_dec(gp->gp_hv);
1115 SvREFCNT_dec(gp->gp_io);
1116 SvREFCNT_dec(gp->gp_cv);
1117 SvREFCNT_dec(gp->gp_form);
1123 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1127 #ifdef MICROPORT /* Microport 2.4 hack */
1131 if (GvGP(gv)->gp_av)
1132 return GvGP(gv)->gp_av;
1134 return GvGP(gv_AVadd(gv))->gp_av;
1140 if (GvGP(gv)->gp_hv)
1141 return GvGP(gv)->gp_hv;
1143 return GvGP(gv_HVadd(gv))->gp_hv;
1145 #endif /* Microport 2.4 hack */
1147 /* Updates and caches the CV's */
1150 Perl_Gv_AMupdate(pTHX_ HV *stash)
1155 MAGIC* mg=mg_find((SV*)stash,'c');
1156 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1159 #ifdef OVERLOAD_VIA_HASH
1164 if (mg && amtp->was_ok_am == PL_amagic_generation
1165 && amtp->was_ok_sub == PL_sub_generation)
1166 return AMT_AMAGIC(amtp);
1167 if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
1169 for (i=1; i<NofAMmeth; i++) {
1170 if (amtp->table[i]) {
1171 SvREFCNT_dec(amtp->table[i]);
1175 sv_unmagic((SV*)stash, 'c');
1177 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1179 amt.was_ok_am = PL_amagic_generation;
1180 amt.was_ok_sub = PL_sub_generation;
1181 amt.fallback = AMGfallNO;
1184 #ifdef OVERLOAD_VIA_HASH
1185 gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1186 if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1193 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1195 if (( cp = (char *)PL_AMG_names[0] ) &&
1196 (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1197 if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1198 else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1200 for (i = 1; i < NofAMmeth; i++) {
1202 cp = (char *)PL_AMG_names[i];
1204 svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1205 if (svp && ((sv = *svp) != &PL_sv_undef)) {
1206 switch (SvTYPE(sv)) {
1209 if (!SvOK(sv)) break;
1210 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1211 if (gv) cv = GvCV(gv);
1215 if (SvTYPE(cv) == SVt_PVCV)
1220 Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1226 if (!(cv = GvCVu((GV*)sv)))
1227 cv = sv_2cv(sv, &stash, &gv, FALSE);
1232 Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1244 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1246 if ((cp = PL_AMG_names[0])) {
1247 /* Try to find via inheritance. */
1248 gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1254 else if (SvTRUE(sv))
1255 amt.fallback=AMGfallYES;
1257 amt.fallback=AMGfallNEVER;
1260 for (i = 1; i < NofAMmeth; i++) {
1261 SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1262 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1263 cp, HvNAME(stash)) );
1264 /* don't fill the cache while looking up! */
1265 gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1267 if(gv && (cv = GvCV(gv))) {
1268 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1269 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1270 /* GvSV contains the name of the method. */
1273 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1274 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1275 if (!SvPOK(GvSV(gv))
1276 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1279 /* Can be an import stub (created by `can'). */
1281 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1282 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1285 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1286 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1289 cv = GvCV(gv = ngv);
1291 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1292 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1293 GvNAME(CvGV(cv))) );
1297 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1300 AMT_AMAGIC_on(&amt);
1301 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1305 /* Here we have no table: */
1307 AMT_AMAGIC_off(&amt);
1308 sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1313 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1318 CV **cvp=NULL, **ocvp=NULL;
1320 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1321 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1323 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1324 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1325 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1326 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1328 && ((cv = cvp[off=method+assignshift])
1329 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1331 (fl = 1, cv = cvp[off=method])))) {
1332 lr = -1; /* Call method for left argument */
1334 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1337 /* look for substituted methods */
1338 /* In all the covered cases we should be called with assign==0. */
1342 if ((cv = cvp[off=add_ass_amg])
1343 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1344 right = &PL_sv_yes; lr = -1; assign = 1;
1349 if ((cv = cvp[off = subtr_ass_amg])
1350 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1351 right = &PL_sv_yes; lr = -1; assign = 1;
1355 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1358 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1361 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1364 (void)((cv = cvp[off=bool__amg])
1365 || (cv = cvp[off=numer_amg])
1366 || (cv = cvp[off=string_amg]));
1372 * SV* ref causes confusion with the interpreter variable of
1375 SV* tmpRef=SvRV(left);
1376 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1378 * Just to be extra cautious. Maybe in some
1379 * additional cases sv_setsv is safe, too.
1381 SV* newref = newSVsv(tmpRef);
1382 SvOBJECT_on(newref);
1383 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1389 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1390 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1391 SV* nullsv=sv_2mortal(newSViv(0));
1393 SV* lessp = amagic_call(left,nullsv,
1394 lt_amg,AMGf_noright);
1395 logic = SvTRUE(lessp);
1397 SV* lessp = amagic_call(left,nullsv,
1398 ncmp_amg,AMGf_noright);
1399 logic = (SvNV(lessp) < 0);
1402 if (off==subtr_amg) {
1413 if ((cv = cvp[off=subtr_amg])) {
1415 left = sv_2mortal(newSViv(0));
1419 case iter_amg: /* XXXX Eventually should do to_gv. */
1421 return NULL; /* Delegate operation to standard mechanisms. */
1429 return left; /* Delegate operation to standard mechanisms. */
1434 if (!cv) goto not_found;
1435 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1436 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1437 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1438 ? (amtp = (AMT*)mg->mg_ptr)->table
1440 && (cv = cvp[off=method])) { /* Method for right
1443 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1444 && (cvp=ocvp) && (lr = -1))
1445 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1446 && !(flags & AMGf_unary)) {
1447 /* We look for substitution for
1448 * comparison operations and
1450 if (method==concat_amg || method==concat_ass_amg
1451 || method==repeat_amg || method==repeat_ass_amg) {
1452 return NULL; /* Delegate operation to string conversion */
1462 postpr = 1; off=ncmp_amg; break;
1469 postpr = 1; off=scmp_amg; break;
1471 if (off != -1) cv = cvp[off];
1476 not_found: /* No method found, either report or croak */
1484 return left; /* Delegate operation to standard mechanisms. */
1487 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1488 notfound = 1; lr = -1;
1489 } else if (cvp && (cv=cvp[nomethod_amg])) {
1490 notfound = 1; lr = 1;
1493 if (off==-1) off=method;
1494 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1495 "Operation `%s': no method found,%sargument %s%s%s%s",
1496 PL_AMG_names[method + assignshift],
1497 (flags & AMGf_unary ? " " : "\n\tleft "),
1499 "in overloaded package ":
1500 "has no overloaded magic",
1502 HvNAME(SvSTASH(SvRV(left))):
1505 ",\n\tright argument in overloaded package ":
1508 : ",\n\tright argument has no overloaded magic"),
1510 HvNAME(SvSTASH(SvRV(right))):
1512 if (amtp && amtp->fallback >= AMGfallYES) {
1513 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1515 Perl_croak(aTHX_ "%"SVf, msg);
1519 force_cpy = force_cpy || assign;
1523 DEBUG_o( Perl_deb(aTHX_
1524 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1526 method+assignshift==off? "" :
1528 method+assignshift==off? "" :
1529 PL_AMG_names[method+assignshift],
1530 method+assignshift==off? "" : "')",
1531 flags & AMGf_unary? "" :
1532 lr==1 ? " for right argument": " for left argument",
1533 flags & AMGf_unary? " for argument" : "",
1535 fl? ",\n\tassignment variant used": "") );
1537 /* Since we use shallow copy during assignment, we need
1538 * to dublicate the contents, probably calling user-supplied
1539 * version of copy operator
1541 /* We need to copy in following cases:
1542 * a) Assignment form was called.
1543 * assignshift==1, assign==T, method + 1 == off
1544 * b) Increment or decrement, called directly.
1545 * assignshift==0, assign==0, method + 0 == off
1546 * c) Increment or decrement, translated to assignment add/subtr.
1547 * assignshift==0, assign==T,
1549 * d) Increment or decrement, translated to nomethod.
1550 * assignshift==0, assign==0,
1552 * e) Assignment form translated to nomethod.
1553 * assignshift==1, assign==T, method + 1 != off
1556 /* off is method, method+assignshift, or a result of opcode substitution.
1557 * In the latter case assignshift==0, so only notfound case is important.
1559 if (( (method + assignshift == off)
1560 && (assign || (method == inc_amg) || (method == dec_amg)))
1567 bool oldcatch = CATCH_GET;
1570 Zero(&myop, 1, BINOP);
1571 myop.op_last = (OP *) &myop;
1572 myop.op_next = Nullop;
1573 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1575 PUSHSTACKi(PERLSI_OVERLOAD);
1578 PL_op = (OP *) &myop;
1579 if (PERLDB_SUB && PL_curstash != PL_debstash)
1580 PL_op->op_private |= OPpENTERSUB_DB;
1584 EXTEND(SP, notfound + 5);
1585 PUSHs(lr>0? right: left);
1586 PUSHs(lr>0? left: right);
1587 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1589 PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1594 if ((PL_op = Perl_pp_entersub(aTHX)))
1602 CATCH_SET(oldcatch);
1609 ans=SvIV(res)<=0; break;
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 SvSetSV(left,res); return left;
1629 ans=!SvTRUE(res); break;
1632 } else if (method==copy_amg) {
1634 Perl_croak(aTHX_ "Copy method did not return a reference");
1636 return SvREFCNT_inc(SvRV(res));
1644 =for apidoc is_gv_magical
1646 Returns C<TRUE> if given the name of a magical GV.
1648 Currently only useful internally when determining if a GV should be
1649 created even in rvalue contexts.
1651 C<flags> is not used at present but available for future extension to
1652 allow selecting particular classes of magical variable.
1657 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1664 if (len == 3 && strEQ(name, "ISA"))
1668 if (len == 8 && strEQ(name, "OVERLOAD"))
1672 if (len == 3 && strEQ(name, "SIG"))
1675 case '\027': /* $^W & $^WARNING_BITS */
1677 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1678 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1710 case '\001': /* $^A */
1711 case '\003': /* $^C */
1712 case '\004': /* $^D */
1713 case '\005': /* $^E */
1714 case '\006': /* $^F */
1715 case '\010': /* $^H */
1716 case '\011': /* $^I, NOT \t in EBCDIC */
1717 case '\014': /* $^L */
1718 case '\017': /* $^O */
1719 case '\020': /* $^P */
1720 case '\023': /* $^S */
1721 case '\024': /* $^T */
1722 case '\026': /* $^V */
1736 char *end = name + len;
1737 while (--end > name) {