3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
12 * of your inquisitiveness, I shall spend all the rest of my days answering
13 * you. What more do you want to know?'
14 * 'The names of all the stars, and of all living things, and the whole
15 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
28 Perl_gv_AVadd(pTHX_ register GV *gv)
30 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
31 Perl_croak(aTHX_ "Bad symbol for array");
38 Perl_gv_HVadd(pTHX_ register GV *gv)
40 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
41 Perl_croak(aTHX_ "Bad symbol for hash");
48 Perl_gv_IOadd(pTHX_ register GV *gv)
50 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
51 Perl_croak(aTHX_ "Bad symbol for filehandle");
53 #ifdef GV_UNIQUE_CHECK
55 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
64 Perl_gv_fetchfile(pTHX_ const char *name)
74 tmplen = strlen(name) + 2;
75 if (tmplen < sizeof smallbuf)
78 New(603, tmpbuf, tmplen + 1, char);
79 /* This is where the debugger's %{"::_<$filename"} hash is created */
82 strcpy(tmpbuf + 2, name);
83 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
85 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
86 sv_setpv(GvSV(gv), name);
88 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
90 if (tmpbuf != smallbuf)
96 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
99 bool doproto = SvTYPE(gv) > SVt_NULL;
100 char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
102 sv_upgrade((SV*)gv, SVt_PVGV);
111 Newz(602, gp, 1, GP);
112 GvGP(gv) = gp_ref(gp);
113 GvSV(gv) = NEWSV(72,0);
114 GvLINE(gv) = CopLINE(PL_curcop);
115 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
118 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
119 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
120 GvNAME(gv) = savepvn(name, len);
122 if (multi || doproto) /* doproto means it _was_ mentioned */
124 if (doproto) { /* Replicate part of newSUB here. */
127 /* XXX unsafe for threads if eval_owner isn't held */
128 start_subparse(0,0); /* Create CV in compcv. */
129 GvCV(gv) = PL_compcv;
134 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
135 CvSTASH(GvCV(gv)) = PL_curstash;
136 #ifdef USE_5005THREADS
137 CvOWNER(GvCV(gv)) = 0;
138 if (!CvMUTEXP(GvCV(gv))) {
139 New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
140 MUTEX_INIT(CvMUTEXP(GvCV(gv)));
142 #endif /* USE_5005THREADS */
144 sv_setpv((SV*)GvCV(gv), proto);
151 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
167 =for apidoc gv_fetchmeth
169 Returns the glob with the given C<name> and a defined subroutine or
170 C<NULL>. The glob lives in the given C<stash>, or in the stashes
171 accessible via @ISA and UNIVERSAL::.
173 The argument C<level> should be either 0 or -1. If C<level==0>, as a
174 side-effect creates a glob with the given C<name> in the given C<stash>
175 which in the case of success contains an alias for the subroutine, and sets
176 up caching info for this glob. Similarly for all the searched stashes.
178 This function grants C<"SUPER"> token as a postfix of the stash name. The
179 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
180 visible to Perl code. So when calling C<call_sv>, you should not use
181 the GV directly; instead, you should use the method's CV, which can be
182 obtained from the GV with the C<GvCV> macro.
188 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
196 /* UNIVERSAL methods should be callable without a stash */
198 level = -1; /* probably appropriate */
199 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
203 if ((level > 100) || (level < -100))
204 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
205 name, HvNAME(stash));
207 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
209 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
214 if (SvTYPE(topgv) != SVt_PVGV)
215 gv_init(topgv, stash, name, len, TRUE);
216 if ((cv = GvCV(topgv))) {
217 /* If genuine method or valid cache entry, use it */
218 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
220 /* Stale cached entry: junk it */
222 GvCV(topgv) = cv = Nullcv;
225 else if (GvCVGEN(topgv) == PL_sub_generation)
226 return 0; /* cache indicates sub doesn't exist */
229 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
230 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
232 /* create and re-create @.*::SUPER::ISA on demand */
233 if (!av || !SvMAGIC(av)) {
234 char* packname = HvNAME(stash);
235 STRLEN packlen = strlen(packname);
237 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
241 basestash = gv_stashpvn(packname, packlen, TRUE);
242 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
243 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
244 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
245 if (!gvp || !(gv = *gvp))
246 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
247 if (SvTYPE(gv) != SVt_PVGV)
248 gv_init(gv, stash, "ISA", 3, TRUE);
249 SvREFCNT_dec(GvAV(gv));
250 GvAV(gv) = (AV*)SvREFCNT_inc(av);
256 SV** svp = AvARRAY(av);
257 /* NOTE: No support for tied ISA */
258 I32 items = AvFILLp(av) + 1;
261 HV* basestash = gv_stashsv(sv, FALSE);
263 if (ckWARN(WARN_MISC))
264 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %s for @%s::ISA",
265 SvPVX(sv), HvNAME(stash));
268 gv = gv_fetchmeth(basestash, name, len,
269 (level >= 0) ? level + 1 : level - 1);
275 /* if at top level, try UNIVERSAL */
277 if (level == 0 || level == -1) {
280 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
281 if ((gv = gv_fetchmeth(lastchance, name, len,
282 (level >= 0) ? level + 1 : level - 1)))
286 * Cache method in topgv if:
287 * 1. topgv has no synonyms (else inheritance crosses wires)
288 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
291 GvREFCNT(topgv) == 1 &&
293 (CvROOT(cv) || CvXSUB(cv)))
295 if ((cv = GvCV(topgv)))
297 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
298 GvCVGEN(topgv) = PL_sub_generation;
302 else if (topgv && GvREFCNT(topgv) == 1) {
303 /* cache the fact that the method is not defined */
304 GvCVGEN(topgv) = PL_sub_generation;
313 =for apidoc gv_fetchmeth_autoload
315 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
316 Returns a glob for the subroutine.
318 For an autoloaded subroutine without a GV, will create a GV even
319 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
320 of the result may be zero.
326 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
328 GV *gv = gv_fetchmeth(stash, name, len, level);
331 char autoload[] = "AUTOLOAD";
332 STRLEN autolen = sizeof(autoload)-1;
337 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
338 if (len == autolen && strnEQ(name, autoload, autolen))
340 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
343 if (!(CvROOT(cv) || CvXSUB(cv)))
345 /* Have an autoload */
346 if (level < 0) /* Cannot do without a stub */
347 gv_fetchmeth(stash, name, len, 0);
348 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
357 =for apidoc gv_fetchmethod
359 See L<gv_fetchmethod_autoload>.
365 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
367 return gv_fetchmethod_autoload(stash, name, TRUE);
371 =for apidoc gv_fetchmethod_autoload
373 Returns the glob which contains the subroutine to call to invoke the method
374 on the C<stash>. In fact in the presence of autoloading this may be the
375 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
378 The third parameter of C<gv_fetchmethod_autoload> determines whether
379 AUTOLOAD lookup is performed if the given method is not present: non-zero
380 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
381 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
382 with a non-zero C<autoload> parameter.
384 These functions grant C<"SUPER"> token as a prefix of the method name. Note
385 that if you want to keep the returned glob for a long time, you need to
386 check for it being "AUTOLOAD", since at the later time the call may load a
387 different subroutine due to $AUTOLOAD changing its value. Use the glob
388 created via a side effect to do this.
390 These functions have the same side-effects and as C<gv_fetchmeth> with
391 C<level==0>. C<name> should be writable if contains C<':'> or C<'
392 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
393 C<call_sv> apply equally to these functions.
399 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
401 register const char *nend;
402 const char *nsplit = 0;
405 for (nend = name; *nend; nend++) {
408 else if (*nend == ':' && *(nend + 1) == ':')
412 const char *origname = name;
416 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
417 /* ->SUPER::method should really be looked up in original stash */
418 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
419 CopSTASHPV(PL_curcop)));
420 /* __PACKAGE__::SUPER stash should be autovivified */
421 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
422 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
423 origname, HvNAME(stash), name) );
426 /* don't autovifify if ->NoSuchStash::method */
427 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
430 gv = gv_fetchmeth(stash, name, nend - name, 0);
432 if (strEQ(name,"import") || strEQ(name,"unimport"))
433 gv = (GV*)&PL_sv_yes;
435 gv = gv_autoload4(stash, name, nend - name, TRUE);
439 if (!CvROOT(cv) && !CvXSUB(cv)) {
447 if (GvCV(stubgv) != cv) /* orphaned import */
450 autogv = gv_autoload4(GvSTASH(stubgv),
451 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
461 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
463 char autoload[] = "AUTOLOAD";
464 STRLEN autolen = sizeof(autoload)-1;
472 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
473 if (len == autolen && strnEQ(name, autoload, autolen))
475 if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
479 if (!(CvROOT(cv) || CvXSUB(cv)))
483 * Inheriting AUTOLOAD for non-methods works ... for now.
485 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
486 (GvCVGEN(gv) || GvSTASH(gv) != stash))
487 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
488 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
489 HvNAME(stash), (int)len, name);
491 #ifndef USE_5005THREADS
493 /* rather than lookup/init $AUTOLOAD here
494 * only to have the XSUB do another lookup for $AUTOLOAD
495 * and split that value on the last '::',
496 * pass along the same data via some unused fields in the CV
499 SvPVX(cv) = (char *)name; /* cast to lose constness warning */
506 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
507 * The subroutine's original name may not be "AUTOLOAD", so we don't
508 * use that, but for lack of anything better we will use the sub's
509 * original package to look up $AUTOLOAD.
511 varstash = GvSTASH(CvGV(cv));
512 vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
515 #ifdef USE_5005THREADS
516 sv_lock((SV *)varstash);
519 gv_init(vargv, varstash, autoload, autolen, FALSE);
522 #ifdef USE_5005THREADS
525 sv_setpv(varsv, HvNAME(stash));
526 sv_catpvn(varsv, "::", 2);
527 sv_catpvn(varsv, name, len);
528 SvTAINTED_off(varsv);
532 /* The "gv" parameter should be the glob known to Perl code as *!
533 * The scalar must already have been magicalized.
536 S_require_errno(pTHX_ GV *gv)
538 HV* stash = gv_stashpvn("Errno",5,FALSE);
540 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
544 save_scalar(gv); /* keep the value of $! */
545 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
546 newSVpvn("Errno",5), Nullsv);
549 stash = gv_stashpvn("Errno",5,FALSE);
550 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
551 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
556 =for apidoc gv_stashpv
558 Returns a pointer to the stash for a specified package. C<name> should
559 be a valid UTF-8 string. If C<create> is set then the package will be
560 created if it does not already exist. If C<create> is not set and the
561 package does not exist then NULL is returned.
567 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
569 return gv_stashpvn(name, strlen(name), create);
573 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
580 if (namelen + 3 < sizeof smallbuf)
583 New(606, tmpbuf, namelen + 3, char);
584 Copy(name,tmpbuf,namelen,char);
585 tmpbuf[namelen++] = ':';
586 tmpbuf[namelen++] = ':';
587 tmpbuf[namelen] = '\0';
588 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
589 if (tmpbuf != smallbuf)
594 GvHV(tmpgv) = newHV();
597 HvNAME(stash) = savepv(name);
602 =for apidoc gv_stashsv
604 Returns a pointer to the stash for a specified package, which must be a
605 valid UTF-8 string. See C<gv_stashpv>.
611 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
616 return gv_stashpvn(ptr, len, create);
621 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
623 register const char *name = nambeg;
627 register const char *namend;
630 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
633 for (namend = name; *namend; namend++) {
634 if ((*namend == ':' && namend[1] == ':')
635 || (*namend == '\'' && namend[1]))
639 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
647 if (len + 3 < sizeof smallbuf)
650 New(601, tmpbuf, len+3, char);
651 Copy(name, tmpbuf, len, char);
655 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
656 gv = gvp ? *gvp : Nullgv;
657 if (gv && gv != (GV*)&PL_sv_undef) {
658 if (SvTYPE(gv) != SVt_PVGV)
659 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
663 if (tmpbuf != smallbuf)
665 if (!gv || gv == (GV*)&PL_sv_undef)
668 if (!(stash = GvHV(gv)))
669 stash = GvHV(gv) = newHV();
672 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
680 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
687 /* No stash in name, so see how we can default */
690 if (isIDFIRST_lazy(name)) {
693 if (isUPPER(*name)) {
694 if (*name == 'S' && (
695 strEQ(name, "SIG") ||
696 strEQ(name, "STDIN") ||
697 strEQ(name, "STDOUT") ||
698 strEQ(name, "STDERR")))
700 else if (*name == 'I' && strEQ(name, "INC"))
702 else if (*name == 'E' && strEQ(name, "ENV"))
704 else if (*name == 'A' && (
705 strEQ(name, "ARGV") ||
706 strEQ(name, "ARGVOUT")))
709 else if (*name == '_' && !name[1])
714 else if ((COP*)PL_curcop == &PL_compiling) {
716 if (add && (PL_hints & HINT_STRICT_VARS) &&
717 sv_type != SVt_PVCV &&
718 sv_type != SVt_PVGV &&
719 sv_type != SVt_PVFM &&
720 sv_type != SVt_PVIO &&
721 !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
723 gvp = (GV**)hv_fetch(stash,name,len,0);
725 *gvp == (GV*)&PL_sv_undef ||
726 SvTYPE(*gvp) != SVt_PVGV)
730 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
731 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
732 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
734 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
735 sv_type == SVt_PVAV ? '@' :
736 sv_type == SVt_PVHV ? '%' : '$',
739 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
745 stash = CopSTASH(PL_curcop);
751 /* By this point we should have a stash and a name */
755 qerror(Perl_mess(aTHX_
756 "Global symbol \"%s%s\" requires explicit package name",
757 (sv_type == SVt_PV ? "$"
758 : sv_type == SVt_PVAV ? "@"
759 : sv_type == SVt_PVHV ? "%"
761 stash = PL_nullstash;
767 if (!SvREFCNT(stash)) /* symbol table under destruction */
770 gvp = (GV**)hv_fetch(stash,name,len,add);
771 if (!gvp || *gvp == (GV*)&PL_sv_undef)
774 if (SvTYPE(gv) == SVt_PVGV) {
777 gv_init_sv(gv, sv_type);
778 if (*name=='!' && sv_type == SVt_PVHV && len==1)
782 } else if (add & GV_NOINIT) {
786 /* Adding a new symbol */
788 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
789 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
790 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
791 gv_init_sv(gv, sv_type);
793 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
794 : (PL_dowarn & G_WARN_ON ) ) )
797 /* set up magic where warranted */
800 if (strEQ(name, "ARGV")) {
801 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
805 if (strnEQ(name, "EXPORT", 6))
809 if (strEQ(name, "ISA")) {
812 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
813 /* NOTE: No support for tied ISA */
814 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
815 && AvFILLp(av) == -1)
818 av_push(av, newSVpvn(pname = "NDBM_File",9));
819 gv_stashpvn(pname, 9, TRUE);
820 av_push(av, newSVpvn(pname = "DB_File",7));
821 gv_stashpvn(pname, 7, TRUE);
822 av_push(av, newSVpvn(pname = "GDBM_File",9));
823 gv_stashpvn(pname, 9, TRUE);
824 av_push(av, newSVpvn(pname = "SDBM_File",9));
825 gv_stashpvn(pname, 9, TRUE);
826 av_push(av, newSVpvn(pname = "ODBM_File",9));
827 gv_stashpvn(pname, 9, TRUE);
832 if (strEQ(name, "OVERLOAD")) {
835 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
839 if (strEQ(name, "SIG")) {
843 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
844 Newz(73, PL_psig_name, SIG_SIZE, SV*);
845 Newz(73, PL_psig_pend, SIG_SIZE, int);
849 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
850 for (i = 1; i < SIG_SIZE; i++) {
852 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
854 sv_setsv(*init, &PL_sv_undef);
862 if (strEQ(name, "VERSION"))
871 sv_type == SVt_PVAV ||
872 sv_type == SVt_PVHV ||
873 sv_type == SVt_PVCV ||
874 sv_type == SVt_PVFM ||
877 PL_sawampersand = TRUE;
883 sv_setpv(GvSV(gv),PL_chopset);
889 #ifdef COMPLEX_STATUS
890 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
898 /* If %! has been used, automatically load Errno.pm.
899 The require will itself set errno, so in order to
900 preserve its value we have to set up the magic
901 now (rather than going to magicalize)
904 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
906 if (sv_type == SVt_PVHV)
915 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
921 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
922 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
937 case '\001': /* $^A */
938 case '\003': /* $^C */
939 case '\004': /* $^D */
940 case '\006': /* $^F */
941 case '\010': /* $^H */
942 case '\011': /* $^I, NOT \t in EBCDIC */
943 case '\016': /* $^N */
944 case '\020': /* $^P */
951 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
953 case '\005': /* $^E && $^ENCODING */
954 if (len > 1 && strNE(name, "\005NCODING"))
958 case '\017': /* $^O & $^OPEN */
959 if (len > 1 && strNE(name, "\017PEN"))
962 case '\023': /* $^S */
966 case '\024': /* $^T, ${^TAINT} */
969 else if (strEQ(name, "\024AINT"))
973 case '\027': /* $^W & $^WARNING_BITS */
974 if (len > 1 && strNE(name, "\027ARNING_BITS")
975 && strNE(name, "\027IDE_SYSTEM_CALLS"))
984 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
997 /* ensures variable is only digits */
998 /* ${"1foo"} fails this test (and is thus writeable) */
999 /* added by japhy, but borrowed from is_gv_magical */
1002 const char *end = name + len;
1003 while (--end > name) {
1004 if (!isDIGIT(*end)) return gv;
1009 SvREADONLY_on(GvSV(gv));
1011 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1014 case '\014': /* $^L */
1017 sv_setpv(GvSV(gv),"\f");
1018 PL_formfeed = GvSV(gv);
1023 sv_setpv(GvSV(gv),"\034");
1028 (void)SvUPGRADE(sv, SVt_PVNV);
1029 Perl_sv_setpvf(aTHX_ sv,
1030 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1036 SvNVX(PL_patchlevel));
1037 SvNVX(sv) = SvNVX(PL_patchlevel);
1042 case '\026': /* $^V */
1045 GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1054 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1056 HV *hv = GvSTASH(gv);
1061 sv_setpv(sv, prefix ? prefix : "");
1062 if (keepmain || strNE(HvNAME(hv), "main")) {
1063 sv_catpv(sv,HvNAME(hv));
1064 sv_catpvn(sv,"::", 2);
1066 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1070 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1072 HV *hv = GvSTASH(gv);
1077 sv_setpv(sv, prefix ? prefix : "");
1078 sv_catpv(sv,HvNAME(hv));
1079 sv_catpvn(sv,"::", 2);
1080 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1084 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1086 GV *egv = GvEGV(gv);
1089 gv_fullname4(sv, egv, prefix, keepmain);
1093 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1095 GV *egv = GvEGV(gv);
1098 gv_fullname3(sv, egv, prefix);
1101 /* XXX compatibility with versions <= 5.003. */
1103 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1105 gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1108 /* XXX compatibility with versions <= 5.003. */
1110 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1112 gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1121 io = (IO*)NEWSV(0,0);
1122 sv_upgrade((SV *)io,SVt_PVIO);
1125 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1126 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1127 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1128 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1129 SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1134 Perl_gv_check(pTHX_ HV *stash)
1141 if (!HvARRAY(stash))
1143 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1144 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1145 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1146 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
1148 if (hv != PL_defstash && hv != stash)
1149 gv_check(hv); /* nested package */
1151 else if (isALPHA(*HeKEY(entry))) {
1153 gv = (GV*)HeVAL(entry);
1154 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1157 /* performance hack: if filename is absolute and it's a standard
1158 * module, don't bother warning */
1160 && PERL_FILE_IS_ABSOLUTE(file)
1161 #ifdef MACOS_TRADITIONAL
1162 && (instr(file, ":lib:")
1164 && (instr(file, "/lib/")
1166 || instr(file, ".pm")))
1170 CopLINE_set(PL_curcop, GvLINE(gv));
1172 CopFILE(PL_curcop) = file; /* set for warning */
1174 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1176 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1177 "Name \"%s::%s\" used only once: possible typo",
1178 HvNAME(stash), GvNAME(gv));
1185 Perl_newGVgen(pTHX_ char *pack)
1187 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1191 /* hopefully this is only called on local symbol table entries */
1194 Perl_gp_ref(pTHX_ GP *gp)
1201 /* multi-named GPs cannot be used for method cache */
1202 SvREFCNT_dec(gp->gp_cv);
1207 /* Adding a new name to a subroutine invalidates method cache */
1208 PL_sub_generation++;
1215 Perl_gp_free(pTHX_ GV *gv)
1219 if (!gv || !(gp = GvGP(gv)))
1221 if (gp->gp_refcnt == 0) {
1222 if (ckWARN_d(WARN_INTERNAL))
1223 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1224 "Attempt to free unreferenced glob pointers");
1228 /* Deleting the name of a subroutine invalidates method cache */
1229 PL_sub_generation++;
1231 if (--gp->gp_refcnt > 0) {
1232 if (gp->gp_egv == gv)
1237 SvREFCNT_dec(gp->gp_sv);
1238 SvREFCNT_dec(gp->gp_av);
1239 SvREFCNT_dec(gp->gp_hv);
1240 SvREFCNT_dec(gp->gp_io);
1241 SvREFCNT_dec(gp->gp_cv);
1242 SvREFCNT_dec(gp->gp_form);
1249 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1251 AMT *amtp = (AMT*)mg->mg_ptr;
1252 if (amtp && AMT_AMAGIC(amtp)) {
1254 for (i = 1; i < NofAMmeth; i++) {
1255 CV *cv = amtp->table[i];
1257 SvREFCNT_dec((SV *) cv);
1258 amtp->table[i] = Nullcv;
1265 /* Updates and caches the CV's */
1268 Perl_Gv_AMupdate(pTHX_ HV *stash)
1272 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1273 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1276 if (mg && amtp->was_ok_am == PL_amagic_generation
1277 && amtp->was_ok_sub == PL_sub_generation)
1278 return AMT_OVERLOADED(amtp);
1279 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1281 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1284 amt.was_ok_am = PL_amagic_generation;
1285 amt.was_ok_sub = PL_sub_generation;
1286 amt.fallback = AMGfallNO;
1290 int filled = 0, have_ovl = 0;
1294 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1296 /* Try to find via inheritance. */
1297 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1302 lim = DESTROY_amg; /* Skip overloading entries. */
1303 else if (SvTRUE(sv))
1304 amt.fallback=AMGfallYES;
1306 amt.fallback=AMGfallNEVER;
1308 for (i = 1; i < lim; i++)
1309 amt.table[i] = Nullcv;
1310 for (; i < NofAMmeth; i++) {
1311 char *cooky = (char*)PL_AMG_names[i];
1312 /* Human-readable form, for debugging: */
1313 char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1314 STRLEN l = strlen(cooky);
1316 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1317 cp, HvNAME(stash)) );
1318 /* don't fill the cache while looking up!
1319 Creation of inheritance stubs in intermediate packages may
1320 conflict with the logic of runtime method substitution.
1321 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1322 then we could have created stubs for "(+0" in A and C too.
1323 But if B overloads "bool", we may want to use it for
1324 numifying instead of C's "+0". */
1325 if (i >= DESTROY_amg)
1326 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1327 else /* Autoload taken care of below */
1328 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1330 if (gv && (cv = GvCV(gv))) {
1331 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1332 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1333 /* This is a hack to support autoloading..., while
1334 knowing *which* methods were declared as overloaded. */
1335 /* GvSV contains the name of the method. */
1338 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1339 SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
1340 if (!SvPOK(GvSV(gv))
1341 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1344 /* Can be an import stub (created by `can'). */
1346 Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1347 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1350 Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1351 (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
1354 cv = GvCV(gv = ngv);
1356 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1357 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1358 GvNAME(CvGV(cv))) );
1360 if (i < DESTROY_amg)
1362 } else if (gv) { /* Autoloaded... */
1366 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1369 AMT_AMAGIC_on(&amt);
1371 AMT_OVERLOADED_on(&amt);
1372 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1373 (char*)&amt, sizeof(AMT));
1377 /* Here we have no table: */
1379 AMT_AMAGIC_off(&amt);
1380 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1381 (char*)&amt, sizeof(AMTS));
1387 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1395 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1399 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1401 amtp = (AMT*)mg->mg_ptr;
1402 if ( amtp->was_ok_am != PL_amagic_generation
1403 || amtp->was_ok_sub != PL_sub_generation )
1405 if (AMT_AMAGIC(amtp)) {
1406 ret = amtp->table[id];
1407 if (ret && isGV(ret)) { /* Autoloading stab */
1408 /* Passing it through may have resulted in a warning
1409 "Inherited AUTOLOAD for a non-method deprecated", since
1410 our caller is going through a function call, not a method call.
1411 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1412 GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1425 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1429 CV **cvp=NULL, **ocvp=NULL;
1430 AMT *amtp=NULL, *oamtp=NULL;
1431 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1432 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1437 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1438 && (stash = SvSTASH(SvRV(left)))
1439 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1440 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1441 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1443 && ((cv = cvp[off=method+assignshift])
1444 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1450 cv = cvp[off=method])))) {
1451 lr = -1; /* Call method for left argument */
1453 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1456 /* look for substituted methods */
1457 /* In all the covered cases we should be called with assign==0. */
1461 if ((cv = cvp[off=add_ass_amg])
1462 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1463 right = &PL_sv_yes; lr = -1; assign = 1;
1468 if ((cv = cvp[off = subtr_ass_amg])
1469 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1470 right = &PL_sv_yes; lr = -1; assign = 1;
1474 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1477 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1480 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1483 (void)((cv = cvp[off=bool__amg])
1484 || (cv = cvp[off=numer_amg])
1485 || (cv = cvp[off=string_amg]));
1491 * SV* ref causes confusion with the interpreter variable of
1494 SV* tmpRef=SvRV(left);
1495 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1497 * Just to be extra cautious. Maybe in some
1498 * additional cases sv_setsv is safe, too.
1500 SV* newref = newSVsv(tmpRef);
1501 SvOBJECT_on(newref);
1502 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1508 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1509 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1510 SV* nullsv=sv_2mortal(newSViv(0));
1512 SV* lessp = amagic_call(left,nullsv,
1513 lt_amg,AMGf_noright);
1514 logic = SvTRUE(lessp);
1516 SV* lessp = amagic_call(left,nullsv,
1517 ncmp_amg,AMGf_noright);
1518 logic = (SvNV(lessp) < 0);
1521 if (off==subtr_amg) {
1532 if ((cv = cvp[off=subtr_amg])) {
1534 left = sv_2mortal(newSViv(0));
1539 case iter_amg: /* XXXX Eventually should do to_gv. */
1541 return NULL; /* Delegate operation to standard mechanisms. */
1549 return left; /* Delegate operation to standard mechanisms. */
1554 if (!cv) goto not_found;
1555 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1556 && (stash = SvSTASH(SvRV(right)))
1557 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1558 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1559 ? (amtp = (AMT*)mg->mg_ptr)->table
1561 && (cv = cvp[off=method])) { /* Method for right
1564 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1565 && (cvp=ocvp) && (lr = -1))
1566 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1567 && !(flags & AMGf_unary)) {
1568 /* We look for substitution for
1569 * comparison operations and
1571 if (method==concat_amg || method==concat_ass_amg
1572 || method==repeat_amg || method==repeat_ass_amg) {
1573 return NULL; /* Delegate operation to string conversion */
1583 postpr = 1; off=ncmp_amg; break;
1590 postpr = 1; off=scmp_amg; break;
1592 if (off != -1) cv = cvp[off];
1597 not_found: /* No method found, either report or croak */
1605 return left; /* Delegate operation to standard mechanisms. */
1608 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1609 notfound = 1; lr = -1;
1610 } else if (cvp && (cv=cvp[nomethod_amg])) {
1611 notfound = 1; lr = 1;
1614 if (off==-1) off=method;
1615 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1616 "Operation `%s': no method found,%sargument %s%s%s%s",
1617 AMG_id2name(method + assignshift),
1618 (flags & AMGf_unary ? " " : "\n\tleft "),
1620 "in overloaded package ":
1621 "has no overloaded magic",
1623 HvNAME(SvSTASH(SvRV(left))):
1626 ",\n\tright argument in overloaded package ":
1629 : ",\n\tright argument has no overloaded magic"),
1631 HvNAME(SvSTASH(SvRV(right))):
1633 if (amtp && amtp->fallback >= AMGfallYES) {
1634 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1636 Perl_croak(aTHX_ "%"SVf, msg);
1640 force_cpy = force_cpy || assign;
1645 DEBUG_o(Perl_deb(aTHX_
1646 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1648 method+assignshift==off? "" :
1650 method+assignshift==off? "" :
1651 AMG_id2name(method+assignshift),
1652 method+assignshift==off? "" : "')",
1653 flags & AMGf_unary? "" :
1654 lr==1 ? " for right argument": " for left argument",
1655 flags & AMGf_unary? " for argument" : "",
1656 stash ? HvNAME(stash) : "null",
1657 fl? ",\n\tassignment variant used": "") );
1660 /* Since we use shallow copy during assignment, we need
1661 * to dublicate the contents, probably calling user-supplied
1662 * version of copy operator
1664 /* We need to copy in following cases:
1665 * a) Assignment form was called.
1666 * assignshift==1, assign==T, method + 1 == off
1667 * b) Increment or decrement, called directly.
1668 * assignshift==0, assign==0, method + 0 == off
1669 * c) Increment or decrement, translated to assignment add/subtr.
1670 * assignshift==0, assign==T,
1672 * d) Increment or decrement, translated to nomethod.
1673 * assignshift==0, assign==0,
1675 * e) Assignment form translated to nomethod.
1676 * assignshift==1, assign==T, method + 1 != off
1679 /* off is method, method+assignshift, or a result of opcode substitution.
1680 * In the latter case assignshift==0, so only notfound case is important.
1682 if (( (method + assignshift == off)
1683 && (assign || (method == inc_amg) || (method == dec_amg)))
1690 bool oldcatch = CATCH_GET;
1693 Zero(&myop, 1, BINOP);
1694 myop.op_last = (OP *) &myop;
1695 myop.op_next = Nullop;
1696 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1698 PUSHSTACKi(PERLSI_OVERLOAD);
1701 PL_op = (OP *) &myop;
1702 if (PERLDB_SUB && PL_curstash != PL_debstash)
1703 PL_op->op_private |= OPpENTERSUB_DB;
1707 EXTEND(SP, notfound + 5);
1708 PUSHs(lr>0? right: left);
1709 PUSHs(lr>0? left: right);
1710 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1712 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1717 if ((PL_op = Perl_pp_entersub(aTHX)))
1725 CATCH_SET(oldcatch);
1732 ans=SvIV(res)<=0; break;
1735 ans=SvIV(res)<0; break;
1738 ans=SvIV(res)>=0; break;
1741 ans=SvIV(res)>0; break;
1744 ans=SvIV(res)==0; break;
1747 ans=SvIV(res)!=0; break;
1750 SvSetSV(left,res); return left;
1752 ans=!SvTRUE(res); break;
1755 } else if (method==copy_amg) {
1757 Perl_croak(aTHX_ "Copy method did not return a reference");
1759 return SvREFCNT_inc(SvRV(res));
1767 =for apidoc is_gv_magical
1769 Returns C<TRUE> if given the name of a magical GV.
1771 Currently only useful internally when determining if a GV should be
1772 created even in rvalue contexts.
1774 C<flags> is not used at present but available for future extension to
1775 allow selecting particular classes of magical variable.
1780 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1787 if (len == 3 && strEQ(name, "ISA"))
1791 if (len == 8 && strEQ(name, "OVERLOAD"))
1795 if (len == 3 && strEQ(name, "SIG"))
1798 case '\017': /* $^O & $^OPEN */
1800 || (len == 4 && strEQ(name, "\017PEN")))
1805 case '\027': /* $^W & $^WARNING_BITS */
1807 || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1808 || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1840 case '\001': /* $^A */
1841 case '\003': /* $^C */
1842 case '\004': /* $^D */
1843 case '\005': /* $^E */
1844 case '\006': /* $^F */
1845 case '\010': /* $^H */
1846 case '\011': /* $^I, NOT \t in EBCDIC */
1847 case '\014': /* $^L */
1848 case '\016': /* $^N */
1849 case '\020': /* $^P */
1850 case '\023': /* $^S */
1851 case '\026': /* $^V */
1855 case '\024': /* $^T, ${^TAINT} */
1856 if (len == 1 || strEQ(name, "\024AINT"))
1869 char *end = name + len;
1870 while (--end > name) {