3 * Copyright (c) 1991-2001, 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");
49 #ifdef GV_SHARED_CHECK
51 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
60 Perl_gv_fetchfile(pTHX_ const char *name)
70 tmplen = strlen(name) + 2;
71 if (tmplen < sizeof smallbuf)
74 New(603, tmpbuf, tmplen + 1, char);
77 strcpy(tmpbuf + 2, name);
78 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
80 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
81 sv_setpv(GvSV(gv), name);
83 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
85 if (tmpbuf != smallbuf)
91 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
94 bool doproto = SvTYPE(gv) > SVt_NULL;
95 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
97 sv_upgrade((SV*)gv, SVt_PVGV);
106 Newz(602, gp, 1, GP);
107 GvGP(gv) = gp_ref(gp);
108 GvSV(gv) = NEWSV(72,0);
109 GvLINE(gv) = CopLINE(PL_curcop);
110 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
113 sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
114 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
115 GvNAME(gv) = savepvn(name, len);
117 if (multi || doproto) /* doproto means it _was_ mentioned */
119 if (doproto) { /* Replicate part of newSUB here. */
122 /* XXX unsafe for threads if eval_owner isn't held */
123 start_subparse(0,0); /* Create CV in compcv. */
124 GvCV(gv) = PL_compcv;
129 CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
130 CvSTASH(GvCV(gv)) = PL_curstash;
132 CvOWNER(GvCV(gv)) = 0;
133 if (!CvMUTEXP(GvCV(gv))) {
134 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
135 MUTEX_INIT(CvMUTEXP(GvCV(gv)));
137 #endif /* USE_THREADS */
139 sv_setpv((SV*)GvCV(gv), proto);
146 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
162 =for apidoc gv_fetchmeth
164 Returns the glob with the given C<name> and a defined subroutine or
165 C<NULL>. The glob lives in the given C<stash>, or in the stashes
166 accessible via @ISA and @UNIVERSAL.
168 The argument C<level> should be either 0 or -1. If C<level==0>, as a
169 side-effect creates a glob with the given C<name> in the given C<stash>
170 which in the case of success contains an alias for the subroutine, and sets
171 up caching info for this glob. Similarly for all the searched stashes.
173 This function grants C<"SUPER"> token as a postfix of the stash name. The
174 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
175 visible to Perl code. So when calling C<call_sv>, you should not use
176 the GV directly; instead, you should use the method's CV, which can be
177 obtained from the GV with the C<GvCV> macro.
183 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
193 if ((level > 100) || (level < -100))
194 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
195 name, HvNAME(stash));
197 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
199 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
204 if (SvTYPE(topgv) != SVt_PVGV)
205 gv_init(topgv, stash, name, len, TRUE);
206 if ((cv = GvCV(topgv))) {
207 /* If genuine method or valid cache entry, use it */
208 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
210 /* Stale cached entry: junk it */
212 GvCV(topgv) = cv = Nullcv;
215 else if (GvCVGEN(topgv) == PL_sub_generation)
216 return 0; /* cache indicates sub doesn't exist */
219 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
220 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
222 /* create and re-create @.*::SUPER::ISA on demand */
223 if (!av || !SvMAGIC(av)) {
224 char* packname = HvNAME(stash);
225 STRLEN packlen = strlen(packname);
227 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
231 basestash = gv_stashpvn(packname, packlen, TRUE);
232 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
233 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
234 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
235 if (!gvp || !(gv = *gvp))
236 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
237 if (SvTYPE(gv) != SVt_PVGV)
238 gv_init(gv, stash, "ISA", 3, TRUE);
239 SvREFCNT_dec(GvAV(gv));
240 GvAV(gv) = (AV*)SvREFCNT_inc(av);
246 SV** svp = AvARRAY(av);
247 /* NOTE: No support for tied ISA */
248 I32 items = AvFILLp(av) + 1;
251 HV* basestash = gv_stashsv(sv, FALSE);
253 if (ckWARN(WARN_MISC))
254 Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
255 SvPVX(sv), HvNAME(stash));
258 gv = gv_fetchmeth(basestash, name, len,
259 (level >= 0) ? level + 1 : level - 1);
265 /* if at top level, try UNIVERSAL */
267 if (level == 0 || level == -1) {
270 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
271 if ((gv = gv_fetchmeth(lastchance, name, len,
272 (level >= 0) ? level + 1 : level - 1)))
276 * Cache method in topgv if:
277 * 1. topgv has no synonyms (else inheritance crosses wires)
278 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
281 GvREFCNT(topgv) == 1 &&
283 (CvROOT(cv) || CvXSUB(cv)))
285 if ((cv = GvCV(topgv)))
287 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
288 GvCVGEN(topgv) = PL_sub_generation;
292 else if (topgv && GvREFCNT(topgv) == 1) {
293 /* cache the fact that the method is not defined */
294 GvCVGEN(topgv) = PL_sub_generation;
303 =for apidoc gv_fetchmethod
305 See L<gv_fetchmethod_autoload>.
311 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
313 return gv_fetchmethod_autoload(stash, name, TRUE);
317 =for apidoc gv_fetchmethod_autoload
319 Returns the glob which contains the subroutine to call to invoke the method
320 on the C<stash>. In fact in the presence of autoloading this may be the
321 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
324 The third parameter of C<gv_fetchmethod_autoload> determines whether
325 AUTOLOAD lookup is performed if the given method is not present: non-zero
326 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
327 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
328 with a non-zero C<autoload> parameter.
330 These functions grant C<"SUPER"> token as a prefix of the method name. Note
331 that if you want to keep the returned glob for a long time, you need to
332 check for it being "AUTOLOAD", since at the later time the call may load a
333 different subroutine due to $AUTOLOAD changing its value. Use the glob
334 created via a side effect to do this.
336 These functions have the same side-effects and as C<gv_fetchmeth> with
337 C<level==0>. C<name> should be writable if contains C<':'> or C<'
338 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
339 C<call_sv> apply equally to these functions.
345 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
347 register const char *nend;
348 const char *nsplit = 0;
351 for (nend = name; *nend; nend++) {
354 else if (*nend == ':' && *(nend + 1) == ':')
358 const char *origname = name;
362 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
363 /* ->SUPER::method should really be looked up in original stash */
364 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
365 CopSTASHPV(PL_curcop)));
366 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
367 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
368 origname, HvNAME(stash), name) );
371 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
374 gv = gv_fetchmeth(stash, name, nend - name, 0);
376 if (strEQ(name,"import") || strEQ(name,"unimport"))
377 gv = (GV*)&PL_sv_yes;
379 gv = gv_autoload4(stash, name, nend - name, TRUE);
383 if (!CvROOT(cv) && !CvXSUB(cv)) {
391 if (GvCV(stubgv) != cv) /* orphaned import */
394 autogv = gv_autoload4(GvSTASH(stubgv),
395 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
405 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)))
421 if (!(CvROOT(cv) || CvXSUB(cv)))
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);
435 /* rather than lookup/init $AUTOLOAD here
436 * only to have the XSUB do another lookup for $AUTOLOAD
437 * and split that value on the last '::',
438 * pass along the same data via some unused fields in the CV
441 SvPVX(cv) = (char *)name; /* cast to loose constness warning */
448 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
449 * The subroutine's original name may not be "AUTOLOAD", so we don't
450 * use that, but for lack of anything better we will use the sub's
451 * original package to look up $AUTOLOAD.
453 varstash = GvSTASH(CvGV(cv));
454 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
458 sv_lock((SV *)varstash);
461 gv_init(vargv, varstash, autoload, autolen, FALSE);
467 sv_setpv(varsv, HvNAME(stash));
468 sv_catpvn(varsv, "::", 2);
469 sv_catpvn(varsv, name, len);
470 SvTAINTED_off(varsv);
474 /* The "gv" parameter should be the glob known to Perl code as *!
475 * The scalar must already have been magicalized.
478 S_require_errno(pTHX_ GV *gv)
480 HV* stash = gv_stashpvn("Errno",5,FALSE);
482 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
486 save_scalar(gv); /* keep the value of $! */
487 require_pv("Errno.pm");
490 stash = gv_stashpvn("Errno",5,FALSE);
491 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
492 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
497 =for apidoc gv_stashpv
499 Returns a pointer to the stash for a specified package. C<name> should
500 be a valid UTF-8 string. If C<create> is set then the package will be
501 created if it does not already exist. If C<create> is not set and the
502 package does not exist then NULL is returned.
508 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
510 return gv_stashpvn(name, strlen(name), create);
514 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
521 if (namelen + 3 < sizeof smallbuf)
524 New(606, tmpbuf, namelen + 3, char);
525 Copy(name,tmpbuf,namelen,char);
526 tmpbuf[namelen++] = ':';
527 tmpbuf[namelen++] = ':';
528 tmpbuf[namelen] = '\0';
529 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
530 if (tmpbuf != smallbuf)
535 GvHV(tmpgv) = newHV();
538 HvNAME(stash) = savepv(name);
543 =for apidoc gv_stashsv
545 Returns a pointer to the stash for a specified package, which must be a
546 valid UTF-8 string. See C<gv_stashpv>.
552 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
557 return gv_stashpvn(ptr, len, create);
562 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
564 register const char *name = nambeg;
568 register const char *namend;
571 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
574 for (namend = name; *namend; namend++) {
575 if ((*namend == ':' && namend[1] == ':')
576 || (*namend == '\'' && namend[1]))
580 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
588 if (len + 3 < sizeof smallbuf)
591 New(601, tmpbuf, len+3, char);
592 Copy(name, tmpbuf, len, char);
596 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
597 gv = gvp ? *gvp : Nullgv;
598 if (gv && gv != (GV*)&PL_sv_undef) {
599 if (SvTYPE(gv) != SVt_PVGV)
600 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
604 if (tmpbuf != smallbuf)
606 if (!gv || gv == (GV*)&PL_sv_undef)
609 if (!(stash = GvHV(gv)))
610 stash = GvHV(gv) = newHV();
613 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
621 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
628 /* No stash in name, so see how we can default */
631 if (isIDFIRST_lazy(name)) {
634 if (isUPPER(*name)) {
635 if (*name == 'S' && (
636 strEQ(name, "SIG") ||
637 strEQ(name, "STDIN") ||
638 strEQ(name, "STDOUT") ||
639 strEQ(name, "STDERR")))
641 else if (*name == 'I' && strEQ(name, "INC"))
643 else if (*name == 'E' && strEQ(name, "ENV"))
645 else if (*name == 'A' && (
646 strEQ(name, "ARGV") ||
647 strEQ(name, "ARGVOUT")))
650 else if (*name == '_' && !name[1])
655 else if ((COP*)PL_curcop == &PL_compiling) {
657 if (add && (PL_hints & HINT_STRICT_VARS) &&
658 sv_type != SVt_PVCV &&
659 sv_type != SVt_PVGV &&
660 sv_type != SVt_PVFM &&
661 sv_type != SVt_PVIO &&
662 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
664 gvp = (GV**)hv_fetch(stash,name,len,0);
666 *gvp == (GV*)&PL_sv_undef ||
667 SvTYPE(*gvp) != SVt_PVGV)
671 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
672 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
673 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
675 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
676 sv_type == SVt_PVAV ? '@' :
677 sv_type == SVt_PVHV ? '%' : '$',
680 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
686 stash = CopSTASH(PL_curcop);
692 /* By this point we should have a stash and a name */
696 qerror(Perl_mess(aTHX_
697 "Global symbol \"%s%s\" requires explicit package name",
698 (sv_type == SVt_PV ? "$"
699 : sv_type == SVt_PVAV ? "@"
700 : sv_type == SVt_PVHV ? "%"
702 stash = PL_nullstash;
708 if (!SvREFCNT(stash)) /* symbol table under destruction */
711 gvp = (GV**)hv_fetch(stash,name,len,add);
712 if (!gvp || *gvp == (GV*)&PL_sv_undef)
715 if (SvTYPE(gv) == SVt_PVGV) {
718 gv_init_sv(gv, sv_type);
719 if (*name=='!' && sv_type == SVt_PVHV && len==1)
723 } else if (add & GV_NOINIT) {
727 /* Adding a new symbol */
729 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
730 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
731 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
732 gv_init_sv(gv, sv_type);
734 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
735 : (PL_dowarn & G_WARN_ON ) ) )
738 /* set up magic where warranted */
741 if (strEQ(name, "ARGV")) {
742 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
746 if (strnEQ(name, "EXPORT", 6))
750 if (strEQ(name, "ISA")) {
753 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
754 /* NOTE: No support for tied ISA */
755 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
756 && AvFILLp(av) == -1)
759 av_push(av, newSVpvn(pname = "NDBM_File",9));
760 gv_stashpvn(pname, 9, TRUE);
761 av_push(av, newSVpvn(pname = "DB_File",7));
762 gv_stashpvn(pname, 7, TRUE);
763 av_push(av, newSVpvn(pname = "GDBM_File",9));
764 gv_stashpvn(pname, 9, TRUE);
765 av_push(av, newSVpvn(pname = "SDBM_File",9));
766 gv_stashpvn(pname, 9, TRUE);
767 av_push(av, newSVpvn(pname = "ODBM_File",9));
768 gv_stashpvn(pname, 9, TRUE);
773 if (strEQ(name, "OVERLOAD")) {
776 hv_magic(hv, Nullgv, 'A');
780 if (strEQ(name, "SIG")) {
784 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
785 Newz(73, PL_psig_name, SIG_SIZE, SV*);
786 Newz(73, PL_psig_pend, SIG_SIZE, int);
790 hv_magic(hv, Nullgv, 'S');
791 for (i = 1; i < SIG_SIZE; i++) {
793 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
795 sv_setsv(*init, &PL_sv_undef);
803 if (strEQ(name, "VERSION"))
810 PL_sawampersand = TRUE;
816 PL_sawampersand = TRUE;
822 PL_sawampersand = TRUE;
828 sv_setpv(GvSV(gv),PL_chopset);
834 #ifdef COMPLEX_STATUS
835 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
843 /* If %! has been used, automatically load Errno.pm.
844 The require will itself set errno, so in order to
845 preserve its value we have to set up the magic
846 now (rather than going to magicalize)
849 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
851 if (sv_type == SVt_PVHV)
860 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
866 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
867 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
882 case '\001': /* $^A */
883 case '\003': /* $^C */
884 case '\004': /* $^D */
885 case '\005': /* $^E */
886 case '\006': /* $^F */
887 case '\010': /* $^H */
888 case '\011': /* $^I, NOT \t in EBCDIC */
889 case '\020': /* $^P */
890 case '\024': /* $^T */
897 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
899 case '\017': /* $^O & $^OPEN */
900 if (len > 1 && strNE(name, "\017PEN"))
903 case '\023': /* $^S */
907 case '\027': /* $^W & $^WARNING_BITS */
908 if (len > 1 && strNE(name, "\027ARNING_BITS")
909 && strNE(name, "\027IDE_SYSTEM_CALLS"))
918 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
932 SvREADONLY_on(GvSV(gv));
934 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
937 case '\014': /* $^L */
940 sv_setpv(GvSV(gv),"\f");
941 PL_formfeed = GvSV(gv);
946 sv_setpv(GvSV(gv),"\034");
951 (void)SvUPGRADE(sv, SVt_PVNV);
952 Perl_sv_setpvf(aTHX_ sv,
953 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
959 SvNVX(PL_patchlevel));
960 SvNVX(sv) = SvNVX(PL_patchlevel);
965 case '\026': /* $^V */
968 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
977 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
979 HV *hv = GvSTASH(gv);
984 sv_setpv(sv, prefix ? prefix : "");
985 if (keepmain || strNE(HvNAME(hv), "main")) {
986 sv_catpv(sv,HvNAME(hv));
987 sv_catpvn(sv,"::", 2);
989 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
993 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
995 HV *hv = GvSTASH(gv);
1000 sv_setpv(sv, prefix ? prefix : "");
1001 sv_catpv(sv,HvNAME(hv));
1002 sv_catpvn(sv,"::", 2);
1003 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1007 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1009 GV *egv = GvEGV(gv);
1012 gv_fullname4(sv, egv, prefix, keepmain);
1016 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1018 GV *egv = GvEGV(gv);
1021 gv_fullname3(sv, egv, prefix);
1024 /* XXX compatibility with versions <= 5.003. */
1026 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1028 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1031 /* XXX compatibility with versions <= 5.003. */
1033 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1035 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1044 io = (IO*)NEWSV(0,0);
1045 sv_upgrade((SV *)io,SVt_PVIO);
1048 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1049 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1050 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1051 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1052 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1057 Perl_gv_check(pTHX_ HV *stash)
1064 if (!HvARRAY(stash))
1066 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1067 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1068 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1069 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1071 if (hv != PL_defstash && hv != stash)
1072 gv_check(hv); /* nested package */
1074 else if (isALPHA(*HeKEY(entry))) {
1076 gv = (GV*)HeVAL(entry);
1077 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1080 /* performance hack: if filename is absolute and it's a standard
1081 * module, don't bother warning */
1083 && PERL_FILE_IS_ABSOLUTE(file)
1084 && (instr(file, "/lib/") || instr(file, ".pm")))
1088 CopLINE_set(PL_curcop, GvLINE(gv));
1090 CopFILE(PL_curcop) = file; /* set for warning */
1092 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1094 Perl_warner(aTHX_ WARN_ONCE,
1095 "Name \"%s::%s\" used only once: possible typo",
1096 HvNAME(stash), GvNAME(gv));
1103 Perl_newGVgen(pTHX_ char *pack)
1105 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1109 /* hopefully this is only called on local symbol table entries */
1112 Perl_gp_ref(pTHX_ GP *gp)
1119 /* multi-named GPs cannot be used for method cache */
1120 SvREFCNT_dec(gp->gp_cv);
1125 /* Adding a new name to a subroutine invalidates method cache */
1126 PL_sub_generation++;
1133 Perl_gp_free(pTHX_ GV *gv)
1137 if (!gv || !(gp = GvGP(gv)))
1139 if (gp->gp_refcnt == 0) {
1140 if (ckWARN_d(WARN_INTERNAL))
1141 Perl_warner(aTHX_ WARN_INTERNAL,
1142 "Attempt to free unreferenced glob pointers");
1146 /* Deleting the name of a subroutine invalidates method cache */
1147 PL_sub_generation++;
1149 if (--gp->gp_refcnt > 0) {
1150 if (gp->gp_egv == gv)
1155 SvREFCNT_dec(gp->gp_sv);
1156 SvREFCNT_dec(gp->gp_av);
1157 SvREFCNT_dec(gp->gp_hv);
1158 SvREFCNT_dec(gp->gp_io);
1159 SvREFCNT_dec(gp->gp_cv);
1160 SvREFCNT_dec(gp->gp_form);
1166 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1170 #ifdef MICROPORT /* Microport 2.4 hack */
1174 if (GvGP(gv)->gp_av)
1175 return GvGP(gv)->gp_av;
1177 return GvGP(gv_AVadd(gv))->gp_av;
1183 if (GvGP(gv)->gp_hv)
1184 return GvGP(gv)->gp_hv;
1186 return GvGP(gv_HVadd(gv))->gp_hv;
1188 #endif /* Microport 2.4 hack */
1191 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1193 AMT *amtp = (AMT*)mg->mg_ptr;
1194 if (amtp && AMT_AMAGIC(amtp)) {
1196 for (i = 1; i < NofAMmeth; i++) {
1197 CV *cv = amtp->table[i];
1199 SvREFCNT_dec((SV *) cv);
1200 amtp->table[i] = Nullcv;
1207 /* Updates and caches the CV's */
1210 Perl_Gv_AMupdate(pTHX_ HV *stash)
1214 MAGIC* mg=mg_find((SV*)stash,'c');
1215 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1219 if (mg && amtp->was_ok_am == PL_amagic_generation
1220 && amtp->was_ok_sub == PL_sub_generation)
1221 return AMT_OVERLOADED(amtp);
1222 sv_unmagic((SV*)stash, 'c');
1224 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1227 amt.was_ok_am = PL_amagic_generation;
1228 amt.was_ok_sub = PL_sub_generation;
1229 amt.fallback = AMGfallNO;
1233 int filled = 0, have_ovl = 0;
1237 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1239 /* Try to find via inheritance. */
1240 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1245 lim = DESTROY_amg; /* Skip overloading entries. */
1246 else if (SvTRUE(sv))
1247 amt.fallback=AMGfallYES;
1249 amt.fallback=AMGfallNEVER;
1251 for (i = 1; i < lim; i++)
1252 amt.table[i] = Nullcv;
1253 for (; i < NofAMmeth; i++) {
1254 char *cooky = (char*)PL_AMG_names[i];
1255 /* Human-readable form, for debugging: */
1256 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1257 STRLEN l = strlen(cooky);
1259 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1260 cp, HvNAME(stash)) );
1261 /* don't fill the cache while looking up! */
1262 gv = gv_fetchmeth(stash, cooky, l, -1);
1264 if (gv && (cv = GvCV(gv))) {
1265 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1266 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1267 /* GvSV contains the name of the method. */
1270 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1271 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1272 if (!SvPOK(GvSV(gv))
1273 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1276 /* Can be an import stub (created by `can'). */
1278 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1279 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1282 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1283 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1286 cv = GvCV(gv = ngv);
1288 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1289 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1290 GvNAME(CvGV(cv))) );
1292 if (i < DESTROY_amg)
1295 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1298 AMT_AMAGIC_on(&amt);
1300 AMT_OVERLOADED_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));
1314 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1321 mg = mg_find((SV*)stash,'c');
1325 mg = mg_find((SV*)stash,'c');
1327 amtp = (AMT*)mg->mg_ptr;
1328 if ( amtp->was_ok_am != PL_amagic_generation
1329 || amtp->was_ok_sub != PL_sub_generation )
1331 if (AMT_AMAGIC(amtp))
1332 return amtp->table[id];
1338 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1342 CV **cvp=NULL, **ocvp=NULL;
1344 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1345 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1347 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1348 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1349 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1350 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1352 && ((cv = cvp[off=method+assignshift])
1353 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1355 (fl = 1, cv = cvp[off=method])))) {
1356 lr = -1; /* Call method for left argument */
1358 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1361 /* look for substituted methods */
1362 /* In all the covered cases we should be called with assign==0. */
1366 if ((cv = cvp[off=add_ass_amg])
1367 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1368 right = &PL_sv_yes; lr = -1; assign = 1;
1373 if ((cv = cvp[off = subtr_ass_amg])
1374 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1375 right = &PL_sv_yes; lr = -1; assign = 1;
1379 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1382 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1385 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1388 (void)((cv = cvp[off=bool__amg])
1389 || (cv = cvp[off=numer_amg])
1390 || (cv = cvp[off=string_amg]));
1396 * SV* ref causes confusion with the interpreter variable of
1399 SV* tmpRef=SvRV(left);
1400 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1402 * Just to be extra cautious. Maybe in some
1403 * additional cases sv_setsv is safe, too.
1405 SV* newref = newSVsv(tmpRef);
1406 SvOBJECT_on(newref);
1407 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1413 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1414 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1415 SV* nullsv=sv_2mortal(newSViv(0));
1417 SV* lessp = amagic_call(left,nullsv,
1418 lt_amg,AMGf_noright);
1419 logic = SvTRUE(lessp);
1421 SV* lessp = amagic_call(left,nullsv,
1422 ncmp_amg,AMGf_noright);
1423 logic = (SvNV(lessp) < 0);
1426 if (off==subtr_amg) {
1437 if ((cv = cvp[off=subtr_amg])) {
1439 left = sv_2mortal(newSViv(0));
1444 case iter_amg: /* XXXX Eventually should do to_gv. */
1446 return NULL; /* Delegate operation to standard mechanisms. */
1454 return left; /* Delegate operation to standard mechanisms. */
1459 if (!cv) goto not_found;
1460 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1461 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1462 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1463 ? (amtp = (AMT*)mg->mg_ptr)->table
1465 && (cv = cvp[off=method])) { /* Method for right
1468 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1469 && (cvp=ocvp) && (lr = -1))
1470 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1471 && !(flags & AMGf_unary)) {
1472 /* We look for substitution for
1473 * comparison operations and
1475 if (method==concat_amg || method==concat_ass_amg
1476 || method==repeat_amg || method==repeat_ass_amg) {
1477 return NULL; /* Delegate operation to string conversion */
1487 postpr = 1; off=ncmp_amg; break;
1494 postpr = 1; off=scmp_amg; break;
1496 if (off != -1) cv = cvp[off];
1501 not_found: /* No method found, either report or croak */
1509 return left; /* Delegate operation to standard mechanisms. */
1512 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1513 notfound = 1; lr = -1;
1514 } else if (cvp && (cv=cvp[nomethod_amg])) {
1515 notfound = 1; lr = 1;
1518 if (off==-1) off=method;
1519 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1520 "Operation `%s': no method found,%sargument %s%s%s%s",
1521 AMG_id2name(method + assignshift),
1522 (flags & AMGf_unary ? " " : "\n\tleft "),
1524 "in overloaded package ":
1525 "has no overloaded magic",
1527 HvNAME(SvSTASH(SvRV(left))):
1530 ",\n\tright argument in overloaded package ":
1533 : ",\n\tright argument has no overloaded magic"),
1535 HvNAME(SvSTASH(SvRV(right))):
1537 if (amtp && amtp->fallback >= AMGfallYES) {
1538 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1540 Perl_croak(aTHX_ "%"SVf, msg);
1544 force_cpy = force_cpy || assign;
1548 DEBUG_o( Perl_deb(aTHX_
1549 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1551 method+assignshift==off? "" :
1553 method+assignshift==off? "" :
1554 AMG_id2name(method+assignshift),
1555 method+assignshift==off? "" : "')",
1556 flags & AMGf_unary? "" :
1557 lr==1 ? " for right argument": " for left argument",
1558 flags & AMGf_unary? " for argument" : "",
1560 fl? ",\n\tassignment variant used": "") );
1562 /* Since we use shallow copy during assignment, we need
1563 * to dublicate the contents, probably calling user-supplied
1564 * version of copy operator
1566 /* We need to copy in following cases:
1567 * a) Assignment form was called.
1568 * assignshift==1, assign==T, method + 1 == off
1569 * b) Increment or decrement, called directly.
1570 * assignshift==0, assign==0, method + 0 == off
1571 * c) Increment or decrement, translated to assignment add/subtr.
1572 * assignshift==0, assign==T,
1574 * d) Increment or decrement, translated to nomethod.
1575 * assignshift==0, assign==0,
1577 * e) Assignment form translated to nomethod.
1578 * assignshift==1, assign==T, method + 1 != off
1581 /* off is method, method+assignshift, or a result of opcode substitution.
1582 * In the latter case assignshift==0, so only notfound case is important.
1584 if (( (method + assignshift == off)
1585 && (assign || (method == inc_amg) || (method == dec_amg)))
1592 bool oldcatch = CATCH_GET;
1595 Zero(&myop, 1, BINOP);
1596 myop.op_last = (OP *) &myop;
1597 myop.op_next = Nullop;
1598 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1600 PUSHSTACKi(PERLSI_OVERLOAD);
1603 PL_op = (OP *) &myop;
1604 if (PERLDB_SUB && PL_curstash != PL_debstash)
1605 PL_op->op_private |= OPpENTERSUB_DB;
1609 EXTEND(SP, notfound + 5);
1610 PUSHs(lr>0? right: left);
1611 PUSHs(lr>0? left: right);
1612 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1614 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1619 if ((PL_op = Perl_pp_entersub(aTHX)))
1627 CATCH_SET(oldcatch);
1634 ans=SvIV(res)<=0; break;
1637 ans=SvIV(res)<0; break;
1640 ans=SvIV(res)>=0; break;
1643 ans=SvIV(res)>0; break;
1646 ans=SvIV(res)==0; break;
1649 ans=SvIV(res)!=0; break;
1652 SvSetSV(left,res); return left;
1654 ans=!SvTRUE(res); break;
1657 } else if (method==copy_amg) {
1659 Perl_croak(aTHX_ "Copy method did not return a reference");
1661 return SvREFCNT_inc(SvRV(res));
1669 =for apidoc is_gv_magical
1671 Returns C<TRUE> if given the name of a magical GV.
1673 Currently only useful internally when determining if a GV should be
1674 created even in rvalue contexts.
1676 C<flags> is not used at present but available for future extension to
1677 allow selecting particular classes of magical variable.
1682 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1689 if (len == 3 && strEQ(name, "ISA"))
1693 if (len == 8 && strEQ(name, "OVERLOAD"))
1697 if (len == 3 && strEQ(name, "SIG"))
1700 case '\017': /* $^O & $^OPEN */
1702 || (len == 4 && strEQ(name, "\027PEN")))
1707 case '\027': /* $^W & $^WARNING_BITS */
1709 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1710 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1742 case '\001': /* $^A */
1743 case '\003': /* $^C */
1744 case '\004': /* $^D */
1745 case '\005': /* $^E */
1746 case '\006': /* $^F */
1747 case '\010': /* $^H */
1748 case '\011': /* $^I, NOT \t in EBCDIC */
1749 case '\014': /* $^L */
1750 case '\020': /* $^P */
1751 case '\023': /* $^S */
1752 case '\024': /* $^T */
1753 case '\026': /* $^V */
1767 char *end = name + len;
1768 while (--end > name) {