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)
194 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
195 if ((level > 100) || (level < -100))
196 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
197 name, HvNAME(stash));
199 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
201 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
206 if (SvTYPE(topgv) != SVt_PVGV)
207 gv_init(topgv, stash, name, len, TRUE);
208 if ((cv = GvCV(topgv))) {
209 /* If genuine method or valid cache entry, use it */
210 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
212 /* Stale cached entry: junk it */
214 GvCV(topgv) = cv = Nullcv;
217 else if (GvCVGEN(topgv) == PL_sub_generation)
218 return 0; /* cache indicates sub doesn't exist */
221 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
222 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
224 /* create and re-create @.*::SUPER::ISA on demand */
225 if (!av || !SvMAGIC(av)) {
226 char* packname = HvNAME(stash);
227 STRLEN packlen = strlen(packname);
229 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
233 basestash = gv_stashpvn(packname, packlen, TRUE);
234 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
235 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
236 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
237 if (!gvp || !(gv = *gvp))
238 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
239 if (SvTYPE(gv) != SVt_PVGV)
240 gv_init(gv, stash, "ISA", 3, TRUE);
241 SvREFCNT_dec(GvAV(gv));
242 GvAV(gv) = (AV*)SvREFCNT_inc(av);
248 SV** svp = AvARRAY(av);
249 /* NOTE: No support for tied ISA */
250 I32 items = AvFILLp(av) + 1;
253 HV* basestash = gv_stashsv(sv, FALSE);
255 if (ckWARN(WARN_MISC))
256 Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
257 SvPVX(sv), HvNAME(stash));
260 gv = gv_fetchmeth(basestash, name, len,
261 (level >= 0) ? level + 1 : level - 1);
267 /* if at top level, try UNIVERSAL */
269 if (level == 0 || level == -1) {
272 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
273 if ((gv = gv_fetchmeth(lastchance, name, len,
274 (level >= 0) ? level + 1 : level - 1)))
278 * Cache method in topgv if:
279 * 1. topgv has no synonyms (else inheritance crosses wires)
280 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
283 GvREFCNT(topgv) == 1 &&
285 (CvROOT(cv) || CvXSUB(cv)))
287 if ((cv = GvCV(topgv)))
289 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
290 GvCVGEN(topgv) = PL_sub_generation;
294 else if (topgv && GvREFCNT(topgv) == 1) {
295 /* cache the fact that the method is not defined */
296 GvCVGEN(topgv) = PL_sub_generation;
305 =for apidoc gv_fetchmethod
307 See L<gv_fetchmethod_autoload>.
313 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
315 return gv_fetchmethod_autoload(stash, name, TRUE);
319 =for apidoc gv_fetchmethod_autoload
321 Returns the glob which contains the subroutine to call to invoke the method
322 on the C<stash>. In fact in the presence of autoloading this may be the
323 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
326 The third parameter of C<gv_fetchmethod_autoload> determines whether
327 AUTOLOAD lookup is performed if the given method is not present: non-zero
328 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
329 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
330 with a non-zero C<autoload> parameter.
332 These functions grant C<"SUPER"> token as a prefix of the method name. Note
333 that if you want to keep the returned glob for a long time, you need to
334 check for it being "AUTOLOAD", since at the later time the call may load a
335 different subroutine due to $AUTOLOAD changing its value. Use the glob
336 created via a side effect to do this.
338 These functions have the same side-effects and as C<gv_fetchmeth> with
339 C<level==0>. C<name> should be writable if contains C<':'> or C<'
340 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
341 C<call_sv> apply equally to these functions.
347 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
349 register const char *nend;
350 const char *nsplit = 0;
353 for (nend = name; *nend; nend++) {
356 else if (*nend == ':' && *(nend + 1) == ':')
360 const char *origname = name;
364 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
365 /* ->SUPER::method should really be looked up in original stash */
366 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
367 CopSTASHPV(PL_curcop)));
368 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
369 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
370 origname, HvNAME(stash), name) );
373 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
376 gv = gv_fetchmeth(stash, name, nend - name, 0);
378 if (strEQ(name,"import") || strEQ(name,"unimport"))
379 gv = (GV*)&PL_sv_yes;
381 gv = gv_autoload4(stash, name, nend - name, TRUE);
385 if (!CvROOT(cv) && !CvXSUB(cv)) {
393 if (GvCV(stubgv) != cv) /* orphaned import */
396 autogv = gv_autoload4(GvSTASH(stubgv),
397 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
407 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
409 static char autoload[] = "AUTOLOAD";
410 static STRLEN autolen = 8;
417 if (len == autolen && strnEQ(name, autoload, autolen))
419 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
423 if (!(CvROOT(cv) || CvXSUB(cv)))
427 * Inheriting AUTOLOAD for non-methods works ... for now.
429 if (ckWARN(WARN_DEPRECATED) && !method &&
430 (GvCVGEN(gv) || GvSTASH(gv) != stash))
431 Perl_warner(aTHX_ WARN_DEPRECATED,
432 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
433 HvNAME(stash), (int)len, name);
437 /* rather than lookup/init $AUTOLOAD here
438 * only to have the XSUB do another lookup for $AUTOLOAD
439 * and split that value on the last '::',
440 * pass along the same data via some unused fields in the CV
443 SvPVX(cv) = (char *)name; /* cast to loose constness warning */
450 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
451 * The subroutine's original name may not be "AUTOLOAD", so we don't
452 * use that, but for lack of anything better we will use the sub's
453 * original package to look up $AUTOLOAD.
455 varstash = GvSTASH(CvGV(cv));
456 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
460 sv_lock((SV *)varstash);
463 gv_init(vargv, varstash, autoload, autolen, FALSE);
469 sv_setpv(varsv, HvNAME(stash));
470 sv_catpvn(varsv, "::", 2);
471 sv_catpvn(varsv, name, len);
472 SvTAINTED_off(varsv);
476 /* The "gv" parameter should be the glob known to Perl code as *!
477 * The scalar must already have been magicalized.
480 S_require_errno(pTHX_ GV *gv)
482 HV* stash = gv_stashpvn("Errno",5,FALSE);
484 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
488 save_scalar(gv); /* keep the value of $! */
489 require_pv("Errno.pm");
492 stash = gv_stashpvn("Errno",5,FALSE);
493 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
494 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
499 =for apidoc gv_stashpv
501 Returns a pointer to the stash for a specified package. C<name> should
502 be a valid UTF-8 string. If C<create> is set then the package will be
503 created if it does not already exist. If C<create> is not set and the
504 package does not exist then NULL is returned.
510 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
512 return gv_stashpvn(name, strlen(name), create);
516 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
523 if (namelen + 3 < sizeof smallbuf)
526 New(606, tmpbuf, namelen + 3, char);
527 Copy(name,tmpbuf,namelen,char);
528 tmpbuf[namelen++] = ':';
529 tmpbuf[namelen++] = ':';
530 tmpbuf[namelen] = '\0';
531 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
532 if (tmpbuf != smallbuf)
537 GvHV(tmpgv) = newHV();
540 HvNAME(stash) = savepv(name);
545 =for apidoc gv_stashsv
547 Returns a pointer to the stash for a specified package, which must be a
548 valid UTF-8 string. See C<gv_stashpv>.
554 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
559 return gv_stashpvn(ptr, len, create);
564 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
566 register const char *name = nambeg;
570 register const char *namend;
573 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
576 for (namend = name; *namend; namend++) {
577 if ((*namend == ':' && namend[1] == ':')
578 || (*namend == '\'' && namend[1]))
582 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
590 if (len + 3 < sizeof smallbuf)
593 New(601, tmpbuf, len+3, char);
594 Copy(name, tmpbuf, len, char);
598 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
599 gv = gvp ? *gvp : Nullgv;
600 if (gv && gv != (GV*)&PL_sv_undef) {
601 if (SvTYPE(gv) != SVt_PVGV)
602 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
606 if (tmpbuf != smallbuf)
608 if (!gv || gv == (GV*)&PL_sv_undef)
611 if (!(stash = GvHV(gv)))
612 stash = GvHV(gv) = newHV();
615 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
623 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
630 /* No stash in name, so see how we can default */
633 if (isIDFIRST_lazy(name)) {
636 if (isUPPER(*name)) {
637 if (*name == 'S' && (
638 strEQ(name, "SIG") ||
639 strEQ(name, "STDIN") ||
640 strEQ(name, "STDOUT") ||
641 strEQ(name, "STDERR")))
643 else if (*name == 'I' && strEQ(name, "INC"))
645 else if (*name == 'E' && strEQ(name, "ENV"))
647 else if (*name == 'A' && (
648 strEQ(name, "ARGV") ||
649 strEQ(name, "ARGVOUT")))
652 else if (*name == '_' && !name[1])
657 else if ((COP*)PL_curcop == &PL_compiling) {
659 if (add && (PL_hints & HINT_STRICT_VARS) &&
660 sv_type != SVt_PVCV &&
661 sv_type != SVt_PVGV &&
662 sv_type != SVt_PVFM &&
663 sv_type != SVt_PVIO &&
664 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
666 gvp = (GV**)hv_fetch(stash,name,len,0);
668 *gvp == (GV*)&PL_sv_undef ||
669 SvTYPE(*gvp) != SVt_PVGV)
673 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
674 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
675 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
677 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
678 sv_type == SVt_PVAV ? '@' :
679 sv_type == SVt_PVHV ? '%' : '$',
682 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
688 stash = CopSTASH(PL_curcop);
694 /* By this point we should have a stash and a name */
698 qerror(Perl_mess(aTHX_
699 "Global symbol \"%s%s\" requires explicit package name",
700 (sv_type == SVt_PV ? "$"
701 : sv_type == SVt_PVAV ? "@"
702 : sv_type == SVt_PVHV ? "%"
704 stash = PL_nullstash;
710 if (!SvREFCNT(stash)) /* symbol table under destruction */
713 gvp = (GV**)hv_fetch(stash,name,len,add);
714 if (!gvp || *gvp == (GV*)&PL_sv_undef)
717 if (SvTYPE(gv) == SVt_PVGV) {
720 gv_init_sv(gv, sv_type);
721 if (*name=='!' && sv_type == SVt_PVHV && len==1)
725 } else if (add & GV_NOINIT) {
729 /* Adding a new symbol */
731 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
732 Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
733 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
734 gv_init_sv(gv, sv_type);
736 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
737 : (PL_dowarn & G_WARN_ON ) ) )
740 /* set up magic where warranted */
743 if (strEQ(name, "ARGV")) {
744 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
748 if (strnEQ(name, "EXPORT", 6))
752 if (strEQ(name, "ISA")) {
755 sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
756 /* NOTE: No support for tied ISA */
757 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
758 && AvFILLp(av) == -1)
761 av_push(av, newSVpvn(pname = "NDBM_File",9));
762 gv_stashpvn(pname, 9, TRUE);
763 av_push(av, newSVpvn(pname = "DB_File",7));
764 gv_stashpvn(pname, 7, TRUE);
765 av_push(av, newSVpvn(pname = "GDBM_File",9));
766 gv_stashpvn(pname, 9, TRUE);
767 av_push(av, newSVpvn(pname = "SDBM_File",9));
768 gv_stashpvn(pname, 9, TRUE);
769 av_push(av, newSVpvn(pname = "ODBM_File",9));
770 gv_stashpvn(pname, 9, TRUE);
775 if (strEQ(name, "OVERLOAD")) {
778 hv_magic(hv, Nullgv, 'A');
782 if (strEQ(name, "SIG")) {
786 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
787 Newz(73, PL_psig_name, SIG_SIZE, SV*);
788 Newz(73, PL_psig_pend, SIG_SIZE, int);
792 hv_magic(hv, Nullgv, 'S');
793 for (i = 1; i < SIG_SIZE; i++) {
795 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
797 sv_setsv(*init, &PL_sv_undef);
805 if (strEQ(name, "VERSION"))
812 PL_sawampersand = TRUE;
818 PL_sawampersand = TRUE;
824 PL_sawampersand = TRUE;
830 sv_setpv(GvSV(gv),PL_chopset);
836 #ifdef COMPLEX_STATUS
837 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
845 /* If %! has been used, automatically load Errno.pm.
846 The require will itself set errno, so in order to
847 preserve its value we have to set up the magic
848 now (rather than going to magicalize)
851 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
853 if (sv_type == SVt_PVHV)
862 sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
868 if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
869 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
884 case '\001': /* $^A */
885 case '\003': /* $^C */
886 case '\004': /* $^D */
887 case '\005': /* $^E */
888 case '\006': /* $^F */
889 case '\010': /* $^H */
890 case '\011': /* $^I, NOT \t in EBCDIC */
891 case '\020': /* $^P */
892 case '\024': /* $^T */
899 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
901 case '\017': /* $^O & $^OPEN */
902 if (len > 1 && strNE(name, "\017PEN"))
905 case '\023': /* $^S */
909 case '\027': /* $^W & $^WARNING_BITS */
910 if (len > 1 && strNE(name, "\027ARNING_BITS")
911 && strNE(name, "\027IDE_SYSTEM_CALLS"))
920 sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
934 SvREADONLY_on(GvSV(gv));
936 sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
939 case '\014': /* $^L */
942 sv_setpv(GvSV(gv),"\f");
943 PL_formfeed = GvSV(gv);
948 sv_setpv(GvSV(gv),"\034");
953 (void)SvUPGRADE(sv, SVt_PVNV);
954 Perl_sv_setpvf(aTHX_ sv,
955 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
961 SvNVX(PL_patchlevel));
962 SvNVX(sv) = SvNVX(PL_patchlevel);
967 case '\026': /* $^V */
970 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
979 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
981 HV *hv = GvSTASH(gv);
986 sv_setpv(sv, prefix ? prefix : "");
987 if (keepmain || strNE(HvNAME(hv), "main")) {
988 sv_catpv(sv,HvNAME(hv));
989 sv_catpvn(sv,"::", 2);
991 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
995 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
997 HV *hv = GvSTASH(gv);
1002 sv_setpv(sv, prefix ? prefix : "");
1003 sv_catpv(sv,HvNAME(hv));
1004 sv_catpvn(sv,"::", 2);
1005 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1009 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1011 GV *egv = GvEGV(gv);
1014 gv_fullname4(sv, egv, prefix, keepmain);
1018 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1020 GV *egv = GvEGV(gv);
1023 gv_fullname3(sv, egv, prefix);
1026 /* XXX compatibility with versions <= 5.003. */
1028 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1030 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1033 /* XXX compatibility with versions <= 5.003. */
1035 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1037 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1046 io = (IO*)NEWSV(0,0);
1047 sv_upgrade((SV *)io,SVt_PVIO);
1050 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1051 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1052 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1053 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1054 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1059 Perl_gv_check(pTHX_ HV *stash)
1066 if (!HvARRAY(stash))
1068 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1069 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1070 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1071 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1073 if (hv != PL_defstash && hv != stash)
1074 gv_check(hv); /* nested package */
1076 else if (isALPHA(*HeKEY(entry))) {
1078 gv = (GV*)HeVAL(entry);
1079 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1082 /* performance hack: if filename is absolute and it's a standard
1083 * module, don't bother warning */
1085 && PERL_FILE_IS_ABSOLUTE(file)
1086 #ifdef MACOS_TRADITIONAL
1087 && (instr(file, ":lib:")
1089 && (instr(file, "/lib/")
1091 || instr(file, ".pm")))
1095 CopLINE_set(PL_curcop, GvLINE(gv));
1097 CopFILE(PL_curcop) = file; /* set for warning */
1099 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1101 Perl_warner(aTHX_ WARN_ONCE,
1102 "Name \"%s::%s\" used only once: possible typo",
1103 HvNAME(stash), GvNAME(gv));
1110 Perl_newGVgen(pTHX_ char *pack)
1112 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1116 /* hopefully this is only called on local symbol table entries */
1119 Perl_gp_ref(pTHX_ GP *gp)
1126 /* multi-named GPs cannot be used for method cache */
1127 SvREFCNT_dec(gp->gp_cv);
1132 /* Adding a new name to a subroutine invalidates method cache */
1133 PL_sub_generation++;
1140 Perl_gp_free(pTHX_ GV *gv)
1144 if (!gv || !(gp = GvGP(gv)))
1146 if (gp->gp_refcnt == 0) {
1147 if (ckWARN_d(WARN_INTERNAL))
1148 Perl_warner(aTHX_ WARN_INTERNAL,
1149 "Attempt to free unreferenced glob pointers");
1153 /* Deleting the name of a subroutine invalidates method cache */
1154 PL_sub_generation++;
1156 if (--gp->gp_refcnt > 0) {
1157 if (gp->gp_egv == gv)
1162 SvREFCNT_dec(gp->gp_sv);
1163 SvREFCNT_dec(gp->gp_av);
1164 SvREFCNT_dec(gp->gp_hv);
1165 SvREFCNT_dec(gp->gp_io);
1166 SvREFCNT_dec(gp->gp_cv);
1167 SvREFCNT_dec(gp->gp_form);
1173 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1177 #ifdef MICROPORT /* Microport 2.4 hack */
1181 if (GvGP(gv)->gp_av)
1182 return GvGP(gv)->gp_av;
1184 return GvGP(gv_AVadd(gv))->gp_av;
1190 if (GvGP(gv)->gp_hv)
1191 return GvGP(gv)->gp_hv;
1193 return GvGP(gv_HVadd(gv))->gp_hv;
1195 #endif /* Microport 2.4 hack */
1198 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1200 AMT *amtp = (AMT*)mg->mg_ptr;
1201 if (amtp && AMT_AMAGIC(amtp)) {
1203 for (i = 1; i < NofAMmeth; i++) {
1204 CV *cv = amtp->table[i];
1206 SvREFCNT_dec((SV *) cv);
1207 amtp->table[i] = Nullcv;
1214 /* Updates and caches the CV's */
1217 Perl_Gv_AMupdate(pTHX_ HV *stash)
1221 MAGIC* mg=mg_find((SV*)stash,'c');
1222 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1226 if (mg && amtp->was_ok_am == PL_amagic_generation
1227 && amtp->was_ok_sub == PL_sub_generation)
1228 return AMT_OVERLOADED(amtp);
1229 sv_unmagic((SV*)stash, 'c');
1231 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1234 amt.was_ok_am = PL_amagic_generation;
1235 amt.was_ok_sub = PL_sub_generation;
1236 amt.fallback = AMGfallNO;
1240 int filled = 0, have_ovl = 0;
1244 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1246 /* Try to find via inheritance. */
1247 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1252 lim = DESTROY_amg; /* Skip overloading entries. */
1253 else if (SvTRUE(sv))
1254 amt.fallback=AMGfallYES;
1256 amt.fallback=AMGfallNEVER;
1258 for (i = 1; i < lim; i++)
1259 amt.table[i] = Nullcv;
1260 for (; i < NofAMmeth; i++) {
1261 char *cooky = (char*)PL_AMG_names[i];
1262 /* Human-readable form, for debugging: */
1263 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1264 STRLEN l = strlen(cooky);
1266 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1267 cp, HvNAME(stash)) );
1268 /* don't fill the cache while looking up! */
1269 gv = gv_fetchmeth(stash, cooky, l, -1);
1271 if (gv && (cv = GvCV(gv))) {
1272 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1273 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1274 /* GvSV contains the name of the method. */
1277 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1278 SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1279 if (!SvPOK(GvSV(gv))
1280 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1283 /* Can be an import stub (created by `can'). */
1285 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1286 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1289 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1290 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1293 cv = GvCV(gv = ngv);
1295 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1296 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1297 GvNAME(CvGV(cv))) );
1299 if (i < DESTROY_amg)
1302 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1305 AMT_AMAGIC_on(&amt);
1307 AMT_OVERLOADED_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));
1321 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1328 mg = mg_find((SV*)stash,'c');
1332 mg = mg_find((SV*)stash,'c');
1334 amtp = (AMT*)mg->mg_ptr;
1335 if ( amtp->was_ok_am != PL_amagic_generation
1336 || amtp->was_ok_sub != PL_sub_generation )
1338 if (AMT_AMAGIC(amtp))
1339 return amtp->table[id];
1345 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1349 CV **cvp=NULL, **ocvp=NULL;
1351 int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1352 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1354 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1355 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1356 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1357 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1359 && ((cv = cvp[off=method+assignshift])
1360 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1362 (fl = 1, cv = cvp[off=method])))) {
1363 lr = -1; /* Call method for left argument */
1365 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1368 /* look for substituted methods */
1369 /* In all the covered cases we should be called with assign==0. */
1373 if ((cv = cvp[off=add_ass_amg])
1374 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1375 right = &PL_sv_yes; lr = -1; assign = 1;
1380 if ((cv = cvp[off = subtr_ass_amg])
1381 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1382 right = &PL_sv_yes; lr = -1; assign = 1;
1386 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1389 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1392 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1395 (void)((cv = cvp[off=bool__amg])
1396 || (cv = cvp[off=numer_amg])
1397 || (cv = cvp[off=string_amg]));
1403 * SV* ref causes confusion with the interpreter variable of
1406 SV* tmpRef=SvRV(left);
1407 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1409 * Just to be extra cautious. Maybe in some
1410 * additional cases sv_setsv is safe, too.
1412 SV* newref = newSVsv(tmpRef);
1413 SvOBJECT_on(newref);
1414 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1420 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1421 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1422 SV* nullsv=sv_2mortal(newSViv(0));
1424 SV* lessp = amagic_call(left,nullsv,
1425 lt_amg,AMGf_noright);
1426 logic = SvTRUE(lessp);
1428 SV* lessp = amagic_call(left,nullsv,
1429 ncmp_amg,AMGf_noright);
1430 logic = (SvNV(lessp) < 0);
1433 if (off==subtr_amg) {
1444 if ((cv = cvp[off=subtr_amg])) {
1446 left = sv_2mortal(newSViv(0));
1451 case iter_amg: /* XXXX Eventually should do to_gv. */
1453 return NULL; /* Delegate operation to standard mechanisms. */
1461 return left; /* Delegate operation to standard mechanisms. */
1466 if (!cv) goto not_found;
1467 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1468 && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1469 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1470 ? (amtp = (AMT*)mg->mg_ptr)->table
1472 && (cv = cvp[off=method])) { /* Method for right
1475 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1476 && (cvp=ocvp) && (lr = -1))
1477 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1478 && !(flags & AMGf_unary)) {
1479 /* We look for substitution for
1480 * comparison operations and
1482 if (method==concat_amg || method==concat_ass_amg
1483 || method==repeat_amg || method==repeat_ass_amg) {
1484 return NULL; /* Delegate operation to string conversion */
1494 postpr = 1; off=ncmp_amg; break;
1501 postpr = 1; off=scmp_amg; break;
1503 if (off != -1) cv = cvp[off];
1508 not_found: /* No method found, either report or croak */
1516 return left; /* Delegate operation to standard mechanisms. */
1519 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1520 notfound = 1; lr = -1;
1521 } else if (cvp && (cv=cvp[nomethod_amg])) {
1522 notfound = 1; lr = 1;
1525 if (off==-1) off=method;
1526 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1527 "Operation `%s': no method found,%sargument %s%s%s%s",
1528 AMG_id2name(method + assignshift),
1529 (flags & AMGf_unary ? " " : "\n\tleft "),
1531 "in overloaded package ":
1532 "has no overloaded magic",
1534 HvNAME(SvSTASH(SvRV(left))):
1537 ",\n\tright argument in overloaded package ":
1540 : ",\n\tright argument has no overloaded magic"),
1542 HvNAME(SvSTASH(SvRV(right))):
1544 if (amtp && amtp->fallback >= AMGfallYES) {
1545 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1547 Perl_croak(aTHX_ "%"SVf, msg);
1551 force_cpy = force_cpy || assign;
1555 DEBUG_o( Perl_deb(aTHX_
1556 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1558 method+assignshift==off? "" :
1560 method+assignshift==off? "" :
1561 AMG_id2name(method+assignshift),
1562 method+assignshift==off? "" : "')",
1563 flags & AMGf_unary? "" :
1564 lr==1 ? " for right argument": " for left argument",
1565 flags & AMGf_unary? " for argument" : "",
1567 fl? ",\n\tassignment variant used": "") );
1569 /* Since we use shallow copy during assignment, we need
1570 * to dublicate the contents, probably calling user-supplied
1571 * version of copy operator
1573 /* We need to copy in following cases:
1574 * a) Assignment form was called.
1575 * assignshift==1, assign==T, method + 1 == off
1576 * b) Increment or decrement, called directly.
1577 * assignshift==0, assign==0, method + 0 == off
1578 * c) Increment or decrement, translated to assignment add/subtr.
1579 * assignshift==0, assign==T,
1581 * d) Increment or decrement, translated to nomethod.
1582 * assignshift==0, assign==0,
1584 * e) Assignment form translated to nomethod.
1585 * assignshift==1, assign==T, method + 1 != off
1588 /* off is method, method+assignshift, or a result of opcode substitution.
1589 * In the latter case assignshift==0, so only notfound case is important.
1591 if (( (method + assignshift == off)
1592 && (assign || (method == inc_amg) || (method == dec_amg)))
1599 bool oldcatch = CATCH_GET;
1602 Zero(&myop, 1, BINOP);
1603 myop.op_last = (OP *) &myop;
1604 myop.op_next = Nullop;
1605 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1607 PUSHSTACKi(PERLSI_OVERLOAD);
1610 PL_op = (OP *) &myop;
1611 if (PERLDB_SUB && PL_curstash != PL_debstash)
1612 PL_op->op_private |= OPpENTERSUB_DB;
1616 EXTEND(SP, notfound + 5);
1617 PUSHs(lr>0? right: left);
1618 PUSHs(lr>0? left: right);
1619 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1621 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1626 if ((PL_op = Perl_pp_entersub(aTHX)))
1634 CATCH_SET(oldcatch);
1641 ans=SvIV(res)<=0; break;
1644 ans=SvIV(res)<0; break;
1647 ans=SvIV(res)>=0; break;
1650 ans=SvIV(res)>0; break;
1653 ans=SvIV(res)==0; break;
1656 ans=SvIV(res)!=0; break;
1659 SvSetSV(left,res); return left;
1661 ans=!SvTRUE(res); break;
1664 } else if (method==copy_amg) {
1666 Perl_croak(aTHX_ "Copy method did not return a reference");
1668 return SvREFCNT_inc(SvRV(res));
1676 =for apidoc is_gv_magical
1678 Returns C<TRUE> if given the name of a magical GV.
1680 Currently only useful internally when determining if a GV should be
1681 created even in rvalue contexts.
1683 C<flags> is not used at present but available for future extension to
1684 allow selecting particular classes of magical variable.
1689 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1696 if (len == 3 && strEQ(name, "ISA"))
1700 if (len == 8 && strEQ(name, "OVERLOAD"))
1704 if (len == 3 && strEQ(name, "SIG"))
1707 case '\017': /* $^O & $^OPEN */
1709 || (len == 4 && strEQ(name, "\027PEN")))
1714 case '\027': /* $^W & $^WARNING_BITS */
1716 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1717 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1749 case '\001': /* $^A */
1750 case '\003': /* $^C */
1751 case '\004': /* $^D */
1752 case '\005': /* $^E */
1753 case '\006': /* $^F */
1754 case '\010': /* $^H */
1755 case '\011': /* $^I, NOT \t in EBCDIC */
1756 case '\014': /* $^L */
1757 case '\020': /* $^P */
1758 case '\023': /* $^S */
1759 case '\024': /* $^T */
1760 case '\026': /* $^V */
1774 char *end = name + len;
1775 while (--end > name) {