3 * Copyright (c) 1991-2002, 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,'
28 Perl_gv_AVadd(pTHX_ register GV *gv)
30 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
31 Perl_croak(aTHX_ "Bad symbol for array");
38 Perl_gv_HVadd(pTHX_ register GV *gv)
40 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
41 Perl_croak(aTHX_ "Bad symbol for hash");
48 Perl_gv_IOadd(pTHX_ register GV *gv)
50 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
51 Perl_croak(aTHX_ "Bad symbol for filehandle");
53 #ifdef GV_UNIQUE_CHECK
55 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
64 Perl_gv_fetchfile(pTHX_ const char *name)
74 tmplen = strlen(name) + 2;
75 if (tmplen < sizeof smallbuf)
78 New(603, tmpbuf, tmplen + 1, char);
79 /* This is where the debugger's %{"::_<$filename"} hash is created */
82 strcpy(tmpbuf + 2, name);
83 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
85 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
86 sv_setpv(GvSV(gv), name);
88 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
90 if (tmpbuf != smallbuf)
96 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
99 bool doproto = SvTYPE(gv) > SVt_NULL;
100 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
102 sv_upgrade((SV*)gv, SVt_PVGV);
111 Newz(602, gp, 1, GP);
112 GvGP(gv) = gp_ref(gp);
113 GvSV(gv) = NEWSV(72,0);
114 GvLINE(gv) = CopLINE(PL_curcop);
115 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
118 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
119 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
120 GvNAME(gv) = savepvn(name, len);
122 if (multi || doproto) /* doproto means it _was_ mentioned */
124 if (doproto) { /* Replicate part of newSUB here. */
127 /* XXX unsafe for threads if eval_owner isn't held */
128 start_subparse(0,0); /* Create CV in compcv. */
129 GvCV(gv) = PL_compcv;
134 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
135 CvSTASH(GvCV(gv)) = PL_curstash;
136 #ifdef USE_5005THREADS
137 CvOWNER(GvCV(gv)) = 0;
138 if (!CvMUTEXP(GvCV(gv))) {
139 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
140 MUTEX_INIT(CvMUTEXP(GvCV(gv)));
142 #endif /* USE_5005THREADS */
144 sv_setpv((SV*)GvCV(gv), proto);
151 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
167 =for apidoc gv_fetchmeth
169 Returns the glob with the given C<name> and a defined subroutine or
170 C<NULL>. The glob lives in the given C<stash>, or in the stashes
171 accessible via @ISA and UNIVERSAL::.
173 The argument C<level> should be either 0 or -1. If C<level==0>, as a
174 side-effect creates a glob with the given C<name> in the given C<stash>
175 which in the case of success contains an alias for the subroutine, and sets
176 up caching info for this glob. Similarly for all the searched stashes.
178 This function grants C<"SUPER"> token as a postfix of the stash name. The
179 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
180 visible to Perl code. So when calling C<call_sv>, you should not use
181 the GV directly; instead, you should use the method's CV, which can be
182 obtained from the GV with the C<GvCV> macro.
188 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
196 /* UNIVERSAL methods should be callable without a stash */
198 level = -1; /* probably appropriate */
199 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
203 if ((level > 100) || (level < -100))
204 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
205 name, HvNAME(stash));
207 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
209 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
214 if (SvTYPE(topgv) != SVt_PVGV)
215 gv_init(topgv, stash, name, len, TRUE);
216 if ((cv = GvCV(topgv))) {
217 /* If genuine method or valid cache entry, use it */
218 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
220 /* Stale cached entry: junk it */
222 GvCV(topgv) = cv = Nullcv;
225 else if (GvCVGEN(topgv) == PL_sub_generation)
226 return 0; /* cache indicates sub doesn't exist */
229 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
230 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
232 /* create and re-create @.*::SUPER::ISA on demand */
233 if (!av || !SvMAGIC(av)) {
234 char* packname = HvNAME(stash);
235 STRLEN packlen = strlen(packname);
237 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
241 basestash = gv_stashpvn(packname, packlen, TRUE);
242 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
243 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
244 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
245 if (!gvp || !(gv = *gvp))
246 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
247 if (SvTYPE(gv) != SVt_PVGV)
248 gv_init(gv, stash, "ISA", 3, TRUE);
249 SvREFCNT_dec(GvAV(gv));
250 GvAV(gv) = (AV*)SvREFCNT_inc(av);
256 SV** svp = AvARRAY(av);
257 /* NOTE: No support for tied ISA */
258 I32 items = AvFILLp(av) + 1;
261 HV* basestash = gv_stashsv(sv, FALSE);
263 if (ckWARN(WARN_MISC))
264 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %s for @%s::ISA",
265 SvPVX(sv), HvNAME(stash));
268 gv = gv_fetchmeth(basestash, name, len,
269 (level >= 0) ? level + 1 : level - 1);
275 /* if at top level, try UNIVERSAL */
277 if (level == 0 || level == -1) {
280 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
281 if ((gv = gv_fetchmeth(lastchance, name, len,
282 (level >= 0) ? level + 1 : level - 1)))
286 * Cache method in topgv if:
287 * 1. topgv has no synonyms (else inheritance crosses wires)
288 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
291 GvREFCNT(topgv) == 1 &&
293 (CvROOT(cv) || CvXSUB(cv)))
295 if ((cv = GvCV(topgv)))
297 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
298 GvCVGEN(topgv) = PL_sub_generation;
302 else if (topgv && GvREFCNT(topgv) == 1) {
303 /* cache the fact that the method is not defined */
304 GvCVGEN(topgv) = PL_sub_generation;
313 =for apidoc gv_fetchmeth_autoload
315 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
316 Returns a glob for the subroutine.
318 For an autoloaded subroutine without a GV, will create a GV even
319 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
320 of the result may be zero.
326 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
328 GV *gv = gv_fetchmeth(stash, name, len, level);
331 char autoload[] = "AUTOLOAD";
332 STRLEN autolen = sizeof(autoload)-1;
337 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
338 if (len == autolen && strnEQ(name, autoload, autolen))
340 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
343 if (!(CvROOT(cv) || CvXSUB(cv)))
345 /* Have an autoload */
346 if (level < 0) /* Cannot do without a stub */
347 gv_fetchmeth(stash, name, len, 0);
348 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
357 =for apidoc gv_fetchmethod
359 See L<gv_fetchmethod_autoload>.
365 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
367 return gv_fetchmethod_autoload(stash, name, TRUE);
371 =for apidoc gv_fetchmethod_autoload
373 Returns the glob which contains the subroutine to call to invoke the method
374 on the C<stash>. In fact in the presence of autoloading this may be the
375 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
378 The third parameter of C<gv_fetchmethod_autoload> determines whether
379 AUTOLOAD lookup is performed if the given method is not present: non-zero
380 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
381 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
382 with a non-zero C<autoload> parameter.
384 These functions grant C<"SUPER"> token as a prefix of the method name. Note
385 that if you want to keep the returned glob for a long time, you need to
386 check for it being "AUTOLOAD", since at the later time the call may load a
387 different subroutine due to $AUTOLOAD changing its value. Use the glob
388 created via a side effect to do this.
390 These functions have the same side-effects and as C<gv_fetchmeth> with
391 C<level==0>. C<name> should be writable if contains C<':'> or C<'
392 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
393 C<call_sv> apply equally to these functions.
399 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
401 register const char *nend;
402 const char *nsplit = 0;
405 for (nend = name; *nend; nend++) {
408 else if (*nend == ':' && *(nend + 1) == ':')
412 const char *origname = name;
416 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
417 /* ->SUPER::method should really be looked up in original stash */
418 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
419 CopSTASHPV(PL_curcop)));
420 /* __PACKAGE__::SUPER stash should be autovivified */
421 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
422 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
423 origname, HvNAME(stash), name) );
426 /* don't autovifify if ->NoSuchStash::method */
427 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
429 /* however, explicit calls to Pkg::SUPER::method may
430 happen, and may require autovivification to work */
431 if (!stash && (nsplit - origname) >= 7 &&
432 strnEQ(nsplit - 7, "::SUPER", 7) &&
433 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
434 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
438 gv = gv_fetchmeth(stash, name, nend - name, 0);
440 if (strEQ(name,"import") || strEQ(name,"unimport"))
441 gv = (GV*)&PL_sv_yes;
443 gv = gv_autoload4(stash, name, nend - name, TRUE);
447 if (!CvROOT(cv) && !CvXSUB(cv)) {
455 if (GvCV(stubgv) != cv) /* orphaned import */
458 autogv = gv_autoload4(GvSTASH(stubgv),
459 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
469 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
471 char autoload[] = "AUTOLOAD";
472 STRLEN autolen = sizeof(autoload)-1;
480 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
481 if (len == autolen && strnEQ(name, autoload, autolen))
483 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
487 if (!(CvROOT(cv) || CvXSUB(cv)))
491 * Inheriting AUTOLOAD for non-methods works ... for now.
493 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
494 (GvCVGEN(gv) || GvSTASH(gv) != stash))
495 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
496 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
497 HvNAME(stash), (int)len, name);
499 #ifndef USE_5005THREADS
501 /* rather than lookup/init $AUTOLOAD here
502 * only to have the XSUB do another lookup for $AUTOLOAD
503 * and split that value on the last '::',
504 * pass along the same data via some unused fields in the CV
507 SvPVX(cv) = (char *)name; /* cast to lose constness warning */
514 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
515 * The subroutine's original name may not be "AUTOLOAD", so we don't
516 * use that, but for lack of anything better we will use the sub's
517 * original package to look up $AUTOLOAD.
519 varstash = GvSTASH(CvGV(cv));
520 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
523 #ifdef USE_5005THREADS
524 sv_lock((SV *)varstash);
527 gv_init(vargv, varstash, autoload, autolen, FALSE);
530 #ifdef USE_5005THREADS
533 sv_setpv(varsv, HvNAME(stash));
534 sv_catpvn(varsv, "::", 2);
535 sv_catpvn(varsv, name, len);
536 SvTAINTED_off(varsv);
540 /* The "gv" parameter should be the glob known to Perl code as *!
541 * The scalar must already have been magicalized.
544 S_require_errno(pTHX_ GV *gv)
546 HV* stash = gv_stashpvn("Errno",5,FALSE);
548 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
552 save_scalar(gv); /* keep the value of $! */
553 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
554 newSVpvn("Errno",5), Nullsv);
557 stash = gv_stashpvn("Errno",5,FALSE);
558 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
559 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
564 =for apidoc gv_stashpv
566 Returns a pointer to the stash for a specified package. C<name> should
567 be a valid UTF-8 string. If C<create> is set then the package will be
568 created if it does not already exist. If C<create> is not set and the
569 package does not exist then NULL is returned.
575 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
577 return gv_stashpvn(name, strlen(name), create);
581 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
588 if (namelen + 3 < sizeof smallbuf)
591 New(606, tmpbuf, namelen + 3, char);
592 Copy(name,tmpbuf,namelen,char);
593 tmpbuf[namelen++] = ':';
594 tmpbuf[namelen++] = ':';
595 tmpbuf[namelen] = '\0';
596 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
597 if (tmpbuf != smallbuf)
602 GvHV(tmpgv) = newHV();
605 HvNAME(stash) = savepv(name);
610 =for apidoc gv_stashsv
612 Returns a pointer to the stash for a specified package, which must be a
613 valid UTF-8 string. See C<gv_stashpv>.
619 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
624 return gv_stashpvn(ptr, len, create);
629 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
631 register const char *name = nambeg;
635 register const char *namend;
638 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
641 for (namend = name; *namend; namend++) {
642 if ((*namend == ':' && namend[1] == ':')
643 || (*namend == '\'' && namend[1]))
647 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
655 if (len + 3 < sizeof (smallbuf))
658 New(601, tmpbuf, len+3, char);
659 Copy(name, tmpbuf, len, char);
663 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
664 gv = gvp ? *gvp : Nullgv;
665 if (gv && gv != (GV*)&PL_sv_undef) {
666 if (SvTYPE(gv) != SVt_PVGV)
667 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
671 if (tmpbuf != smallbuf)
673 if (!gv || gv == (GV*)&PL_sv_undef)
676 if (!(stash = GvHV(gv)))
677 stash = GvHV(gv) = newHV();
680 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
688 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
695 /* No stash in name, so see how we can default */
698 if (isIDFIRST_lazy(name)) {
701 if (isUPPER(*name)) {
702 if (*name == 'S' && (
703 strEQ(name, "SIG") ||
704 strEQ(name, "STDIN") ||
705 strEQ(name, "STDOUT") ||
706 strEQ(name, "STDERR")))
708 else if (*name == 'I' && strEQ(name, "INC"))
710 else if (*name == 'E' && strEQ(name, "ENV"))
712 else if (*name == 'A' && (
713 strEQ(name, "ARGV") ||
714 strEQ(name, "ARGVOUT")))
717 else if (*name == '_' && !name[1])
722 else if ((COP*)PL_curcop == &PL_compiling) {
724 if (add && (PL_hints & HINT_STRICT_VARS) &&
725 sv_type != SVt_PVCV &&
726 sv_type != SVt_PVGV &&
727 sv_type != SVt_PVFM &&
728 sv_type != SVt_PVIO &&
729 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
731 gvp = (GV**)hv_fetch(stash,name,len,0);
733 *gvp == (GV*)&PL_sv_undef ||
734 SvTYPE(*gvp) != SVt_PVGV)
738 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
739 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
740 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
742 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
743 sv_type == SVt_PVAV ? '@' :
744 sv_type == SVt_PVHV ? '%' : '$',
747 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
753 stash = CopSTASH(PL_curcop);
759 /* By this point we should have a stash and a name */
763 qerror(Perl_mess(aTHX_
764 "Global symbol \"%s%s\" requires explicit package name",
765 (sv_type == SVt_PV ? "$"
766 : sv_type == SVt_PVAV ? "@"
767 : sv_type == SVt_PVHV ? "%"
769 stash = PL_nullstash;
775 if (!SvREFCNT(stash)) /* symbol table under destruction */
778 gvp = (GV**)hv_fetch(stash,name,len,add);
779 if (!gvp || *gvp == (GV*)&PL_sv_undef)
782 if (SvTYPE(gv) == SVt_PVGV) {
785 gv_init_sv(gv, sv_type);
786 if (*name=='!' && sv_type == SVt_PVHV && len==1)
790 } else if (add & GV_NOINIT) {
794 /* Adding a new symbol */
796 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
797 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
798 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
799 gv_init_sv(gv, sv_type);
801 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
802 : (PL_dowarn & G_WARN_ON ) ) )
805 /* set up magic where warranted */
808 if (strEQ(name, "ARGV")) {
809 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
813 if (strnEQ(name, "EXPORT", 6))
817 if (strEQ(name, "ISA")) {
820 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
821 /* NOTE: No support for tied ISA */
822 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
823 && AvFILLp(av) == -1)
826 av_push(av, newSVpvn(pname = "NDBM_File",9));
827 gv_stashpvn(pname, 9, TRUE);
828 av_push(av, newSVpvn(pname = "DB_File",7));
829 gv_stashpvn(pname, 7, TRUE);
830 av_push(av, newSVpvn(pname = "GDBM_File",9));
831 gv_stashpvn(pname, 9, TRUE);
832 av_push(av, newSVpvn(pname = "SDBM_File",9));
833 gv_stashpvn(pname, 9, TRUE);
834 av_push(av, newSVpvn(pname = "ODBM_File",9));
835 gv_stashpvn(pname, 9, TRUE);
840 if (strEQ(name, "OVERLOAD")) {
843 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
847 if (strEQ(name, "SIG")) {
851 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
852 Newz(73, PL_psig_name, SIG_SIZE, SV*);
853 Newz(73, PL_psig_pend, SIG_SIZE, int);
857 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
858 for (i = 1; i < SIG_SIZE; i++) {
860 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
862 sv_setsv(*init, &PL_sv_undef);
870 if (strEQ(name, "VERSION"))
879 sv_type == SVt_PVAV ||
880 sv_type == SVt_PVHV ||
881 sv_type == SVt_PVCV ||
882 sv_type == SVt_PVFM ||
885 PL_sawampersand = TRUE;
891 sv_setpv(GvSV(gv),PL_chopset);
897 #ifdef COMPLEX_STATUS
898 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
906 /* If %! has been used, automatically load Errno.pm.
907 The require will itself set errno, so in order to
908 preserve its value we have to set up the magic
909 now (rather than going to magicalize)
912 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
914 if (sv_type == SVt_PVHV)
923 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
929 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
930 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
945 case '\001': /* $^A */
946 case '\003': /* $^C */
947 case '\004': /* $^D */
948 case '\006': /* $^F */
949 case '\010': /* $^H */
950 case '\011': /* $^I, NOT \t in EBCDIC */
951 case '\016': /* $^N */
952 case '\020': /* $^P */
959 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
961 case '\005': /* $^E && $^ENCODING */
962 if (len > 1 && strNE(name, "\005NCODING"))
966 case '\017': /* $^O & $^OPEN */
967 if (len > 1 && strNE(name, "\017PEN"))
970 case '\023': /* $^S */
974 case '\024': /* $^T, ${^TAINT} */
977 else if (strEQ(name, "\024AINT"))
981 case '\027': /* $^W & $^WARNING_BITS */
982 if (len > 1 && strNE(name, "\027ARNING_BITS")
983 && strNE(name, "\027IDE_SYSTEM_CALLS"))
992 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1005 /* ensures variable is only digits */
1006 /* ${"1foo"} fails this test (and is thus writeable) */
1007 /* added by japhy, but borrowed from is_gv_magical */
1010 const char *end = name + len;
1011 while (--end > name) {
1012 if (!isDIGIT(*end)) return gv;
1017 SvREADONLY_on(GvSV(gv));
1019 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1022 case '\014': /* $^L */
1025 sv_setpv(GvSV(gv),"\f");
1026 PL_formfeed = GvSV(gv);
1031 sv_setpv(GvSV(gv),"\034");
1036 (void)SvUPGRADE(sv, SVt_PVNV);
1037 Perl_sv_setpvf(aTHX_ sv,
1038 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1044 SvNVX(PL_patchlevel));
1045 SvNVX(sv) = SvNVX(PL_patchlevel);
1050 case '\026': /* $^V */
1053 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1062 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1064 HV *hv = GvSTASH(gv);
1069 sv_setpv(sv, prefix ? prefix : "");
1070 if (keepmain || strNE(HvNAME(hv), "main")) {
1071 sv_catpv(sv,HvNAME(hv));
1072 sv_catpvn(sv,"::", 2);
1074 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1078 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1080 gv_fullname4(sv, gv, prefix, TRUE);
1084 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1086 GV *egv = GvEGV(gv);
1089 gv_fullname4(sv, egv, prefix, keepmain);
1093 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1095 gv_efullname4(sv, gv, prefix, TRUE);
1098 /* XXX compatibility with versions <= 5.003. */
1100 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1102 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1105 /* XXX compatibility with versions <= 5.003. */
1107 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1109 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1118 io = (IO*)NEWSV(0,0);
1119 sv_upgrade((SV *)io,SVt_PVIO);
1122 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1123 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1124 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1125 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1126 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1131 Perl_gv_check(pTHX_ HV *stash)
1138 if (!HvARRAY(stash))
1140 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1141 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1142 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1143 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
1145 if (hv != PL_defstash && hv != stash)
1146 gv_check(hv); /* nested package */
1148 else if (isALPHA(*HeKEY(entry))) {
1150 gv = (GV*)HeVAL(entry);
1151 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1154 /* performance hack: if filename is absolute and it's a standard
1155 * module, don't bother warning */
1157 && PERL_FILE_IS_ABSOLUTE(file)
1158 #ifdef MACOS_TRADITIONAL
1159 && (instr(file, ":lib:")
1161 && (instr(file, "/lib/")
1163 || instr(file, ".pm")))
1167 CopLINE_set(PL_curcop, GvLINE(gv));
1169 CopFILE(PL_curcop) = file; /* set for warning */
1171 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1173 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1174 "Name \"%s::%s\" used only once: possible typo",
1175 HvNAME(stash), GvNAME(gv));
1182 Perl_newGVgen(pTHX_ char *pack)
1184 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1188 /* hopefully this is only called on local symbol table entries */
1191 Perl_gp_ref(pTHX_ GP *gp)
1198 /* multi-named GPs cannot be used for method cache */
1199 SvREFCNT_dec(gp->gp_cv);
1204 /* Adding a new name to a subroutine invalidates method cache */
1205 PL_sub_generation++;
1212 Perl_gp_free(pTHX_ GV *gv)
1216 if (!gv || !(gp = GvGP(gv)))
1218 if (gp->gp_refcnt == 0) {
1219 if (ckWARN_d(WARN_INTERNAL))
1220 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1221 "Attempt to free unreferenced glob pointers");
1225 /* Deleting the name of a subroutine invalidates method cache */
1226 PL_sub_generation++;
1228 if (--gp->gp_refcnt > 0) {
1229 if (gp->gp_egv == gv)
1234 SvREFCNT_dec(gp->gp_sv);
1235 SvREFCNT_dec(gp->gp_av);
1236 SvREFCNT_dec(gp->gp_hv);
1237 SvREFCNT_dec(gp->gp_io);
1238 SvREFCNT_dec(gp->gp_cv);
1239 SvREFCNT_dec(gp->gp_form);
1246 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1248 AMT *amtp = (AMT*)mg->mg_ptr;
1249 if (amtp && AMT_AMAGIC(amtp)) {
1251 for (i = 1; i < NofAMmeth; i++) {
1252 CV *cv = amtp->table[i];
1254 SvREFCNT_dec((SV *) cv);
1255 amtp->table[i] = Nullcv;
1262 /* Updates and caches the CV's */
1265 Perl_Gv_AMupdate(pTHX_ HV *stash)
1269 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1270 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1273 if (mg && amtp->was_ok_am == PL_amagic_generation
1274 && amtp->was_ok_sub == PL_sub_generation)
1275 return (bool)AMT_OVERLOADED(amtp);
1276 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1278 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1281 amt.was_ok_am = PL_amagic_generation;
1282 amt.was_ok_sub = PL_sub_generation;
1283 amt.fallback = AMGfallNO;
1287 int filled = 0, have_ovl = 0;
1291 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1293 /* Try to find via inheritance. */
1294 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1299 lim = DESTROY_amg; /* Skip overloading entries. */
1300 else if (SvTRUE(sv))
1301 amt.fallback=AMGfallYES;
1303 amt.fallback=AMGfallNEVER;
1305 for (i = 1; i < lim; i++)
1306 amt.table[i] = Nullcv;
1307 for (; i < NofAMmeth; i++) {
1308 char *cooky = (char*)PL_AMG_names[i];
1309 /* Human-readable form, for debugging: */
1310 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1311 STRLEN l = strlen(cooky);
1313 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1314 cp, HvNAME(stash)) );
1315 /* don't fill the cache while looking up!
1316 Creation of inheritance stubs in intermediate packages may
1317 conflict with the logic of runtime method substitution.
1318 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1319 then we could have created stubs for "(+0" in A and C too.
1320 But if B overloads "bool", we may want to use it for
1321 numifying instead of C's "+0". */
1322 if (i >= DESTROY_amg)
1323 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1324 else /* Autoload taken care of below */
1325 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1327 if (gv && (cv = GvCV(gv))) {
1328 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1329 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1330 /* This is a hack to support autoloading..., while
1331 knowing *which* methods were declared as overloaded. */
1332 /* GvSV contains the name of the method. */
1335 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1336 SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
1337 if (!SvPOK(GvSV(gv))
1338 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1341 /* Can be an import stub (created by `can'). */
1343 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1344 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1347 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1348 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1351 cv = GvCV(gv = ngv);
1353 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1354 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1355 GvNAME(CvGV(cv))) );
1357 if (i < DESTROY_amg)
1359 } else if (gv) { /* Autoloaded... */
1363 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1366 AMT_AMAGIC_on(&amt);
1368 AMT_OVERLOADED_on(&amt);
1369 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1370 (char*)&amt, sizeof(AMT));
1374 /* Here we have no table: */
1376 AMT_AMAGIC_off(&amt);
1377 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1378 (char*)&amt, sizeof(AMTS));
1384 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1392 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1396 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1398 amtp = (AMT*)mg->mg_ptr;
1399 if ( amtp->was_ok_am != PL_amagic_generation
1400 || amtp->was_ok_sub != PL_sub_generation )
1402 if (AMT_AMAGIC(amtp)) {
1403 ret = amtp->table[id];
1404 if (ret && isGV(ret)) { /* Autoloading stab */
1405 /* Passing it through may have resulted in a warning
1406 "Inherited AUTOLOAD for a non-method deprecated", since
1407 our caller is going through a function call, not a method call.
1408 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1409 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1422 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1426 CV **cvp=NULL, **ocvp=NULL;
1427 AMT *amtp=NULL, *oamtp=NULL;
1428 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1429 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1434 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1435 && (stash = SvSTASH(SvRV(left)))
1436 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1437 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1438 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1440 && ((cv = cvp[off=method+assignshift])
1441 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1447 cv = cvp[off=method])))) {
1448 lr = -1; /* Call method for left argument */
1450 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1453 /* look for substituted methods */
1454 /* In all the covered cases we should be called with assign==0. */
1458 if ((cv = cvp[off=add_ass_amg])
1459 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1460 right = &PL_sv_yes; lr = -1; assign = 1;
1465 if ((cv = cvp[off = subtr_ass_amg])
1466 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1467 right = &PL_sv_yes; lr = -1; assign = 1;
1471 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1474 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1477 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1480 (void)((cv = cvp[off=bool__amg])
1481 || (cv = cvp[off=numer_amg])
1482 || (cv = cvp[off=string_amg]));
1488 * SV* ref causes confusion with the interpreter variable of
1491 SV* tmpRef=SvRV(left);
1492 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1494 * Just to be extra cautious. Maybe in some
1495 * additional cases sv_setsv is safe, too.
1497 SV* newref = newSVsv(tmpRef);
1498 SvOBJECT_on(newref);
1499 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1505 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1506 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1507 SV* nullsv=sv_2mortal(newSViv(0));
1509 SV* lessp = amagic_call(left,nullsv,
1510 lt_amg,AMGf_noright);
1511 logic = SvTRUE(lessp);
1513 SV* lessp = amagic_call(left,nullsv,
1514 ncmp_amg,AMGf_noright);
1515 logic = (SvNV(lessp) < 0);
1518 if (off==subtr_amg) {
1529 if ((cv = cvp[off=subtr_amg])) {
1531 left = sv_2mortal(newSViv(0));
1536 case iter_amg: /* XXXX Eventually should do to_gv. */
1538 return NULL; /* Delegate operation to standard mechanisms. */
1546 return left; /* Delegate operation to standard mechanisms. */
1551 if (!cv) goto not_found;
1552 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1553 && (stash = SvSTASH(SvRV(right)))
1554 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1555 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1556 ? (amtp = (AMT*)mg->mg_ptr)->table
1558 && (cv = cvp[off=method])) { /* Method for right
1561 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1562 && (cvp=ocvp) && (lr = -1))
1563 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1564 && !(flags & AMGf_unary)) {
1565 /* We look for substitution for
1566 * comparison operations and
1568 if (method==concat_amg || method==concat_ass_amg
1569 || method==repeat_amg || method==repeat_ass_amg) {
1570 return NULL; /* Delegate operation to string conversion */
1580 postpr = 1; off=ncmp_amg; break;
1587 postpr = 1; off=scmp_amg; break;
1589 if (off != -1) cv = cvp[off];
1594 not_found: /* No method found, either report or croak */
1602 return left; /* Delegate operation to standard mechanisms. */
1605 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1606 notfound = 1; lr = -1;
1607 } else if (cvp && (cv=cvp[nomethod_amg])) {
1608 notfound = 1; lr = 1;
1611 if (off==-1) off=method;
1612 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1613 "Operation `%s': no method found,%sargument %s%s%s%s",
1614 AMG_id2name(method + assignshift),
1615 (flags & AMGf_unary ? " " : "\n\tleft "),
1617 "in overloaded package ":
1618 "has no overloaded magic",
1620 HvNAME(SvSTASH(SvRV(left))):
1623 ",\n\tright argument in overloaded package ":
1626 : ",\n\tright argument has no overloaded magic"),
1628 HvNAME(SvSTASH(SvRV(right))):
1630 if (amtp && amtp->fallback >= AMGfallYES) {
1631 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1633 Perl_croak(aTHX_ "%"SVf, msg);
1637 force_cpy = force_cpy || assign;
1642 DEBUG_o(Perl_deb(aTHX_
1643 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1645 method+assignshift==off? "" :
1647 method+assignshift==off? "" :
1648 AMG_id2name(method+assignshift),
1649 method+assignshift==off? "" : "')",
1650 flags & AMGf_unary? "" :
1651 lr==1 ? " for right argument": " for left argument",
1652 flags & AMGf_unary? " for argument" : "",
1653 stash ? HvNAME(stash) : "null",
1654 fl? ",\n\tassignment variant used": "") );
1657 /* Since we use shallow copy during assignment, we need
1658 * to dublicate the contents, probably calling user-supplied
1659 * version of copy operator
1661 /* We need to copy in following cases:
1662 * a) Assignment form was called.
1663 * assignshift==1, assign==T, method + 1 == off
1664 * b) Increment or decrement, called directly.
1665 * assignshift==0, assign==0, method + 0 == off
1666 * c) Increment or decrement, translated to assignment add/subtr.
1667 * assignshift==0, assign==T,
1669 * d) Increment or decrement, translated to nomethod.
1670 * assignshift==0, assign==0,
1672 * e) Assignment form translated to nomethod.
1673 * assignshift==1, assign==T, method + 1 != off
1676 /* off is method, method+assignshift, or a result of opcode substitution.
1677 * In the latter case assignshift==0, so only notfound case is important.
1679 if (( (method + assignshift == off)
1680 && (assign || (method == inc_amg) || (method == dec_amg)))
1687 bool oldcatch = CATCH_GET;
1690 Zero(&myop, 1, BINOP);
1691 myop.op_last = (OP *) &myop;
1692 myop.op_next = Nullop;
1693 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1695 PUSHSTACKi(PERLSI_OVERLOAD);
1698 PL_op = (OP *) &myop;
1699 if (PERLDB_SUB && PL_curstash != PL_debstash)
1700 PL_op->op_private |= OPpENTERSUB_DB;
1704 EXTEND(SP, notfound + 5);
1705 PUSHs(lr>0? right: left);
1706 PUSHs(lr>0? left: right);
1707 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1709 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1714 if ((PL_op = Perl_pp_entersub(aTHX)))
1722 CATCH_SET(oldcatch);
1729 ans=SvIV(res)<=0; break;
1732 ans=SvIV(res)<0; break;
1735 ans=SvIV(res)>=0; break;
1738 ans=SvIV(res)>0; break;
1741 ans=SvIV(res)==0; break;
1744 ans=SvIV(res)!=0; break;
1747 SvSetSV(left,res); return left;
1749 ans=!SvTRUE(res); break;
1752 } else if (method==copy_amg) {
1754 Perl_croak(aTHX_ "Copy method did not return a reference");
1756 return SvREFCNT_inc(SvRV(res));
1764 =for apidoc is_gv_magical
1766 Returns C<TRUE> if given the name of a magical GV.
1768 Currently only useful internally when determining if a GV should be
1769 created even in rvalue contexts.
1771 C<flags> is not used at present but available for future extension to
1772 allow selecting particular classes of magical variable.
1777 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1784 if (len == 3 && strEQ(name, "ISA"))
1788 if (len == 8 && strEQ(name, "OVERLOAD"))
1792 if (len == 3 && strEQ(name, "SIG"))
1795 case '\017': /* $^O & $^OPEN */
1797 || (len == 4 && strEQ(name, "\017PEN")))
1802 case '\027': /* $^W & $^WARNING_BITS */
1804 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1805 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1837 case '\001': /* $^A */
1838 case '\003': /* $^C */
1839 case '\004': /* $^D */
1840 case '\005': /* $^E */
1841 case '\006': /* $^F */
1842 case '\010': /* $^H */
1843 case '\011': /* $^I, NOT \t in EBCDIC */
1844 case '\014': /* $^L */
1845 case '\016': /* $^N */
1846 case '\020': /* $^P */
1847 case '\023': /* $^S */
1848 case '\026': /* $^V */
1852 case '\024': /* $^T, ${^TAINT} */
1853 if (len == 1 || strEQ(name, "\024AINT"))
1866 char *end = name + len;
1867 while (--end > name) {