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);
929 if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
930 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
931 "$* is no longer supported");
934 if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
935 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
936 "Use of $# is deprecated");
951 case '\001': /* $^A */
952 case '\003': /* $^C */
953 case '\004': /* $^D */
954 case '\006': /* $^F */
955 case '\010': /* $^H */
956 case '\011': /* $^I, NOT \t in EBCDIC */
957 case '\016': /* $^N */
958 case '\020': /* $^P */
965 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
967 case '\005': /* $^E && $^ENCODING */
968 if (len > 1 && strNE(name, "\005NCODING"))
972 case '\017': /* $^O & $^OPEN */
973 if (len > 1 && strNE(name, "\017PEN"))
976 case '\023': /* $^S */
980 case '\024': /* $^T, ${^TAINT} */
983 else if (strEQ(name, "\024AINT"))
988 if (len > 1 && strNE(name, "\025NICODE"))
992 case '\027': /* $^W & $^WARNING_BITS */
994 && strNE(name, "\027ARNING_BITS")
1004 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1017 /* ensures variable is only digits */
1018 /* ${"1foo"} fails this test (and is thus writeable) */
1019 /* added by japhy, but borrowed from is_gv_magical */
1022 const char *end = name + len;
1023 while (--end > name) {
1024 if (!isDIGIT(*end)) return gv;
1029 SvREADONLY_on(GvSV(gv));
1031 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1034 case '\014': /* $^L */
1037 sv_setpv(GvSV(gv),"\f");
1038 PL_formfeed = GvSV(gv);
1043 sv_setpv(GvSV(gv),"\034");
1048 (void)SvUPGRADE(sv, SVt_PVNV);
1049 Perl_sv_setpvf(aTHX_ sv,
1050 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1056 SvNVX(PL_patchlevel));
1057 SvNVX(sv) = SvNVX(PL_patchlevel);
1062 case '\026': /* $^V */
1065 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1074 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1077 HV *hv = GvSTASH(gv);
1082 sv_setpv(sv, prefix ? prefix : "");
1088 if (keepmain || strNE(name, "main")) {
1090 sv_catpvn(sv,"::", 2);
1092 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1096 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1098 gv_fullname4(sv, gv, prefix, TRUE);
1102 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1104 GV *egv = GvEGV(gv);
1107 gv_fullname4(sv, egv, prefix, keepmain);
1111 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1113 gv_efullname4(sv, gv, prefix, TRUE);
1116 /* XXX compatibility with versions <= 5.003. */
1118 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1120 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1123 /* XXX compatibility with versions <= 5.003. */
1125 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1127 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1136 io = (IO*)NEWSV(0,0);
1137 sv_upgrade((SV *)io,SVt_PVIO);
1140 /* Clear the stashcache because a new IO could overrule a
1142 hv_clear(PL_stashcache);
1143 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1144 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1145 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1146 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1147 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1152 Perl_gv_check(pTHX_ HV *stash)
1159 if (!HvARRAY(stash))
1161 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1162 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1163 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1164 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1166 if (hv != PL_defstash && hv != stash)
1167 gv_check(hv); /* nested package */
1169 else if (isALPHA(*HeKEY(entry))) {
1171 gv = (GV*)HeVAL(entry);
1172 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1175 /* performance hack: if filename is absolute and it's a standard
1176 * module, don't bother warning */
1178 && PERL_FILE_IS_ABSOLUTE(file)
1179 #ifdef MACOS_TRADITIONAL
1180 && (instr(file, ":lib:")
1182 && (instr(file, "/lib/")
1184 || instr(file, ".pm")))
1188 CopLINE_set(PL_curcop, GvLINE(gv));
1190 CopFILE(PL_curcop) = file; /* set for warning */
1192 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1194 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1195 "Name \"%s::%s\" used only once: possible typo",
1196 HvNAME(stash), GvNAME(gv));
1203 Perl_newGVgen(pTHX_ char *pack)
1205 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1209 /* hopefully this is only called on local symbol table entries */
1212 Perl_gp_ref(pTHX_ GP *gp)
1219 /* multi-named GPs cannot be used for method cache */
1220 SvREFCNT_dec(gp->gp_cv);
1225 /* Adding a new name to a subroutine invalidates method cache */
1226 PL_sub_generation++;
1233 Perl_gp_free(pTHX_ GV *gv)
1237 if (!gv || !(gp = GvGP(gv)))
1239 if (gp->gp_refcnt == 0) {
1240 if (ckWARN_d(WARN_INTERNAL))
1241 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1242 "Attempt to free unreferenced glob pointers");
1246 /* Deleting the name of a subroutine invalidates method cache */
1247 PL_sub_generation++;
1249 if (--gp->gp_refcnt > 0) {
1250 if (gp->gp_egv == gv)
1255 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1256 if (gp->gp_sv) SvREFCNT_dec(gp->gp_av);
1258 if (PL_stashcache && HvNAME(gp->gp_hv))
1259 hv_delete(PL_stashcache,
1260 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1262 SvREFCNT_dec(gp->gp_hv);
1264 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1265 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1266 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1273 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1275 AMT *amtp = (AMT*)mg->mg_ptr;
1276 if (amtp && AMT_AMAGIC(amtp)) {
1278 for (i = 1; i < NofAMmeth; i++) {
1279 CV *cv = amtp->table[i];
1281 SvREFCNT_dec((SV *) cv);
1282 amtp->table[i] = Nullcv;
1289 /* Updates and caches the CV's */
1292 Perl_Gv_AMupdate(pTHX_ HV *stash)
1296 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1297 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1300 if (mg && amtp->was_ok_am == PL_amagic_generation
1301 && amtp->was_ok_sub == PL_sub_generation)
1302 return (bool)AMT_OVERLOADED(amtp);
1303 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1305 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1308 amt.was_ok_am = PL_amagic_generation;
1309 amt.was_ok_sub = PL_sub_generation;
1310 amt.fallback = AMGfallNO;
1314 int filled = 0, have_ovl = 0;
1318 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1320 /* Try to find via inheritance. */
1321 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1326 lim = DESTROY_amg; /* Skip overloading entries. */
1327 else if (SvTRUE(sv))
1328 amt.fallback=AMGfallYES;
1330 amt.fallback=AMGfallNEVER;
1332 for (i = 1; i < lim; i++)
1333 amt.table[i] = Nullcv;
1334 for (; i < NofAMmeth; i++) {
1335 char *cooky = (char*)PL_AMG_names[i];
1336 /* Human-readable form, for debugging: */
1337 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1338 STRLEN l = strlen(cooky);
1340 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1341 cp, HvNAME(stash)) );
1342 /* don't fill the cache while looking up!
1343 Creation of inheritance stubs in intermediate packages may
1344 conflict with the logic of runtime method substitution.
1345 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1346 then we could have created stubs for "(+0" in A and C too.
1347 But if B overloads "bool", we may want to use it for
1348 numifying instead of C's "+0". */
1349 if (i >= DESTROY_amg)
1350 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1351 else /* Autoload taken care of below */
1352 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1354 if (gv && (cv = GvCV(gv))) {
1355 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1356 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1357 /* This is a hack to support autoloading..., while
1358 knowing *which* methods were declared as overloaded. */
1359 /* GvSV contains the name of the method. */
1362 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1363 "' for overloaded `%s' in package `%.256s'\n",
1364 GvSV(gv), cp, HvNAME(stash)) );
1365 if (!SvPOK(GvSV(gv))
1366 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1369 /* Can be an import stub (created by `can'). */
1370 SV *gvsv = GvSV(gv);
1371 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
1372 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1373 "in package `%.256s'",
1374 (GvCVGEN(gv) ? "Stub found while resolving"
1376 name, cp, HvNAME(stash));
1378 cv = GvCV(gv = ngv);
1380 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1381 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1382 GvNAME(CvGV(cv))) );
1384 if (i < DESTROY_amg)
1386 } else if (gv) { /* Autoloaded... */
1390 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1393 AMT_AMAGIC_on(&amt);
1395 AMT_OVERLOADED_on(&amt);
1396 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1397 (char*)&amt, sizeof(AMT));
1401 /* Here we have no table: */
1403 AMT_AMAGIC_off(&amt);
1404 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1405 (char*)&amt, sizeof(AMTS));
1411 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1417 if (!stash || !HvNAME(stash))
1419 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1423 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1425 amtp = (AMT*)mg->mg_ptr;
1426 if ( amtp->was_ok_am != PL_amagic_generation
1427 || amtp->was_ok_sub != PL_sub_generation )
1429 if (AMT_AMAGIC(amtp)) {
1430 ret = amtp->table[id];
1431 if (ret && isGV(ret)) { /* Autoloading stab */
1432 /* Passing it through may have resulted in a warning
1433 "Inherited AUTOLOAD for a non-method deprecated", since
1434 our caller is going through a function call, not a method call.
1435 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1436 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1449 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1453 CV **cvp=NULL, **ocvp=NULL;
1454 AMT *amtp=NULL, *oamtp=NULL;
1455 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1456 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1461 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1462 && (stash = SvSTASH(SvRV(left)))
1463 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1464 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1465 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1467 && ((cv = cvp[off=method+assignshift])
1468 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1474 cv = cvp[off=method])))) {
1475 lr = -1; /* Call method for left argument */
1477 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1480 /* look for substituted methods */
1481 /* In all the covered cases we should be called with assign==0. */
1485 if ((cv = cvp[off=add_ass_amg])
1486 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1487 right = &PL_sv_yes; lr = -1; assign = 1;
1492 if ((cv = cvp[off = subtr_ass_amg])
1493 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1494 right = &PL_sv_yes; lr = -1; assign = 1;
1498 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1501 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1504 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1507 (void)((cv = cvp[off=bool__amg])
1508 || (cv = cvp[off=numer_amg])
1509 || (cv = cvp[off=string_amg]));
1515 * SV* ref causes confusion with the interpreter variable of
1518 SV* tmpRef=SvRV(left);
1519 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1521 * Just to be extra cautious. Maybe in some
1522 * additional cases sv_setsv is safe, too.
1524 SV* newref = newSVsv(tmpRef);
1525 SvOBJECT_on(newref);
1526 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1532 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1533 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1534 SV* nullsv=sv_2mortal(newSViv(0));
1536 SV* lessp = amagic_call(left,nullsv,
1537 lt_amg,AMGf_noright);
1538 logic = SvTRUE(lessp);
1540 SV* lessp = amagic_call(left,nullsv,
1541 ncmp_amg,AMGf_noright);
1542 logic = (SvNV(lessp) < 0);
1545 if (off==subtr_amg) {
1556 if ((cv = cvp[off=subtr_amg])) {
1558 left = sv_2mortal(newSViv(0));
1563 case iter_amg: /* XXXX Eventually should do to_gv. */
1565 return NULL; /* Delegate operation to standard mechanisms. */
1573 return left; /* Delegate operation to standard mechanisms. */
1578 if (!cv) goto not_found;
1579 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1580 && (stash = SvSTASH(SvRV(right)))
1581 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1582 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1583 ? (amtp = (AMT*)mg->mg_ptr)->table
1585 && (cv = cvp[off=method])) { /* Method for right
1588 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1589 && (cvp=ocvp) && (lr = -1))
1590 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1591 && !(flags & AMGf_unary)) {
1592 /* We look for substitution for
1593 * comparison operations and
1595 if (method==concat_amg || method==concat_ass_amg
1596 || method==repeat_amg || method==repeat_ass_amg) {
1597 return NULL; /* Delegate operation to string conversion */
1607 postpr = 1; off=ncmp_amg; break;
1614 postpr = 1; off=scmp_amg; break;
1616 if (off != -1) cv = cvp[off];
1621 not_found: /* No method found, either report or croak */
1629 return left; /* Delegate operation to standard mechanisms. */
1632 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1633 notfound = 1; lr = -1;
1634 } else if (cvp && (cv=cvp[nomethod_amg])) {
1635 notfound = 1; lr = 1;
1638 if (off==-1) off=method;
1639 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1640 "Operation `%s': no method found,%sargument %s%s%s%s",
1641 AMG_id2name(method + assignshift),
1642 (flags & AMGf_unary ? " " : "\n\tleft "),
1644 "in overloaded package ":
1645 "has no overloaded magic",
1647 HvNAME(SvSTASH(SvRV(left))):
1650 ",\n\tright argument in overloaded package ":
1653 : ",\n\tright argument has no overloaded magic"),
1655 HvNAME(SvSTASH(SvRV(right))):
1657 if (amtp && amtp->fallback >= AMGfallYES) {
1658 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1660 Perl_croak(aTHX_ "%"SVf, msg);
1664 force_cpy = force_cpy || assign;
1669 DEBUG_o(Perl_deb(aTHX_
1670 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1672 method+assignshift==off? "" :
1674 method+assignshift==off? "" :
1675 AMG_id2name(method+assignshift),
1676 method+assignshift==off? "" : "')",
1677 flags & AMGf_unary? "" :
1678 lr==1 ? " for right argument": " for left argument",
1679 flags & AMGf_unary? " for argument" : "",
1680 stash ? HvNAME(stash) : "null",
1681 fl? ",\n\tassignment variant used": "") );
1684 /* Since we use shallow copy during assignment, we need
1685 * to dublicate the contents, probably calling user-supplied
1686 * version of copy operator
1688 /* We need to copy in following cases:
1689 * a) Assignment form was called.
1690 * assignshift==1, assign==T, method + 1 == off
1691 * b) Increment or decrement, called directly.
1692 * assignshift==0, assign==0, method + 0 == off
1693 * c) Increment or decrement, translated to assignment add/subtr.
1694 * assignshift==0, assign==T,
1696 * d) Increment or decrement, translated to nomethod.
1697 * assignshift==0, assign==0,
1699 * e) Assignment form translated to nomethod.
1700 * assignshift==1, assign==T, method + 1 != off
1703 /* off is method, method+assignshift, or a result of opcode substitution.
1704 * In the latter case assignshift==0, so only notfound case is important.
1706 if (( (method + assignshift == off)
1707 && (assign || (method == inc_amg) || (method == dec_amg)))
1714 bool oldcatch = CATCH_GET;
1717 Zero(&myop, 1, BINOP);
1718 myop.op_last = (OP *) &myop;
1719 myop.op_next = Nullop;
1720 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1722 PUSHSTACKi(PERLSI_OVERLOAD);
1725 PL_op = (OP *) &myop;
1726 if (PERLDB_SUB && PL_curstash != PL_debstash)
1727 PL_op->op_private |= OPpENTERSUB_DB;
1731 EXTEND(SP, notfound + 5);
1732 PUSHs(lr>0? right: left);
1733 PUSHs(lr>0? left: right);
1734 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1736 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1741 if ((PL_op = Perl_pp_entersub(aTHX)))
1749 CATCH_SET(oldcatch);
1756 ans=SvIV(res)<=0; break;
1759 ans=SvIV(res)<0; break;
1762 ans=SvIV(res)>=0; break;
1765 ans=SvIV(res)>0; break;
1768 ans=SvIV(res)==0; break;
1771 ans=SvIV(res)!=0; break;
1774 SvSetSV(left,res); return left;
1776 ans=!SvTRUE(res); break;
1779 } else if (method==copy_amg) {
1781 Perl_croak(aTHX_ "Copy method did not return a reference");
1783 return SvREFCNT_inc(SvRV(res));
1791 =for apidoc is_gv_magical
1793 Returns C<TRUE> if given the name of a magical GV.
1795 Currently only useful internally when determining if a GV should be
1796 created even in rvalue contexts.
1798 C<flags> is not used at present but available for future extension to
1799 allow selecting particular classes of magical variable.
1804 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1811 if (len == 3 && strEQ(name, "ISA"))
1815 if (len == 8 && strEQ(name, "OVERLOAD"))
1819 if (len == 3 && strEQ(name, "SIG"))
1822 case '\017': /* $^O & $^OPEN */
1824 || (len == 4 && strEQ(name, "\017PEN")))
1830 if (len > 1 && strEQ(name, "\025NICODE"))
1832 case '\027': /* $^W & $^WARNING_BITS */
1834 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1866 case '\001': /* $^A */
1867 case '\003': /* $^C */
1868 case '\004': /* $^D */
1869 case '\005': /* $^E */
1870 case '\006': /* $^F */
1871 case '\010': /* $^H */
1872 case '\011': /* $^I, NOT \t in EBCDIC */
1873 case '\014': /* $^L */
1874 case '\016': /* $^N */
1875 case '\020': /* $^P */
1876 case '\023': /* $^S */
1877 case '\026': /* $^V */
1881 case '\024': /* $^T, ${^TAINT} */
1882 if (len == 1 || strEQ(name, "\024AINT"))
1895 char *end = name + len;
1896 while (--end > name) {