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 /* No stash in name, so see how we can default */
699 if (isIDFIRST_lazy(name)) {
702 if (isUPPER(*name)) {
703 if (*name == 'S' && (
704 strEQ(name, "SIG") ||
705 strEQ(name, "STDIN") ||
706 strEQ(name, "STDOUT") ||
707 strEQ(name, "STDERR")))
709 else if (*name == 'I' && strEQ(name, "INC"))
711 else if (*name == 'E' && strEQ(name, "ENV"))
713 else if (*name == 'A' && (
714 strEQ(name, "ARGV") ||
715 strEQ(name, "ARGVOUT")))
718 else if (*name == '_' && !name[1])
723 else if ((COP*)PL_curcop == &PL_compiling) {
725 if (add && (PL_hints & HINT_STRICT_VARS) &&
726 sv_type != SVt_PVCV &&
727 sv_type != SVt_PVGV &&
728 sv_type != SVt_PVFM &&
729 sv_type != SVt_PVIO &&
730 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
732 gvp = (GV**)hv_fetch(stash,name,len,0);
734 *gvp == (GV*)&PL_sv_undef ||
735 SvTYPE(*gvp) != SVt_PVGV)
739 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
740 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
741 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
743 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
744 sv_type == SVt_PVAV ? '@' :
745 sv_type == SVt_PVHV ? '%' : '$',
748 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
754 stash = CopSTASH(PL_curcop);
760 /* By this point we should have a stash and a name */
764 qerror(Perl_mess(aTHX_
765 "Global symbol \"%s%s\" requires explicit package name",
766 (sv_type == SVt_PV ? "$"
767 : sv_type == SVt_PVAV ? "@"
768 : sv_type == SVt_PVHV ? "%"
770 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
776 if (!SvREFCNT(stash)) /* symbol table under destruction */
779 gvp = (GV**)hv_fetch(stash,name,len,add);
780 if (!gvp || *gvp == (GV*)&PL_sv_undef)
783 if (SvTYPE(gv) == SVt_PVGV) {
786 gv_init_sv(gv, sv_type);
787 if (*name=='!' && sv_type == SVt_PVHV && len==1)
791 } else if (add & GV_NOINIT) {
795 /* Adding a new symbol */
797 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
798 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
799 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
800 gv_init_sv(gv, sv_type);
802 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
803 : (PL_dowarn & G_WARN_ON ) ) )
806 /* set up magic where warranted */
809 if (strEQ(name, "ARGV")) {
810 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
814 if (strnEQ(name, "EXPORT", 6))
818 if (strEQ(name, "ISA")) {
821 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
822 /* NOTE: No support for tied ISA */
823 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
824 && AvFILLp(av) == -1)
827 av_push(av, newSVpvn(pname = "NDBM_File",9));
828 gv_stashpvn(pname, 9, TRUE);
829 av_push(av, newSVpvn(pname = "DB_File",7));
830 gv_stashpvn(pname, 7, TRUE);
831 av_push(av, newSVpvn(pname = "GDBM_File",9));
832 gv_stashpvn(pname, 9, TRUE);
833 av_push(av, newSVpvn(pname = "SDBM_File",9));
834 gv_stashpvn(pname, 9, TRUE);
835 av_push(av, newSVpvn(pname = "ODBM_File",9));
836 gv_stashpvn(pname, 9, TRUE);
841 if (strEQ(name, "OVERLOAD")) {
844 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
848 if (strEQ(name, "SIG")) {
852 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
853 Newz(73, PL_psig_name, SIG_SIZE, SV*);
854 Newz(73, PL_psig_pend, SIG_SIZE, int);
858 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
859 for (i = 1; i < SIG_SIZE; i++) {
861 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
863 sv_setsv(*init, &PL_sv_undef);
871 if (strEQ(name, "VERSION"))
880 sv_type == SVt_PVAV ||
881 sv_type == SVt_PVHV ||
882 sv_type == SVt_PVCV ||
883 sv_type == SVt_PVFM ||
886 PL_sawampersand = TRUE;
892 sv_setpv(GvSV(gv),PL_chopset);
898 #ifdef COMPLEX_STATUS
899 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
907 /* If %! has been used, automatically load Errno.pm.
908 The require will itself set errno, so in order to
909 preserve its value we have to set up the magic
910 now (rather than going to magicalize)
913 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
915 if (sv_type == SVt_PVHV)
924 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
930 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
931 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
946 case '\001': /* $^A */
947 case '\003': /* $^C */
948 case '\004': /* $^D */
949 case '\006': /* $^F */
950 case '\010': /* $^H */
951 case '\011': /* $^I, NOT \t in EBCDIC */
952 case '\016': /* $^N */
953 case '\020': /* $^P */
960 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
962 case '\005': /* $^E && $^ENCODING */
963 if (len > 1 && strNE(name, "\005NCODING"))
967 case '\017': /* $^O & $^OPEN */
968 if (len > 1 && strNE(name, "\017PEN"))
971 case '\023': /* $^S */
975 case '\024': /* $^T, ${^TAINT} */
978 else if (strEQ(name, "\024AINT"))
983 if (len > 1 && strNE(name, "\025NICODE"))
987 case '\027': /* $^W & $^WARNING_BITS */
989 && strNE(name, "\027ARNING_BITS")
999 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1012 /* ensures variable is only digits */
1013 /* ${"1foo"} fails this test (and is thus writeable) */
1014 /* added by japhy, but borrowed from is_gv_magical */
1017 const char *end = name + len;
1018 while (--end > name) {
1019 if (!isDIGIT(*end)) return gv;
1024 SvREADONLY_on(GvSV(gv));
1026 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1029 case '\014': /* $^L */
1032 sv_setpv(GvSV(gv),"\f");
1033 PL_formfeed = GvSV(gv);
1038 sv_setpv(GvSV(gv),"\034");
1043 (void)SvUPGRADE(sv, SVt_PVNV);
1044 Perl_sv_setpvf(aTHX_ sv,
1045 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1051 SvNVX(PL_patchlevel));
1052 SvNVX(sv) = SvNVX(PL_patchlevel);
1057 case '\026': /* $^V */
1060 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1069 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1072 HV *hv = GvSTASH(gv);
1077 sv_setpv(sv, prefix ? prefix : "");
1083 if (keepmain || strNE(name, "main")) {
1085 sv_catpvn(sv,"::", 2);
1087 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1091 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1093 gv_fullname4(sv, gv, prefix, TRUE);
1097 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1099 GV *egv = GvEGV(gv);
1102 gv_fullname4(sv, egv, prefix, keepmain);
1106 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1108 gv_efullname4(sv, gv, prefix, TRUE);
1111 /* XXX compatibility with versions <= 5.003. */
1113 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1115 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1118 /* XXX compatibility with versions <= 5.003. */
1120 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1122 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1131 io = (IO*)NEWSV(0,0);
1132 sv_upgrade((SV *)io,SVt_PVIO);
1135 /* Clear the stashcache because a new IO could overrule a
1137 hv_clear(PL_stashcache);
1138 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1139 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1140 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1141 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1142 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1147 Perl_gv_check(pTHX_ HV *stash)
1154 if (!HvARRAY(stash))
1156 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1157 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1158 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1159 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1161 if (hv != PL_defstash && hv != stash)
1162 gv_check(hv); /* nested package */
1164 else if (isALPHA(*HeKEY(entry))) {
1166 gv = (GV*)HeVAL(entry);
1167 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1170 /* performance hack: if filename is absolute and it's a standard
1171 * module, don't bother warning */
1173 && PERL_FILE_IS_ABSOLUTE(file)
1174 #ifdef MACOS_TRADITIONAL
1175 && (instr(file, ":lib:")
1177 && (instr(file, "/lib/")
1179 || instr(file, ".pm")))
1183 CopLINE_set(PL_curcop, GvLINE(gv));
1185 CopFILE(PL_curcop) = file; /* set for warning */
1187 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1189 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1190 "Name \"%s::%s\" used only once: possible typo",
1191 HvNAME(stash), GvNAME(gv));
1198 Perl_newGVgen(pTHX_ char *pack)
1200 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1204 /* hopefully this is only called on local symbol table entries */
1207 Perl_gp_ref(pTHX_ GP *gp)
1214 /* multi-named GPs cannot be used for method cache */
1215 SvREFCNT_dec(gp->gp_cv);
1220 /* Adding a new name to a subroutine invalidates method cache */
1221 PL_sub_generation++;
1228 Perl_gp_free(pTHX_ GV *gv)
1232 if (!gv || !(gp = GvGP(gv)))
1234 if (gp->gp_refcnt == 0) {
1235 if (ckWARN_d(WARN_INTERNAL))
1236 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1237 "Attempt to free unreferenced glob pointers");
1241 /* Deleting the name of a subroutine invalidates method cache */
1242 PL_sub_generation++;
1244 if (--gp->gp_refcnt > 0) {
1245 if (gp->gp_egv == gv)
1250 SvREFCNT_dec(gp->gp_sv);
1251 SvREFCNT_dec(gp->gp_av);
1252 if(gp->gp_hv && HvNAME(gp->gp_hv) && PL_stashcache)
1253 hv_delete(PL_stashcache, HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), G_DISCARD);
1254 SvREFCNT_dec(gp->gp_hv);
1255 SvREFCNT_dec(gp->gp_io);
1256 SvREFCNT_dec(gp->gp_cv);
1257 SvREFCNT_dec(gp->gp_form);
1264 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1266 AMT *amtp = (AMT*)mg->mg_ptr;
1267 if (amtp && AMT_AMAGIC(amtp)) {
1269 for (i = 1; i < NofAMmeth; i++) {
1270 CV *cv = amtp->table[i];
1272 SvREFCNT_dec((SV *) cv);
1273 amtp->table[i] = Nullcv;
1280 /* Updates and caches the CV's */
1283 Perl_Gv_AMupdate(pTHX_ HV *stash)
1287 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1288 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1291 if (mg && amtp->was_ok_am == PL_amagic_generation
1292 && amtp->was_ok_sub == PL_sub_generation)
1293 return (bool)AMT_OVERLOADED(amtp);
1294 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1296 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1299 amt.was_ok_am = PL_amagic_generation;
1300 amt.was_ok_sub = PL_sub_generation;
1301 amt.fallback = AMGfallNO;
1305 int filled = 0, have_ovl = 0;
1309 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1311 /* Try to find via inheritance. */
1312 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1317 lim = DESTROY_amg; /* Skip overloading entries. */
1318 else if (SvTRUE(sv))
1319 amt.fallback=AMGfallYES;
1321 amt.fallback=AMGfallNEVER;
1323 for (i = 1; i < lim; i++)
1324 amt.table[i] = Nullcv;
1325 for (; i < NofAMmeth; i++) {
1326 char *cooky = (char*)PL_AMG_names[i];
1327 /* Human-readable form, for debugging: */
1328 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1329 STRLEN l = strlen(cooky);
1331 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1332 cp, HvNAME(stash)) );
1333 /* don't fill the cache while looking up!
1334 Creation of inheritance stubs in intermediate packages may
1335 conflict with the logic of runtime method substitution.
1336 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1337 then we could have created stubs for "(+0" in A and C too.
1338 But if B overloads "bool", we may want to use it for
1339 numifying instead of C's "+0". */
1340 if (i >= DESTROY_amg)
1341 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1342 else /* Autoload taken care of below */
1343 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1345 if (gv && (cv = GvCV(gv))) {
1346 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1347 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1348 /* This is a hack to support autoloading..., while
1349 knowing *which* methods were declared as overloaded. */
1350 /* GvSV contains the name of the method. */
1353 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1354 "' 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' "\
1364 "in package `%.256s'",
1365 (GvCVGEN(gv) ? "Stub found while resolving"
1367 name, cp, HvNAME(stash));
1369 cv = GvCV(gv = ngv);
1371 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1372 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1373 GvNAME(CvGV(cv))) );
1375 if (i < DESTROY_amg)
1377 } else if (gv) { /* Autoloaded... */
1381 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1384 AMT_AMAGIC_on(&amt);
1386 AMT_OVERLOADED_on(&amt);
1387 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1388 (char*)&amt, sizeof(AMT));
1392 /* Here we have no table: */
1394 AMT_AMAGIC_off(&amt);
1395 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1396 (char*)&amt, sizeof(AMTS));
1402 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1408 if (!stash || !HvNAME(stash))
1410 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1414 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1416 amtp = (AMT*)mg->mg_ptr;
1417 if ( amtp->was_ok_am != PL_amagic_generation
1418 || amtp->was_ok_sub != PL_sub_generation )
1420 if (AMT_AMAGIC(amtp)) {
1421 ret = amtp->table[id];
1422 if (ret && isGV(ret)) { /* Autoloading stab */
1423 /* Passing it through may have resulted in a warning
1424 "Inherited AUTOLOAD for a non-method deprecated", since
1425 our caller is going through a function call, not a method call.
1426 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1427 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1440 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1444 CV **cvp=NULL, **ocvp=NULL;
1445 AMT *amtp=NULL, *oamtp=NULL;
1446 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1447 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1452 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1453 && (stash = SvSTASH(SvRV(left)))
1454 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1455 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1456 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1458 && ((cv = cvp[off=method+assignshift])
1459 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1465 cv = cvp[off=method])))) {
1466 lr = -1; /* Call method for left argument */
1468 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1471 /* look for substituted methods */
1472 /* In all the covered cases we should be called with assign==0. */
1476 if ((cv = cvp[off=add_ass_amg])
1477 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1478 right = &PL_sv_yes; lr = -1; assign = 1;
1483 if ((cv = cvp[off = subtr_ass_amg])
1484 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1485 right = &PL_sv_yes; lr = -1; assign = 1;
1489 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1492 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1495 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1498 (void)((cv = cvp[off=bool__amg])
1499 || (cv = cvp[off=numer_amg])
1500 || (cv = cvp[off=string_amg]));
1506 * SV* ref causes confusion with the interpreter variable of
1509 SV* tmpRef=SvRV(left);
1510 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1512 * Just to be extra cautious. Maybe in some
1513 * additional cases sv_setsv is safe, too.
1515 SV* newref = newSVsv(tmpRef);
1516 SvOBJECT_on(newref);
1517 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1523 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1524 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1525 SV* nullsv=sv_2mortal(newSViv(0));
1527 SV* lessp = amagic_call(left,nullsv,
1528 lt_amg,AMGf_noright);
1529 logic = SvTRUE(lessp);
1531 SV* lessp = amagic_call(left,nullsv,
1532 ncmp_amg,AMGf_noright);
1533 logic = (SvNV(lessp) < 0);
1536 if (off==subtr_amg) {
1547 if ((cv = cvp[off=subtr_amg])) {
1549 left = sv_2mortal(newSViv(0));
1554 case iter_amg: /* XXXX Eventually should do to_gv. */
1556 return NULL; /* Delegate operation to standard mechanisms. */
1564 return left; /* Delegate operation to standard mechanisms. */
1569 if (!cv) goto not_found;
1570 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1571 && (stash = SvSTASH(SvRV(right)))
1572 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1573 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1574 ? (amtp = (AMT*)mg->mg_ptr)->table
1576 && (cv = cvp[off=method])) { /* Method for right
1579 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1580 && (cvp=ocvp) && (lr = -1))
1581 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1582 && !(flags & AMGf_unary)) {
1583 /* We look for substitution for
1584 * comparison operations and
1586 if (method==concat_amg || method==concat_ass_amg
1587 || method==repeat_amg || method==repeat_ass_amg) {
1588 return NULL; /* Delegate operation to string conversion */
1598 postpr = 1; off=ncmp_amg; break;
1605 postpr = 1; off=scmp_amg; break;
1607 if (off != -1) cv = cvp[off];
1612 not_found: /* No method found, either report or croak */
1620 return left; /* Delegate operation to standard mechanisms. */
1623 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1624 notfound = 1; lr = -1;
1625 } else if (cvp && (cv=cvp[nomethod_amg])) {
1626 notfound = 1; lr = 1;
1629 if (off==-1) off=method;
1630 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1631 "Operation `%s': no method found,%sargument %s%s%s%s",
1632 AMG_id2name(method + assignshift),
1633 (flags & AMGf_unary ? " " : "\n\tleft "),
1635 "in overloaded package ":
1636 "has no overloaded magic",
1638 HvNAME(SvSTASH(SvRV(left))):
1641 ",\n\tright argument in overloaded package ":
1644 : ",\n\tright argument has no overloaded magic"),
1646 HvNAME(SvSTASH(SvRV(right))):
1648 if (amtp && amtp->fallback >= AMGfallYES) {
1649 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1651 Perl_croak(aTHX_ "%"SVf, msg);
1655 force_cpy = force_cpy || assign;
1660 DEBUG_o(Perl_deb(aTHX_
1661 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1663 method+assignshift==off? "" :
1665 method+assignshift==off? "" :
1666 AMG_id2name(method+assignshift),
1667 method+assignshift==off? "" : "')",
1668 flags & AMGf_unary? "" :
1669 lr==1 ? " for right argument": " for left argument",
1670 flags & AMGf_unary? " for argument" : "",
1671 stash ? HvNAME(stash) : "null",
1672 fl? ",\n\tassignment variant used": "") );
1675 /* Since we use shallow copy during assignment, we need
1676 * to dublicate the contents, probably calling user-supplied
1677 * version of copy operator
1679 /* We need to copy in following cases:
1680 * a) Assignment form was called.
1681 * assignshift==1, assign==T, method + 1 == off
1682 * b) Increment or decrement, called directly.
1683 * assignshift==0, assign==0, method + 0 == off
1684 * c) Increment or decrement, translated to assignment add/subtr.
1685 * assignshift==0, assign==T,
1687 * d) Increment or decrement, translated to nomethod.
1688 * assignshift==0, assign==0,
1690 * e) Assignment form translated to nomethod.
1691 * assignshift==1, assign==T, method + 1 != off
1694 /* off is method, method+assignshift, or a result of opcode substitution.
1695 * In the latter case assignshift==0, so only notfound case is important.
1697 if (( (method + assignshift == off)
1698 && (assign || (method == inc_amg) || (method == dec_amg)))
1705 bool oldcatch = CATCH_GET;
1708 Zero(&myop, 1, BINOP);
1709 myop.op_last = (OP *) &myop;
1710 myop.op_next = Nullop;
1711 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1713 PUSHSTACKi(PERLSI_OVERLOAD);
1716 PL_op = (OP *) &myop;
1717 if (PERLDB_SUB && PL_curstash != PL_debstash)
1718 PL_op->op_private |= OPpENTERSUB_DB;
1722 EXTEND(SP, notfound + 5);
1723 PUSHs(lr>0? right: left);
1724 PUSHs(lr>0? left: right);
1725 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1727 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1732 if ((PL_op = Perl_pp_entersub(aTHX)))
1740 CATCH_SET(oldcatch);
1747 ans=SvIV(res)<=0; break;
1750 ans=SvIV(res)<0; break;
1753 ans=SvIV(res)>=0; break;
1756 ans=SvIV(res)>0; break;
1759 ans=SvIV(res)==0; break;
1762 ans=SvIV(res)!=0; break;
1765 SvSetSV(left,res); return left;
1767 ans=!SvTRUE(res); break;
1770 } else if (method==copy_amg) {
1772 Perl_croak(aTHX_ "Copy method did not return a reference");
1774 return SvREFCNT_inc(SvRV(res));
1782 =for apidoc is_gv_magical
1784 Returns C<TRUE> if given the name of a magical GV.
1786 Currently only useful internally when determining if a GV should be
1787 created even in rvalue contexts.
1789 C<flags> is not used at present but available for future extension to
1790 allow selecting particular classes of magical variable.
1795 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1802 if (len == 3 && strEQ(name, "ISA"))
1806 if (len == 8 && strEQ(name, "OVERLOAD"))
1810 if (len == 3 && strEQ(name, "SIG"))
1813 case '\017': /* $^O & $^OPEN */
1815 || (len == 4 && strEQ(name, "\017PEN")))
1821 if (len > 1 && strEQ(name, "\025NICODE"))
1823 case '\027': /* $^W & $^WARNING_BITS */
1825 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1858 case '\001': /* $^A */
1859 case '\003': /* $^C */
1860 case '\004': /* $^D */
1861 case '\005': /* $^E */
1862 case '\006': /* $^F */
1863 case '\010': /* $^H */
1864 case '\011': /* $^I, NOT \t in EBCDIC */
1865 case '\014': /* $^L */
1866 case '\016': /* $^N */
1867 case '\020': /* $^P */
1868 case '\023': /* $^S */
1869 case '\026': /* $^V */
1873 case '\024': /* $^T, ${^TAINT} */
1874 if (len == 1 || strEQ(name, "\024AINT"))
1887 char *end = name + len;
1888 while (--end > name) {