3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
13 * of your inquisitiveness, I shall spend all the rest of my days answering
14 * you. What more do you want to know?'
15 * 'The names of all the stars, and of all living things, and the whole
16 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
29 Perl_gv_AVadd(pTHX_ register GV *gv)
31 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
32 Perl_croak(aTHX_ "Bad symbol for array");
39 Perl_gv_HVadd(pTHX_ register GV *gv)
41 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
42 Perl_croak(aTHX_ "Bad symbol for hash");
49 Perl_gv_IOadd(pTHX_ register GV *gv)
51 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
52 Perl_croak(aTHX_ "Bad symbol for filehandle");
54 #ifdef GV_UNIQUE_CHECK
56 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
65 Perl_gv_fetchfile(pTHX_ const char *name)
75 tmplen = strlen(name) + 2;
76 if (tmplen < sizeof smallbuf)
79 New(603, tmpbuf, tmplen + 1, char);
80 /* This is where the debugger's %{"::_<$filename"} hash is created */
83 strcpy(tmpbuf + 2, name);
84 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
86 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
87 sv_setpv(GvSV(gv), name);
89 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
91 if (tmpbuf != smallbuf)
97 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
100 bool doproto = SvTYPE(gv) > SVt_NULL;
101 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
103 sv_upgrade((SV*)gv, SVt_PVGV);
112 Newz(602, gp, 1, GP);
113 GvGP(gv) = gp_ref(gp);
114 GvSV(gv) = NEWSV(72,0);
115 GvLINE(gv) = CopLINE(PL_curcop);
116 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
119 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
120 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
121 GvNAME(gv) = savepvn(name, len);
123 if (multi || doproto) /* doproto means it _was_ mentioned */
125 if (doproto) { /* Replicate part of newSUB here. */
128 /* XXX unsafe for threads if eval_owner isn't held */
129 start_subparse(0,0); /* Create CV in compcv. */
130 GvCV(gv) = PL_compcv;
135 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
136 CvSTASH(GvCV(gv)) = PL_curstash;
138 sv_setpv((SV*)GvCV(gv), proto);
145 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
161 =for apidoc gv_fetchmeth
163 Returns the glob with the given C<name> and a defined subroutine or
164 C<NULL>. The glob lives in the given C<stash>, or in the stashes
165 accessible via @ISA and UNIVERSAL::.
167 The argument C<level> should be either 0 or -1. If C<level==0>, as a
168 side-effect creates a glob with the given C<name> in the given C<stash>
169 which in the case of success contains an alias for the subroutine, and sets
170 up caching info for this glob. Similarly for all the searched stashes.
172 This function grants C<"SUPER"> token as a postfix of the stash name. The
173 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
174 visible to Perl code. So when calling C<call_sv>, you should not use
175 the GV directly; instead, you should use the method's CV, which can be
176 obtained from the GV with the C<GvCV> macro.
182 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
190 /* UNIVERSAL methods should be callable without a stash */
192 level = -1; /* probably appropriate */
193 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
199 "Can't use anonymous symbol table for method lookup");
201 if ((level > 100) || (level < -100))
202 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
203 name, HvNAME(stash));
205 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
207 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
212 if (SvTYPE(topgv) != SVt_PVGV)
213 gv_init(topgv, stash, name, len, TRUE);
214 if ((cv = GvCV(topgv))) {
215 /* If genuine method or valid cache entry, use it */
216 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
218 /* Stale cached entry: junk it */
220 GvCV(topgv) = cv = Nullcv;
223 else if (GvCVGEN(topgv) == PL_sub_generation)
224 return 0; /* cache indicates sub doesn't exist */
227 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
228 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
230 /* create and re-create @.*::SUPER::ISA on demand */
231 if (!av || !SvMAGIC(av)) {
232 char* packname = HvNAME(stash);
233 STRLEN packlen = strlen(packname);
235 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
239 basestash = gv_stashpvn(packname, packlen, TRUE);
240 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
241 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
242 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
243 if (!gvp || !(gv = *gvp))
244 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
245 if (SvTYPE(gv) != SVt_PVGV)
246 gv_init(gv, stash, "ISA", 3, TRUE);
247 SvREFCNT_dec(GvAV(gv));
248 GvAV(gv) = (AV*)SvREFCNT_inc(av);
254 SV** svp = AvARRAY(av);
255 /* NOTE: No support for tied ISA */
256 I32 items = AvFILLp(av) + 1;
259 HV* basestash = gv_stashsv(sv, FALSE);
261 if (ckWARN(WARN_MISC))
262 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
266 gv = gv_fetchmeth(basestash, name, len,
267 (level >= 0) ? level + 1 : level - 1);
273 /* if at top level, try UNIVERSAL */
275 if (level == 0 || level == -1) {
278 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
279 if ((gv = gv_fetchmeth(lastchance, name, len,
280 (level >= 0) ? level + 1 : level - 1)))
284 * Cache method in topgv if:
285 * 1. topgv has no synonyms (else inheritance crosses wires)
286 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
289 GvREFCNT(topgv) == 1 &&
291 (CvROOT(cv) || CvXSUB(cv)))
293 if ((cv = GvCV(topgv)))
295 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
296 GvCVGEN(topgv) = PL_sub_generation;
300 else if (topgv && GvREFCNT(topgv) == 1) {
301 /* cache the fact that the method is not defined */
302 GvCVGEN(topgv) = PL_sub_generation;
311 =for apidoc gv_fetchmeth_autoload
313 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
314 Returns a glob for the subroutine.
316 For an autoloaded subroutine without a GV, will create a GV even
317 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
318 of the result may be zero.
324 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
326 GV *gv = gv_fetchmeth(stash, name, len, level);
329 char autoload[] = "AUTOLOAD";
330 STRLEN autolen = sizeof(autoload)-1;
335 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
336 if (len == autolen && strnEQ(name, autoload, autolen))
338 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
341 if (!(CvROOT(cv) || CvXSUB(cv)))
343 /* Have an autoload */
344 if (level < 0) /* Cannot do without a stub */
345 gv_fetchmeth(stash, name, len, 0);
346 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
355 =for apidoc gv_fetchmethod
357 See L<gv_fetchmethod_autoload>.
363 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
365 return gv_fetchmethod_autoload(stash, name, TRUE);
369 =for apidoc gv_fetchmethod_autoload
371 Returns the glob which contains the subroutine to call to invoke the method
372 on the C<stash>. In fact in the presence of autoloading this may be the
373 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
376 The third parameter of C<gv_fetchmethod_autoload> determines whether
377 AUTOLOAD lookup is performed if the given method is not present: non-zero
378 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
379 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
380 with a non-zero C<autoload> parameter.
382 These functions grant C<"SUPER"> token as a prefix of the method name. Note
383 that if you want to keep the returned glob for a long time, you need to
384 check for it being "AUTOLOAD", since at the later time the call may load a
385 different subroutine due to $AUTOLOAD changing its value. Use the glob
386 created via a side effect to do this.
388 These functions have the same side-effects and as C<gv_fetchmeth> with
389 C<level==0>. C<name> should be writable if contains C<':'> or C<'
390 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
391 C<call_sv> apply equally to these functions.
397 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
399 register const char *nend;
400 const char *nsplit = 0;
404 if (stash && SvTYPE(stash) < SVt_PVHV)
407 for (nend = name; *nend; nend++) {
410 else if (*nend == ':' && *(nend + 1) == ':')
414 const char *origname = name;
418 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
419 /* ->SUPER::method should really be looked up in original stash */
420 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
421 CopSTASHPV(PL_curcop)));
422 /* __PACKAGE__::SUPER stash should be autovivified */
423 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
424 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
425 origname, HvNAME(stash), name) );
428 /* don't autovifify if ->NoSuchStash::method */
429 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
431 /* however, explicit calls to Pkg::SUPER::method may
432 happen, and may require autovivification to work */
433 if (!stash && (nsplit - origname) >= 7 &&
434 strnEQ(nsplit - 7, "::SUPER", 7) &&
435 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
436 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
441 gv = gv_fetchmeth(stash, name, nend - name, 0);
443 if (strEQ(name,"import") || strEQ(name,"unimport"))
444 gv = (GV*)&PL_sv_yes;
446 gv = gv_autoload4(ostash, name, nend - name, TRUE);
450 if (!CvROOT(cv) && !CvXSUB(cv)) {
458 if (GvCV(stubgv) != cv) /* orphaned import */
461 autogv = gv_autoload4(GvSTASH(stubgv),
462 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
472 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
474 char autoload[] = "AUTOLOAD";
475 STRLEN autolen = sizeof(autoload)-1;
483 if (len == autolen && strnEQ(name, autoload, autolen))
486 if (SvTYPE(stash) < SVt_PVHV) {
487 packname = SvPV_nolen((SV*)stash);
491 packname = HvNAME(stash);
494 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
498 if (!(CvROOT(cv) || CvXSUB(cv)))
502 * Inheriting AUTOLOAD for non-methods works ... for now.
504 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
505 (GvCVGEN(gv) || GvSTASH(gv) != stash))
506 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
507 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
508 packname, (int)len, name);
511 /* rather than lookup/init $AUTOLOAD here
512 * only to have the XSUB do another lookup for $AUTOLOAD
513 * and split that value on the last '::',
514 * pass along the same data via some unused fields in the CV
517 SvPVX(cv) = (char *)name; /* cast to lose constness warning */
523 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
524 * The subroutine's original name may not be "AUTOLOAD", so we don't
525 * use that, but for lack of anything better we will use the sub's
526 * original package to look up $AUTOLOAD.
528 varstash = GvSTASH(CvGV(cv));
529 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
533 gv_init(vargv, varstash, autoload, autolen, FALSE);
536 sv_setpv(varsv, packname);
537 sv_catpvn(varsv, "::", 2);
538 sv_catpvn(varsv, name, len);
539 SvTAINTED_off(varsv);
543 /* The "gv" parameter should be the glob known to Perl code as *!
544 * The scalar must already have been magicalized.
547 S_require_errno(pTHX_ GV *gv)
549 HV* stash = gv_stashpvn("Errno",5,FALSE);
551 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
555 save_scalar(gv); /* keep the value of $! */
556 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
557 newSVpvn("Errno",5), Nullsv);
560 stash = gv_stashpvn("Errno",5,FALSE);
561 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
562 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
567 =for apidoc gv_stashpv
569 Returns a pointer to the stash for a specified package. C<name> should
570 be a valid UTF-8 string. If C<create> is set then the package will be
571 created if it does not already exist. If C<create> is not set and the
572 package does not exist then NULL is returned.
578 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
580 return gv_stashpvn(name, strlen(name), create);
584 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
591 if (namelen + 3 < sizeof smallbuf)
594 New(606, tmpbuf, namelen + 3, char);
595 Copy(name,tmpbuf,namelen,char);
596 tmpbuf[namelen++] = ':';
597 tmpbuf[namelen++] = ':';
598 tmpbuf[namelen] = '\0';
599 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
600 if (tmpbuf != smallbuf)
605 GvHV(tmpgv) = newHV();
608 HvNAME(stash) = savepv(name);
613 =for apidoc gv_stashsv
615 Returns a pointer to the stash for a specified package, which must be a
616 valid UTF-8 string. See C<gv_stashpv>.
622 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
627 return gv_stashpvn(ptr, len, create);
632 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
634 register const char *name = nambeg;
638 register const char *namend;
641 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
644 for (namend = name; *namend; namend++) {
645 if ((*namend == ':' && namend[1] == ':')
646 || (*namend == '\'' && namend[1]))
650 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
658 if (len + 3 < sizeof (smallbuf))
661 New(601, tmpbuf, len+3, char);
662 Copy(name, tmpbuf, len, char);
666 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
667 gv = gvp ? *gvp : Nullgv;
668 if (gv && gv != (GV*)&PL_sv_undef) {
669 if (SvTYPE(gv) != SVt_PVGV)
670 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
674 if (tmpbuf != smallbuf)
676 if (!gv || gv == (GV*)&PL_sv_undef)
679 if (!(stash = GvHV(gv)))
680 stash = GvHV(gv) = newHV();
683 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
691 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
696 /* $_ should always be in main:: even when our'ed */
697 if (*name == '_' && !name[1])
700 /* No stash in name, so see how we can default */
703 if (isIDFIRST_lazy(name)) {
706 if (isUPPER(*name)) {
707 if (*name == 'S' && (
708 strEQ(name, "SIG") ||
709 strEQ(name, "STDIN") ||
710 strEQ(name, "STDOUT") ||
711 strEQ(name, "STDERR")))
713 else if (*name == 'I' && strEQ(name, "INC"))
715 else if (*name == 'E' && strEQ(name, "ENV"))
717 else if (*name == 'A' && (
718 strEQ(name, "ARGV") ||
719 strEQ(name, "ARGVOUT")))
722 else if (*name == '_' && !name[1])
727 else if (IN_PERL_COMPILETIME) {
729 if (add && (PL_hints & HINT_STRICT_VARS) &&
730 sv_type != SVt_PVCV &&
731 sv_type != SVt_PVGV &&
732 sv_type != SVt_PVFM &&
733 sv_type != SVt_PVIO &&
734 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
736 gvp = (GV**)hv_fetch(stash,name,len,0);
738 *gvp == (GV*)&PL_sv_undef ||
739 SvTYPE(*gvp) != SVt_PVGV)
743 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
744 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
745 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
747 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
748 sv_type == SVt_PVAV ? '@' :
749 sv_type == SVt_PVHV ? '%' : '$',
752 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
758 stash = CopSTASH(PL_curcop);
764 /* By this point we should have a stash and a name */
768 register SV *err = Perl_mess(aTHX_
769 "Global symbol \"%s%s\" requires explicit package name",
770 (sv_type == SVt_PV ? "$"
771 : sv_type == SVt_PVAV ? "@"
772 : sv_type == SVt_PVHV ? "%"
774 if (USE_UTF8_IN_NAMES)
777 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
783 if (!SvREFCNT(stash)) /* symbol table under destruction */
786 gvp = (GV**)hv_fetch(stash,name,len,add);
787 if (!gvp || *gvp == (GV*)&PL_sv_undef)
790 if (SvTYPE(gv) == SVt_PVGV) {
793 gv_init_sv(gv, sv_type);
794 if (*name=='!' && sv_type == SVt_PVHV && len==1)
798 } else if (add & GV_NOINIT) {
802 /* Adding a new symbol */
804 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
805 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
806 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
807 gv_init_sv(gv, sv_type);
809 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
810 : (PL_dowarn & G_WARN_ON ) ) )
813 /* set up magic where warranted */
816 if (strEQ(name, "ARGV")) {
817 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
821 if (strnEQ(name, "EXPORT", 6))
825 if (strEQ(name, "ISA")) {
828 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
829 /* NOTE: No support for tied ISA */
830 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
831 && AvFILLp(av) == -1)
834 av_push(av, newSVpvn(pname = "NDBM_File",9));
835 gv_stashpvn(pname, 9, TRUE);
836 av_push(av, newSVpvn(pname = "DB_File",7));
837 gv_stashpvn(pname, 7, TRUE);
838 av_push(av, newSVpvn(pname = "GDBM_File",9));
839 gv_stashpvn(pname, 9, TRUE);
840 av_push(av, newSVpvn(pname = "SDBM_File",9));
841 gv_stashpvn(pname, 9, TRUE);
842 av_push(av, newSVpvn(pname = "ODBM_File",9));
843 gv_stashpvn(pname, 9, TRUE);
848 if (strEQ(name, "OVERLOAD")) {
851 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
855 if (strEQ(name, "SIG")) {
859 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
860 Newz(73, PL_psig_name, SIG_SIZE, SV*);
861 Newz(73, PL_psig_pend, SIG_SIZE, int);
865 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
866 for (i = 1; i < SIG_SIZE; i++) {
868 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
870 sv_setsv(*init, &PL_sv_undef);
878 if (strEQ(name, "VERSION"))
887 sv_type == SVt_PVAV ||
888 sv_type == SVt_PVHV ||
889 sv_type == SVt_PVCV ||
890 sv_type == SVt_PVFM ||
893 PL_sawampersand = TRUE;
899 sv_setpv(GvSV(gv),PL_chopset);
905 #ifdef COMPLEX_STATUS
906 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
914 /* If %! has been used, automatically load Errno.pm.
915 The require will itself set errno, so in order to
916 preserve its value we have to set up the magic
917 now (rather than going to magicalize)
920 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
922 if (sv_type == SVt_PVHV)
931 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
936 if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
937 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
938 "$* is no longer supported");
941 if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
942 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
943 "Use of $# is deprecated");
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)
1084 HV *hv = GvSTASH(gv);
1089 sv_setpv(sv, prefix ? prefix : "");
1095 if (keepmain || strNE(name, "main")) {
1097 sv_catpvn(sv,"::", 2);
1099 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1103 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1105 gv_fullname4(sv, gv, prefix, TRUE);
1109 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1111 GV *egv = GvEGV(gv);
1114 gv_fullname4(sv, egv, prefix, keepmain);
1118 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1120 gv_efullname4(sv, gv, prefix, TRUE);
1123 /* XXX compatibility with versions <= 5.003. */
1125 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1127 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1130 /* XXX compatibility with versions <= 5.003. */
1132 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1134 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1143 io = (IO*)NEWSV(0,0);
1144 sv_upgrade((SV *)io,SVt_PVIO);
1147 /* Clear the stashcache because a new IO could overrule a
1149 hv_clear(PL_stashcache);
1150 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1151 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1152 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1153 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1154 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1159 Perl_gv_check(pTHX_ HV *stash)
1166 if (!HvARRAY(stash))
1168 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1169 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1170 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1171 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1173 if (hv != PL_defstash && hv != stash)
1174 gv_check(hv); /* nested package */
1176 else if (isALPHA(*HeKEY(entry))) {
1178 gv = (GV*)HeVAL(entry);
1179 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1182 /* performance hack: if filename is absolute and it's a standard
1183 * module, don't bother warning */
1185 && PERL_FILE_IS_ABSOLUTE(file)
1186 #ifdef MACOS_TRADITIONAL
1187 && (instr(file, ":lib:")
1189 && (instr(file, "/lib/")
1191 || instr(file, ".pm")))
1195 CopLINE_set(PL_curcop, GvLINE(gv));
1197 CopFILE(PL_curcop) = file; /* set for warning */
1199 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1201 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1202 "Name \"%s::%s\" used only once: possible typo",
1203 HvNAME(stash), GvNAME(gv));
1210 Perl_newGVgen(pTHX_ char *pack)
1212 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1216 /* hopefully this is only called on local symbol table entries */
1219 Perl_gp_ref(pTHX_ GP *gp)
1226 /* multi-named GPs cannot be used for method cache */
1227 SvREFCNT_dec(gp->gp_cv);
1232 /* Adding a new name to a subroutine invalidates method cache */
1233 PL_sub_generation++;
1240 Perl_gp_free(pTHX_ GV *gv)
1244 if (!gv || !(gp = GvGP(gv)))
1246 if (gp->gp_refcnt == 0) {
1247 if (ckWARN_d(WARN_INTERNAL))
1248 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1249 "Attempt to free unreferenced glob pointers");
1253 /* Deleting the name of a subroutine invalidates method cache */
1254 PL_sub_generation++;
1256 if (--gp->gp_refcnt > 0) {
1257 if (gp->gp_egv == gv)
1262 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1263 if (gp->gp_sv) SvREFCNT_dec(gp->gp_av);
1265 if (PL_stashcache && HvNAME(gp->gp_hv))
1266 hv_delete(PL_stashcache,
1267 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1269 SvREFCNT_dec(gp->gp_hv);
1271 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1272 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1273 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1280 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1282 AMT *amtp = (AMT*)mg->mg_ptr;
1283 if (amtp && AMT_AMAGIC(amtp)) {
1285 for (i = 1; i < NofAMmeth; i++) {
1286 CV *cv = amtp->table[i];
1288 SvREFCNT_dec((SV *) cv);
1289 amtp->table[i] = Nullcv;
1296 /* Updates and caches the CV's */
1299 Perl_Gv_AMupdate(pTHX_ HV *stash)
1303 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1304 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1307 if (mg && amtp->was_ok_am == PL_amagic_generation
1308 && amtp->was_ok_sub == PL_sub_generation)
1309 return (bool)AMT_OVERLOADED(amtp);
1310 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1312 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1315 amt.was_ok_am = PL_amagic_generation;
1316 amt.was_ok_sub = PL_sub_generation;
1317 amt.fallback = AMGfallNO;
1321 int filled = 0, have_ovl = 0;
1325 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1327 /* Try to find via inheritance. */
1328 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1333 lim = DESTROY_amg; /* Skip overloading entries. */
1334 else if (SvTRUE(sv))
1335 amt.fallback=AMGfallYES;
1337 amt.fallback=AMGfallNEVER;
1339 for (i = 1; i < lim; i++)
1340 amt.table[i] = Nullcv;
1341 for (; i < NofAMmeth; i++) {
1342 char *cooky = (char*)PL_AMG_names[i];
1343 /* Human-readable form, for debugging: */
1344 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1345 STRLEN l = strlen(cooky);
1347 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1348 cp, HvNAME(stash)) );
1349 /* don't fill the cache while looking up!
1350 Creation of inheritance stubs in intermediate packages may
1351 conflict with the logic of runtime method substitution.
1352 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1353 then we could have created stubs for "(+0" in A and C too.
1354 But if B overloads "bool", we may want to use it for
1355 numifying instead of C's "+0". */
1356 if (i >= DESTROY_amg)
1357 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1358 else /* Autoload taken care of below */
1359 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1361 if (gv && (cv = GvCV(gv))) {
1362 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1363 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1364 /* This is a hack to support autoloading..., while
1365 knowing *which* methods were declared as overloaded. */
1366 /* GvSV contains the name of the method. */
1369 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1370 "' for overloaded `%s' in package `%.256s'\n",
1371 GvSV(gv), cp, HvNAME(stash)) );
1372 if (!SvPOK(GvSV(gv))
1373 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1376 /* Can be an import stub (created by `can'). */
1377 SV *gvsv = GvSV(gv);
1378 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
1379 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1380 "in package `%.256s'",
1381 (GvCVGEN(gv) ? "Stub found while resolving"
1383 name, cp, HvNAME(stash));
1385 cv = GvCV(gv = ngv);
1387 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1388 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1389 GvNAME(CvGV(cv))) );
1391 if (i < DESTROY_amg)
1393 } else if (gv) { /* Autoloaded... */
1397 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1400 AMT_AMAGIC_on(&amt);
1402 AMT_OVERLOADED_on(&amt);
1403 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1404 (char*)&amt, sizeof(AMT));
1408 /* Here we have no table: */
1410 AMT_AMAGIC_off(&amt);
1411 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1412 (char*)&amt, sizeof(AMTS));
1418 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1424 if (!stash || !HvNAME(stash))
1426 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1430 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1432 amtp = (AMT*)mg->mg_ptr;
1433 if ( amtp->was_ok_am != PL_amagic_generation
1434 || amtp->was_ok_sub != PL_sub_generation )
1436 if (AMT_AMAGIC(amtp)) {
1437 ret = amtp->table[id];
1438 if (ret && isGV(ret)) { /* Autoloading stab */
1439 /* Passing it through may have resulted in a warning
1440 "Inherited AUTOLOAD for a non-method deprecated", since
1441 our caller is going through a function call, not a method call.
1442 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1443 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1456 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1460 CV **cvp=NULL, **ocvp=NULL;
1461 AMT *amtp=NULL, *oamtp=NULL;
1462 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1463 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1468 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1469 && (stash = SvSTASH(SvRV(left)))
1470 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1471 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1472 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1474 && ((cv = cvp[off=method+assignshift])
1475 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1481 cv = cvp[off=method])))) {
1482 lr = -1; /* Call method for left argument */
1484 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1487 /* look for substituted methods */
1488 /* In all the covered cases we should be called with assign==0. */
1492 if ((cv = cvp[off=add_ass_amg])
1493 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1494 right = &PL_sv_yes; lr = -1; assign = 1;
1499 if ((cv = cvp[off = subtr_ass_amg])
1500 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1501 right = &PL_sv_yes; lr = -1; assign = 1;
1505 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1508 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1511 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1514 (void)((cv = cvp[off=bool__amg])
1515 || (cv = cvp[off=numer_amg])
1516 || (cv = cvp[off=string_amg]));
1522 * SV* ref causes confusion with the interpreter variable of
1525 SV* tmpRef=SvRV(left);
1526 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1528 * Just to be extra cautious. Maybe in some
1529 * additional cases sv_setsv is safe, too.
1531 SV* newref = newSVsv(tmpRef);
1532 SvOBJECT_on(newref);
1533 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1539 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1540 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1541 SV* nullsv=sv_2mortal(newSViv(0));
1543 SV* lessp = amagic_call(left,nullsv,
1544 lt_amg,AMGf_noright);
1545 logic = SvTRUE(lessp);
1547 SV* lessp = amagic_call(left,nullsv,
1548 ncmp_amg,AMGf_noright);
1549 logic = (SvNV(lessp) < 0);
1552 if (off==subtr_amg) {
1563 if ((cv = cvp[off=subtr_amg])) {
1565 left = sv_2mortal(newSViv(0));
1570 case iter_amg: /* XXXX Eventually should do to_gv. */
1572 return NULL; /* Delegate operation to standard mechanisms. */
1580 return left; /* Delegate operation to standard mechanisms. */
1585 if (!cv) goto not_found;
1586 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1587 && (stash = SvSTASH(SvRV(right)))
1588 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1589 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1590 ? (amtp = (AMT*)mg->mg_ptr)->table
1592 && (cv = cvp[off=method])) { /* Method for right
1595 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1596 && (cvp=ocvp) && (lr = -1))
1597 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1598 && !(flags & AMGf_unary)) {
1599 /* We look for substitution for
1600 * comparison operations and
1602 if (method==concat_amg || method==concat_ass_amg
1603 || method==repeat_amg || method==repeat_ass_amg) {
1604 return NULL; /* Delegate operation to string conversion */
1614 postpr = 1; off=ncmp_amg; break;
1621 postpr = 1; off=scmp_amg; break;
1623 if (off != -1) cv = cvp[off];
1628 not_found: /* No method found, either report or croak */
1636 return left; /* Delegate operation to standard mechanisms. */
1639 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1640 notfound = 1; lr = -1;
1641 } else if (cvp && (cv=cvp[nomethod_amg])) {
1642 notfound = 1; lr = 1;
1645 if (off==-1) off=method;
1646 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1647 "Operation `%s': no method found,%sargument %s%s%s%s",
1648 AMG_id2name(method + assignshift),
1649 (flags & AMGf_unary ? " " : "\n\tleft "),
1651 "in overloaded package ":
1652 "has no overloaded magic",
1654 HvNAME(SvSTASH(SvRV(left))):
1657 ",\n\tright argument in overloaded package ":
1660 : ",\n\tright argument has no overloaded magic"),
1662 HvNAME(SvSTASH(SvRV(right))):
1664 if (amtp && amtp->fallback >= AMGfallYES) {
1665 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1667 Perl_croak(aTHX_ "%"SVf, msg);
1671 force_cpy = force_cpy || assign;
1676 DEBUG_o(Perl_deb(aTHX_
1677 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1679 method+assignshift==off? "" :
1681 method+assignshift==off? "" :
1682 AMG_id2name(method+assignshift),
1683 method+assignshift==off? "" : "')",
1684 flags & AMGf_unary? "" :
1685 lr==1 ? " for right argument": " for left argument",
1686 flags & AMGf_unary? " for argument" : "",
1687 stash ? HvNAME(stash) : "null",
1688 fl? ",\n\tassignment variant used": "") );
1691 /* Since we use shallow copy during assignment, we need
1692 * to dublicate the contents, probably calling user-supplied
1693 * version of copy operator
1695 /* We need to copy in following cases:
1696 * a) Assignment form was called.
1697 * assignshift==1, assign==T, method + 1 == off
1698 * b) Increment or decrement, called directly.
1699 * assignshift==0, assign==0, method + 0 == off
1700 * c) Increment or decrement, translated to assignment add/subtr.
1701 * assignshift==0, assign==T,
1703 * d) Increment or decrement, translated to nomethod.
1704 * assignshift==0, assign==0,
1706 * e) Assignment form translated to nomethod.
1707 * assignshift==1, assign==T, method + 1 != off
1710 /* off is method, method+assignshift, or a result of opcode substitution.
1711 * In the latter case assignshift==0, so only notfound case is important.
1713 if (( (method + assignshift == off)
1714 && (assign || (method == inc_amg) || (method == dec_amg)))
1721 bool oldcatch = CATCH_GET;
1724 Zero(&myop, 1, BINOP);
1725 myop.op_last = (OP *) &myop;
1726 myop.op_next = Nullop;
1727 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1729 PUSHSTACKi(PERLSI_OVERLOAD);
1732 PL_op = (OP *) &myop;
1733 if (PERLDB_SUB && PL_curstash != PL_debstash)
1734 PL_op->op_private |= OPpENTERSUB_DB;
1738 EXTEND(SP, notfound + 5);
1739 PUSHs(lr>0? right: left);
1740 PUSHs(lr>0? left: right);
1741 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1743 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1748 if ((PL_op = Perl_pp_entersub(aTHX)))
1756 CATCH_SET(oldcatch);
1763 ans=SvIV(res)<=0; break;
1766 ans=SvIV(res)<0; break;
1769 ans=SvIV(res)>=0; break;
1772 ans=SvIV(res)>0; break;
1775 ans=SvIV(res)==0; break;
1778 ans=SvIV(res)!=0; break;
1781 SvSetSV(left,res); return left;
1783 ans=!SvTRUE(res); break;
1786 } else if (method==copy_amg) {
1788 Perl_croak(aTHX_ "Copy method did not return a reference");
1790 return SvREFCNT_inc(SvRV(res));
1798 =for apidoc is_gv_magical
1800 Returns C<TRUE> if given the name of a magical GV.
1802 Currently only useful internally when determining if a GV should be
1803 created even in rvalue contexts.
1805 C<flags> is not used at present but available for future extension to
1806 allow selecting particular classes of magical variable.
1811 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1818 if (len == 3 && strEQ(name, "ISA"))
1822 if (len == 8 && strEQ(name, "OVERLOAD"))
1826 if (len == 3 && strEQ(name, "SIG"))
1829 case '\017': /* $^O & $^OPEN */
1831 || (len == 4 && strEQ(name, "\017PEN")))
1837 if (len > 1 && strEQ(name, "\025NICODE"))
1839 case '\027': /* $^W & $^WARNING_BITS */
1841 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1873 case '\001': /* $^A */
1874 case '\003': /* $^C */
1875 case '\004': /* $^D */
1876 case '\005': /* $^E */
1877 case '\006': /* $^F */
1878 case '\010': /* $^H */
1879 case '\011': /* $^I, NOT \t in EBCDIC */
1880 case '\014': /* $^L */
1881 case '\016': /* $^N */
1882 case '\020': /* $^P */
1883 case '\023': /* $^S */
1884 case '\026': /* $^V */
1888 case '\024': /* $^T, ${^TAINT} */
1889 if (len == 1 || strEQ(name, "\024AINT"))
1902 char *end = name + len;
1903 while (--end > name) {