3 * Copyright (c) 1991-2003, 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 %"SVf" for @%s::ISA",
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;
406 if (stash && SvTYPE(stash) < SVt_PVHV)
409 for (nend = name; *nend; nend++) {
412 else if (*nend == ':' && *(nend + 1) == ':')
416 const char *origname = name;
420 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
421 /* ->SUPER::method should really be looked up in original stash */
422 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
423 CopSTASHPV(PL_curcop)));
424 /* __PACKAGE__::SUPER stash should be autovivified */
425 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
426 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
427 origname, HvNAME(stash), name) );
430 /* don't autovifify if ->NoSuchStash::method */
431 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
433 /* however, explicit calls to Pkg::SUPER::method may
434 happen, and may require autovivification to work */
435 if (!stash && (nsplit - origname) >= 7 &&
436 strnEQ(nsplit - 7, "::SUPER", 7) &&
437 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
438 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
443 gv = gv_fetchmeth(stash, name, nend - name, 0);
445 if (strEQ(name,"import") || strEQ(name,"unimport"))
446 gv = (GV*)&PL_sv_yes;
448 gv = gv_autoload4(ostash, name, nend - name, TRUE);
452 if (!CvROOT(cv) && !CvXSUB(cv)) {
460 if (GvCV(stubgv) != cv) /* orphaned import */
463 autogv = gv_autoload4(GvSTASH(stubgv),
464 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
474 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
476 char autoload[] = "AUTOLOAD";
477 STRLEN autolen = sizeof(autoload)-1;
485 if (len == autolen && strnEQ(name, autoload, autolen))
488 if (SvTYPE(stash) < SVt_PVHV) {
489 packname = SvPV_nolen((SV*)stash);
493 packname = HvNAME(stash);
496 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
500 if (!(CvROOT(cv) || CvXSUB(cv)))
504 * Inheriting AUTOLOAD for non-methods works ... for now.
506 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
507 (GvCVGEN(gv) || GvSTASH(gv) != stash))
508 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
509 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
510 packname, (int)len, name);
512 #ifndef USE_5005THREADS
514 /* rather than lookup/init $AUTOLOAD here
515 * only to have the XSUB do another lookup for $AUTOLOAD
516 * and split that value on the last '::',
517 * pass along the same data via some unused fields in the CV
520 SvPVX(cv) = (char *)name; /* cast to lose constness warning */
527 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
528 * The subroutine's original name may not be "AUTOLOAD", so we don't
529 * use that, but for lack of anything better we will use the sub's
530 * original package to look up $AUTOLOAD.
532 varstash = GvSTASH(CvGV(cv));
533 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
536 #ifdef USE_5005THREADS
537 sv_lock((SV *)varstash);
540 gv_init(vargv, varstash, autoload, autolen, FALSE);
543 #ifdef USE_5005THREADS
546 sv_setpv(varsv, packname);
547 sv_catpvn(varsv, "::", 2);
548 sv_catpvn(varsv, name, len);
549 SvTAINTED_off(varsv);
553 /* The "gv" parameter should be the glob known to Perl code as *!
554 * The scalar must already have been magicalized.
557 S_require_errno(pTHX_ GV *gv)
559 HV* stash = gv_stashpvn("Errno",5,FALSE);
561 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
565 save_scalar(gv); /* keep the value of $! */
566 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
567 newSVpvn("Errno",5), Nullsv);
570 stash = gv_stashpvn("Errno",5,FALSE);
571 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
572 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
577 =for apidoc gv_stashpv
579 Returns a pointer to the stash for a specified package. C<name> should
580 be a valid UTF-8 string. If C<create> is set then the package will be
581 created if it does not already exist. If C<create> is not set and the
582 package does not exist then NULL is returned.
588 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
590 return gv_stashpvn(name, strlen(name), create);
594 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
601 if (namelen + 3 < sizeof smallbuf)
604 New(606, tmpbuf, namelen + 3, char);
605 Copy(name,tmpbuf,namelen,char);
606 tmpbuf[namelen++] = ':';
607 tmpbuf[namelen++] = ':';
608 tmpbuf[namelen] = '\0';
609 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
610 if (tmpbuf != smallbuf)
615 GvHV(tmpgv) = newHV();
618 HvNAME(stash) = savepv(name);
623 =for apidoc gv_stashsv
625 Returns a pointer to the stash for a specified package, which must be a
626 valid UTF-8 string. See C<gv_stashpv>.
632 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
637 return gv_stashpvn(ptr, len, create);
642 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
644 register const char *name = nambeg;
648 register const char *namend;
651 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
654 for (namend = name; *namend; namend++) {
655 if ((*namend == ':' && namend[1] == ':')
656 || (*namend == '\'' && namend[1]))
660 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
668 if (len + 3 < sizeof (smallbuf))
671 New(601, tmpbuf, len+3, char);
672 Copy(name, tmpbuf, len, char);
676 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
677 gv = gvp ? *gvp : Nullgv;
678 if (gv && gv != (GV*)&PL_sv_undef) {
679 if (SvTYPE(gv) != SVt_PVGV)
680 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
684 if (tmpbuf != smallbuf)
686 if (!gv || gv == (GV*)&PL_sv_undef)
689 if (!(stash = GvHV(gv)))
690 stash = GvHV(gv) = newHV();
693 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
701 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
708 /* No stash in name, so see how we can default */
711 if (isIDFIRST_lazy(name)) {
714 if (isUPPER(*name)) {
715 if (*name == 'S' && (
716 strEQ(name, "SIG") ||
717 strEQ(name, "STDIN") ||
718 strEQ(name, "STDOUT") ||
719 strEQ(name, "STDERR")))
721 else if (*name == 'I' && strEQ(name, "INC"))
723 else if (*name == 'E' && strEQ(name, "ENV"))
725 else if (*name == 'A' && (
726 strEQ(name, "ARGV") ||
727 strEQ(name, "ARGVOUT")))
730 else if (*name == '_' && !name[1])
735 else if ((COP*)PL_curcop == &PL_compiling) {
737 if (add && (PL_hints & HINT_STRICT_VARS) &&
738 sv_type != SVt_PVCV &&
739 sv_type != SVt_PVGV &&
740 sv_type != SVt_PVFM &&
741 sv_type != SVt_PVIO &&
742 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
744 gvp = (GV**)hv_fetch(stash,name,len,0);
746 *gvp == (GV*)&PL_sv_undef ||
747 SvTYPE(*gvp) != SVt_PVGV)
751 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
752 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
753 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
755 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
756 sv_type == SVt_PVAV ? '@' :
757 sv_type == SVt_PVHV ? '%' : '$',
760 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
766 stash = CopSTASH(PL_curcop);
772 /* By this point we should have a stash and a name */
776 qerror(Perl_mess(aTHX_
777 "Global symbol \"%s%s\" requires explicit package name",
778 (sv_type == SVt_PV ? "$"
779 : sv_type == SVt_PVAV ? "@"
780 : sv_type == SVt_PVHV ? "%"
782 stash = PL_nullstash;
788 if (!SvREFCNT(stash)) /* symbol table under destruction */
791 gvp = (GV**)hv_fetch(stash,name,len,add);
792 if (!gvp || *gvp == (GV*)&PL_sv_undef)
795 if (SvTYPE(gv) == SVt_PVGV) {
798 gv_init_sv(gv, sv_type);
799 if (*name=='!' && sv_type == SVt_PVHV && len==1)
803 } else if (add & GV_NOINIT) {
807 /* Adding a new symbol */
809 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
810 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
811 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
812 gv_init_sv(gv, sv_type);
814 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
815 : (PL_dowarn & G_WARN_ON ) ) )
818 /* set up magic where warranted */
821 if (strEQ(name, "ARGV")) {
822 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
826 if (strnEQ(name, "EXPORT", 6))
830 if (strEQ(name, "ISA")) {
833 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
834 /* NOTE: No support for tied ISA */
835 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
836 && AvFILLp(av) == -1)
839 av_push(av, newSVpvn(pname = "NDBM_File",9));
840 gv_stashpvn(pname, 9, TRUE);
841 av_push(av, newSVpvn(pname = "DB_File",7));
842 gv_stashpvn(pname, 7, TRUE);
843 av_push(av, newSVpvn(pname = "GDBM_File",9));
844 gv_stashpvn(pname, 9, TRUE);
845 av_push(av, newSVpvn(pname = "SDBM_File",9));
846 gv_stashpvn(pname, 9, TRUE);
847 av_push(av, newSVpvn(pname = "ODBM_File",9));
848 gv_stashpvn(pname, 9, TRUE);
853 if (strEQ(name, "OVERLOAD")) {
856 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
860 if (strEQ(name, "SIG")) {
864 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
865 Newz(73, PL_psig_name, SIG_SIZE, SV*);
866 Newz(73, PL_psig_pend, SIG_SIZE, int);
870 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
871 for (i = 1; i < SIG_SIZE; i++) {
873 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
875 sv_setsv(*init, &PL_sv_undef);
883 if (strEQ(name, "VERSION"))
892 sv_type == SVt_PVAV ||
893 sv_type == SVt_PVHV ||
894 sv_type == SVt_PVCV ||
895 sv_type == SVt_PVFM ||
898 PL_sawampersand = TRUE;
904 sv_setpv(GvSV(gv),PL_chopset);
910 #ifdef COMPLEX_STATUS
911 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
919 /* If %! has been used, automatically load Errno.pm.
920 The require will itself set errno, so in order to
921 preserve its value we have to set up the magic
922 now (rather than going to magicalize)
925 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
927 if (sv_type == SVt_PVHV)
936 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
942 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
943 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
958 case '\001': /* $^A */
959 case '\003': /* $^C */
960 case '\004': /* $^D */
961 case '\006': /* $^F */
962 case '\010': /* $^H */
963 case '\011': /* $^I, NOT \t in EBCDIC */
964 case '\016': /* $^N */
965 case '\020': /* $^P */
972 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
974 case '\005': /* $^E && $^ENCODING */
975 if (len > 1 && strNE(name, "\005NCODING"))
979 case '\017': /* $^O & $^OPEN */
980 if (len > 1 && strNE(name, "\017PEN"))
983 case '\023': /* $^S */
987 case '\024': /* $^T, ${^TAINT} */
990 else if (strEQ(name, "\024AINT"))
995 if (len > 1 && strNE(name, "\025NICODE"))
999 case '\027': /* $^W & $^WARNING_BITS */
1001 && strNE(name, "\027ARNING_BITS")
1011 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1024 /* ensures variable is only digits */
1025 /* ${"1foo"} fails this test (and is thus writeable) */
1026 /* added by japhy, but borrowed from is_gv_magical */
1029 const char *end = name + len;
1030 while (--end > name) {
1031 if (!isDIGIT(*end)) return gv;
1036 SvREADONLY_on(GvSV(gv));
1038 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1041 case '\014': /* $^L */
1044 sv_setpv(GvSV(gv),"\f");
1045 PL_formfeed = GvSV(gv);
1050 sv_setpv(GvSV(gv),"\034");
1055 (void)SvUPGRADE(sv, SVt_PVNV);
1056 Perl_sv_setpvf(aTHX_ sv,
1057 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1063 SvNVX(PL_patchlevel));
1064 SvNVX(sv) = SvNVX(PL_patchlevel);
1069 case '\026': /* $^V */
1072 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1081 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1083 HV *hv = GvSTASH(gv);
1088 sv_setpv(sv, prefix ? prefix : "");
1089 if (keepmain || strNE(HvNAME(hv), "main")) {
1090 sv_catpv(sv,HvNAME(hv));
1091 sv_catpvn(sv,"::", 2);
1093 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1097 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1099 gv_fullname4(sv, gv, prefix, TRUE);
1103 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1105 GV *egv = GvEGV(gv);
1108 gv_fullname4(sv, egv, prefix, keepmain);
1112 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1114 gv_efullname4(sv, gv, prefix, TRUE);
1117 /* XXX compatibility with versions <= 5.003. */
1119 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1121 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1124 /* XXX compatibility with versions <= 5.003. */
1126 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1128 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1137 io = (IO*)NEWSV(0,0);
1138 sv_upgrade((SV *)io,SVt_PVIO);
1141 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1142 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1143 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1144 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1145 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1150 Perl_gv_check(pTHX_ HV *stash)
1157 if (!HvARRAY(stash))
1159 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1160 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1161 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1162 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
1164 if (hv != PL_defstash && hv != stash)
1165 gv_check(hv); /* nested package */
1167 else if (isALPHA(*HeKEY(entry))) {
1169 gv = (GV*)HeVAL(entry);
1170 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1173 /* performance hack: if filename is absolute and it's a standard
1174 * module, don't bother warning */
1176 && PERL_FILE_IS_ABSOLUTE(file)
1177 #ifdef MACOS_TRADITIONAL
1178 && (instr(file, ":lib:")
1180 && (instr(file, "/lib/")
1182 || instr(file, ".pm")))
1186 CopLINE_set(PL_curcop, GvLINE(gv));
1188 CopFILE(PL_curcop) = file; /* set for warning */
1190 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1192 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1193 "Name \"%s::%s\" used only once: possible typo",
1194 HvNAME(stash), GvNAME(gv));
1201 Perl_newGVgen(pTHX_ char *pack)
1203 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1207 /* hopefully this is only called on local symbol table entries */
1210 Perl_gp_ref(pTHX_ GP *gp)
1217 /* multi-named GPs cannot be used for method cache */
1218 SvREFCNT_dec(gp->gp_cv);
1223 /* Adding a new name to a subroutine invalidates method cache */
1224 PL_sub_generation++;
1231 Perl_gp_free(pTHX_ GV *gv)
1235 if (!gv || !(gp = GvGP(gv)))
1237 if (gp->gp_refcnt == 0) {
1238 if (ckWARN_d(WARN_INTERNAL))
1239 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1240 "Attempt to free unreferenced glob pointers");
1244 /* Deleting the name of a subroutine invalidates method cache */
1245 PL_sub_generation++;
1247 if (--gp->gp_refcnt > 0) {
1248 if (gp->gp_egv == gv)
1253 SvREFCNT_dec(gp->gp_sv);
1254 SvREFCNT_dec(gp->gp_av);
1255 SvREFCNT_dec(gp->gp_hv);
1256 SvREFCNT_dec(gp->gp_io);
1257 SvREFCNT_dec(gp->gp_cv);
1258 SvREFCNT_dec(gp->gp_form);
1265 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1267 AMT *amtp = (AMT*)mg->mg_ptr;
1268 if (amtp && AMT_AMAGIC(amtp)) {
1270 for (i = 1; i < NofAMmeth; i++) {
1271 CV *cv = amtp->table[i];
1273 SvREFCNT_dec((SV *) cv);
1274 amtp->table[i] = Nullcv;
1281 /* Updates and caches the CV's */
1284 Perl_Gv_AMupdate(pTHX_ HV *stash)
1288 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1289 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1292 if (mg && amtp->was_ok_am == PL_amagic_generation
1293 && amtp->was_ok_sub == PL_sub_generation)
1294 return (bool)AMT_OVERLOADED(amtp);
1295 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1297 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1300 amt.was_ok_am = PL_amagic_generation;
1301 amt.was_ok_sub = PL_sub_generation;
1302 amt.fallback = AMGfallNO;
1306 int filled = 0, have_ovl = 0;
1310 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1312 /* Try to find via inheritance. */
1313 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1318 lim = DESTROY_amg; /* Skip overloading entries. */
1319 else if (SvTRUE(sv))
1320 amt.fallback=AMGfallYES;
1322 amt.fallback=AMGfallNEVER;
1324 for (i = 1; i < lim; i++)
1325 amt.table[i] = Nullcv;
1326 for (; i < NofAMmeth; i++) {
1327 char *cooky = (char*)PL_AMG_names[i];
1328 /* Human-readable form, for debugging: */
1329 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1330 STRLEN l = strlen(cooky);
1332 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1333 cp, HvNAME(stash)) );
1334 /* don't fill the cache while looking up!
1335 Creation of inheritance stubs in intermediate packages may
1336 conflict with the logic of runtime method substitution.
1337 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1338 then we could have created stubs for "(+0" in A and C too.
1339 But if B overloads "bool", we may want to use it for
1340 numifying instead of C's "+0". */
1341 if (i >= DESTROY_amg)
1342 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1343 else /* Autoload taken care of below */
1344 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1346 if (gv && (cv = GvCV(gv))) {
1347 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1348 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1349 /* This is a hack to support autoloading..., while
1350 knowing *which* methods were declared as overloaded. */
1351 /* GvSV contains the name of the method. */
1354 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256"SVf"' for overloaded `%s' in package `%.256s'\n",
1355 GvSV(gv), cp, HvNAME(stash)) );
1356 if (!SvPOK(GvSV(gv))
1357 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1360 /* Can be an import stub (created by `can'). */
1361 SV *gvsv = GvSV(gv);
1362 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
1363 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' in package `%.256s'",
1364 (GvCVGEN(gv) ? "Stub found while resolving"
1366 name, cp, HvNAME(stash));
1368 cv = GvCV(gv = ngv);
1370 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1371 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1372 GvNAME(CvGV(cv))) );
1374 if (i < DESTROY_amg)
1376 } else if (gv) { /* Autoloaded... */
1380 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1383 AMT_AMAGIC_on(&amt);
1385 AMT_OVERLOADED_on(&amt);
1386 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1387 (char*)&amt, sizeof(AMT));
1391 /* Here we have no table: */
1393 AMT_AMAGIC_off(&amt);
1394 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1395 (char*)&amt, sizeof(AMTS));
1401 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1409 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1413 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1415 amtp = (AMT*)mg->mg_ptr;
1416 if ( amtp->was_ok_am != PL_amagic_generation
1417 || amtp->was_ok_sub != PL_sub_generation )
1419 if (AMT_AMAGIC(amtp)) {
1420 ret = amtp->table[id];
1421 if (ret && isGV(ret)) { /* Autoloading stab */
1422 /* Passing it through may have resulted in a warning
1423 "Inherited AUTOLOAD for a non-method deprecated", since
1424 our caller is going through a function call, not a method call.
1425 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1426 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1439 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1443 CV **cvp=NULL, **ocvp=NULL;
1444 AMT *amtp=NULL, *oamtp=NULL;
1445 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1446 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1451 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1452 && (stash = SvSTASH(SvRV(left)))
1453 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1454 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1455 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1457 && ((cv = cvp[off=method+assignshift])
1458 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1464 cv = cvp[off=method])))) {
1465 lr = -1; /* Call method for left argument */
1467 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1470 /* look for substituted methods */
1471 /* In all the covered cases we should be called with assign==0. */
1475 if ((cv = cvp[off=add_ass_amg])
1476 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1477 right = &PL_sv_yes; lr = -1; assign = 1;
1482 if ((cv = cvp[off = subtr_ass_amg])
1483 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1484 right = &PL_sv_yes; lr = -1; assign = 1;
1488 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1491 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1494 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1497 (void)((cv = cvp[off=bool__amg])
1498 || (cv = cvp[off=numer_amg])
1499 || (cv = cvp[off=string_amg]));
1505 * SV* ref causes confusion with the interpreter variable of
1508 SV* tmpRef=SvRV(left);
1509 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1511 * Just to be extra cautious. Maybe in some
1512 * additional cases sv_setsv is safe, too.
1514 SV* newref = newSVsv(tmpRef);
1515 SvOBJECT_on(newref);
1516 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1522 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1523 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1524 SV* nullsv=sv_2mortal(newSViv(0));
1526 SV* lessp = amagic_call(left,nullsv,
1527 lt_amg,AMGf_noright);
1528 logic = SvTRUE(lessp);
1530 SV* lessp = amagic_call(left,nullsv,
1531 ncmp_amg,AMGf_noright);
1532 logic = (SvNV(lessp) < 0);
1535 if (off==subtr_amg) {
1546 if ((cv = cvp[off=subtr_amg])) {
1548 left = sv_2mortal(newSViv(0));
1553 case iter_amg: /* XXXX Eventually should do to_gv. */
1555 return NULL; /* Delegate operation to standard mechanisms. */
1563 return left; /* Delegate operation to standard mechanisms. */
1568 if (!cv) goto not_found;
1569 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1570 && (stash = SvSTASH(SvRV(right)))
1571 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1572 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1573 ? (amtp = (AMT*)mg->mg_ptr)->table
1575 && (cv = cvp[off=method])) { /* Method for right
1578 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1579 && (cvp=ocvp) && (lr = -1))
1580 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1581 && !(flags & AMGf_unary)) {
1582 /* We look for substitution for
1583 * comparison operations and
1585 if (method==concat_amg || method==concat_ass_amg
1586 || method==repeat_amg || method==repeat_ass_amg) {
1587 return NULL; /* Delegate operation to string conversion */
1597 postpr = 1; off=ncmp_amg; break;
1604 postpr = 1; off=scmp_amg; break;
1606 if (off != -1) cv = cvp[off];
1611 not_found: /* No method found, either report or croak */
1619 return left; /* Delegate operation to standard mechanisms. */
1622 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1623 notfound = 1; lr = -1;
1624 } else if (cvp && (cv=cvp[nomethod_amg])) {
1625 notfound = 1; lr = 1;
1628 if (off==-1) off=method;
1629 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1630 "Operation `%s': no method found,%sargument %s%s%s%s",
1631 AMG_id2name(method + assignshift),
1632 (flags & AMGf_unary ? " " : "\n\tleft "),
1634 "in overloaded package ":
1635 "has no overloaded magic",
1637 HvNAME(SvSTASH(SvRV(left))):
1640 ",\n\tright argument in overloaded package ":
1643 : ",\n\tright argument has no overloaded magic"),
1645 HvNAME(SvSTASH(SvRV(right))):
1647 if (amtp && amtp->fallback >= AMGfallYES) {
1648 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1650 Perl_croak(aTHX_ "%"SVf, msg);
1654 force_cpy = force_cpy || assign;
1659 DEBUG_o(Perl_deb(aTHX_
1660 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1662 method+assignshift==off? "" :
1664 method+assignshift==off? "" :
1665 AMG_id2name(method+assignshift),
1666 method+assignshift==off? "" : "')",
1667 flags & AMGf_unary? "" :
1668 lr==1 ? " for right argument": " for left argument",
1669 flags & AMGf_unary? " for argument" : "",
1670 stash ? HvNAME(stash) : "null",
1671 fl? ",\n\tassignment variant used": "") );
1674 /* Since we use shallow copy during assignment, we need
1675 * to dublicate the contents, probably calling user-supplied
1676 * version of copy operator
1678 /* We need to copy in following cases:
1679 * a) Assignment form was called.
1680 * assignshift==1, assign==T, method + 1 == off
1681 * b) Increment or decrement, called directly.
1682 * assignshift==0, assign==0, method + 0 == off
1683 * c) Increment or decrement, translated to assignment add/subtr.
1684 * assignshift==0, assign==T,
1686 * d) Increment or decrement, translated to nomethod.
1687 * assignshift==0, assign==0,
1689 * e) Assignment form translated to nomethod.
1690 * assignshift==1, assign==T, method + 1 != off
1693 /* off is method, method+assignshift, or a result of opcode substitution.
1694 * In the latter case assignshift==0, so only notfound case is important.
1696 if (( (method + assignshift == off)
1697 && (assign || (method == inc_amg) || (method == dec_amg)))
1704 bool oldcatch = CATCH_GET;
1707 Zero(&myop, 1, BINOP);
1708 myop.op_last = (OP *) &myop;
1709 myop.op_next = Nullop;
1710 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1712 PUSHSTACKi(PERLSI_OVERLOAD);
1715 PL_op = (OP *) &myop;
1716 if (PERLDB_SUB && PL_curstash != PL_debstash)
1717 PL_op->op_private |= OPpENTERSUB_DB;
1721 EXTEND(SP, notfound + 5);
1722 PUSHs(lr>0? right: left);
1723 PUSHs(lr>0? left: right);
1724 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1726 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1731 if ((PL_op = Perl_pp_entersub(aTHX)))
1739 CATCH_SET(oldcatch);
1746 ans=SvIV(res)<=0; break;
1749 ans=SvIV(res)<0; break;
1752 ans=SvIV(res)>=0; break;
1755 ans=SvIV(res)>0; break;
1758 ans=SvIV(res)==0; break;
1761 ans=SvIV(res)!=0; break;
1764 SvSetSV(left,res); return left;
1766 ans=!SvTRUE(res); break;
1769 } else if (method==copy_amg) {
1771 Perl_croak(aTHX_ "Copy method did not return a reference");
1773 return SvREFCNT_inc(SvRV(res));
1781 =for apidoc is_gv_magical
1783 Returns C<TRUE> if given the name of a magical GV.
1785 Currently only useful internally when determining if a GV should be
1786 created even in rvalue contexts.
1788 C<flags> is not used at present but available for future extension to
1789 allow selecting particular classes of magical variable.
1794 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1801 if (len == 3 && strEQ(name, "ISA"))
1805 if (len == 8 && strEQ(name, "OVERLOAD"))
1809 if (len == 3 && strEQ(name, "SIG"))
1812 case '\017': /* $^O & $^OPEN */
1814 || (len == 4 && strEQ(name, "\017PEN")))
1820 if (len > 1 && strEQ(name, "\025NICODE"))
1822 case '\027': /* $^W & $^WARNING_BITS */
1824 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1857 case '\001': /* $^A */
1858 case '\003': /* $^C */
1859 case '\004': /* $^D */
1860 case '\005': /* $^E */
1861 case '\006': /* $^F */
1862 case '\010': /* $^H */
1863 case '\011': /* $^I, NOT \t in EBCDIC */
1864 case '\014': /* $^L */
1865 case '\016': /* $^N */
1866 case '\020': /* $^P */
1867 case '\023': /* $^S */
1868 case '\026': /* $^V */
1872 case '\024': /* $^T, ${^TAINT} */
1873 if (len == 1 || strEQ(name, "\024AINT"))
1886 char *end = name + len;
1887 while (--end > name) {