3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 in 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,'
19 * [p.599 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
27 corresponding to $foo, @foo, %foo.
29 GVs are usually found as values in stashes (symbol table hashes) where
30 Perl stores its global variables.
40 static const char S_autoload[] = "AUTOLOAD";
41 static const STRLEN S_autolen = sizeof(S_autoload)-1;
44 #ifdef PERL_DONT_CREATE_GVSV
46 Perl_gv_SVadd(pTHX_ GV *gv)
48 PERL_ARGS_ASSERT_GV_SVADD;
50 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
51 Perl_croak(aTHX_ "Bad symbol for scalar");
59 Perl_gv_AVadd(pTHX_ register GV *gv)
61 PERL_ARGS_ASSERT_GV_AVADD;
63 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
64 Perl_croak(aTHX_ "Bad symbol for array");
71 Perl_gv_HVadd(pTHX_ register GV *gv)
73 PERL_ARGS_ASSERT_GV_HVADD;
75 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
76 Perl_croak(aTHX_ "Bad symbol for hash");
83 Perl_gv_IOadd(pTHX_ register GV *gv)
87 PERL_ARGS_ASSERT_GV_IOADD;
89 if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
92 * if it walks like a dirhandle, then let's assume that
93 * this is a dirhandle.
95 const char * const fh =
96 PL_op->op_type == OP_READDIR ||
97 PL_op->op_type == OP_TELLDIR ||
98 PL_op->op_type == OP_SEEKDIR ||
99 PL_op->op_type == OP_REWINDDIR ||
100 PL_op->op_type == OP_CLOSEDIR ?
101 "dirhandle" : "filehandle";
102 /* diag_listed_as: Bad symbol for filehandle */
103 Perl_croak(aTHX_ "Bad symbol for %s", fh);
113 Perl_gv_fetchfile(pTHX_ const char *name)
115 PERL_ARGS_ASSERT_GV_FETCHFILE;
116 return gv_fetchfile_flags(name, strlen(name), 0);
120 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
126 const STRLEN tmplen = namelen + 2;
129 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
130 PERL_UNUSED_ARG(flags);
135 if (tmplen <= sizeof smallbuf)
138 Newx(tmpbuf, tmplen, char);
139 /* This is where the debugger's %{"::_<$filename"} hash is created */
142 memcpy(tmpbuf + 2, name, namelen);
143 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
145 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
146 #ifdef PERL_DONT_CREATE_GVSV
147 GvSV(gv) = newSVpvn(name, namelen);
149 sv_setpvn(GvSV(gv), name, namelen);
151 if (PERLDB_LINE || PERLDB_SAVESRC)
152 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
154 if (tmpbuf != smallbuf)
160 =for apidoc gv_const_sv
162 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
163 inlining, or C<gv> is a placeholder reference that would be promoted to such
164 a typeglob, then returns the value returned by the sub. Otherwise, returns
171 Perl_gv_const_sv(pTHX_ GV *gv)
173 PERL_ARGS_ASSERT_GV_CONST_SV;
175 if (SvTYPE(gv) == SVt_PVGV)
176 return cv_const_sv(GvCVu(gv));
177 return SvROK(gv) ? SvRV(gv) : NULL;
181 Perl_newGP(pTHX_ GV *const gv)
186 const char *const file
187 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
188 const STRLEN len = strlen(file);
190 SV *const temp_sv = CopFILESV(PL_curcop);
194 PERL_ARGS_ASSERT_NEWGP;
197 file = SvPVX(temp_sv);
198 len = SvCUR(temp_sv);
205 PERL_HASH(hash, file, len);
209 #ifndef PERL_DONT_CREATE_GVSV
210 gp->gp_sv = newSV(0);
213 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
214 /* XXX Ideally this cast would be replaced with a change to const char*
216 gp->gp_file_hek = share_hek(file, len, hash);
224 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
227 const U32 old_type = SvTYPE(gv);
228 const bool doproto = old_type > SVt_NULL;
229 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
230 const STRLEN protolen = proto ? SvCUR(gv) : 0;
231 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
232 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
234 PERL_ARGS_ASSERT_GV_INIT;
235 assert (!(proto && has_constant));
238 /* The constant has to be a simple scalar type. */
239 switch (SvTYPE(has_constant)) {
245 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
246 sv_reftype(has_constant, 0));
254 if (old_type < SVt_PVGV) {
255 if (old_type >= SVt_PV)
257 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
265 Safefree(SvPVX_mutable(gv));
270 GvGP(gv) = Perl_newGP(aTHX_ gv);
273 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
274 gv_name_set(gv, name, len, GV_ADD);
275 if (multi || doproto) /* doproto means it _was_ mentioned */
277 if (doproto) { /* Replicate part of newSUB here. */
280 /* newCONSTSUB takes ownership of the reference from us. */
281 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
282 /* If this reference was a copy of another, then the subroutine
283 must have been "imported", by a Perl space assignment to a GV
284 from a reference to CV. */
285 if (exported_constant)
286 GvIMPORTED_CV_on(gv);
288 (void) start_subparse(0,0); /* Create empty CV in compcv. */
289 GvCV(gv) = PL_compcv;
293 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
295 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
296 CvSTASH(GvCV(gv)) = PL_curstash;
298 sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen,
299 SV_HAS_TRAILING_NUL);
305 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
307 PERL_ARGS_ASSERT_GV_INIT_SV;
319 #ifdef PERL_DONT_CREATE_GVSV
327 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
328 If we just cast GvSVn(gv) to void, it ignores evaluating it for
336 =for apidoc gv_fetchmeth
338 Returns the glob with the given C<name> and a defined subroutine or
339 C<NULL>. The glob lives in the given C<stash>, or in the stashes
340 accessible via @ISA and UNIVERSAL::.
342 The argument C<level> should be either 0 or -1. If C<level==0>, as a
343 side-effect creates a glob with the given C<name> in the given C<stash>
344 which in the case of success contains an alias for the subroutine, and sets
345 up caching info for this glob.
347 This function grants C<"SUPER"> token as a postfix of the stash name. The
348 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
349 visible to Perl code. So when calling C<call_sv>, you should not use
350 the GV directly; instead, you should use the method's CV, which can be
351 obtained from the GV with the C<GvCV> macro.
356 /* NOTE: No support for tied ISA */
359 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
367 GV* candidate = NULL;
372 I32 create = (level >= 0) ? 1 : 0;
377 PERL_ARGS_ASSERT_GV_FETCHMETH;
379 /* UNIVERSAL methods should be callable without a stash */
381 create = 0; /* probably appropriate */
382 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
388 hvname = HvNAME_get(stash);
390 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
395 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
397 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
399 /* check locally for a real method or a cache entry */
400 gvp = (GV**)hv_fetch(stash, name, len, create);
404 if (SvTYPE(topgv) != SVt_PVGV)
405 gv_init(topgv, stash, name, len, TRUE);
406 if ((cand_cv = GvCV(topgv))) {
407 /* If genuine method or valid cache entry, use it */
408 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
412 /* stale cache entry, junk it and move on */
413 SvREFCNT_dec(cand_cv);
414 GvCV(topgv) = cand_cv = NULL;
418 else if (GvCVGEN(topgv) == topgen_cmp) {
419 /* cache indicates no such method definitively */
424 packlen = HvNAMELEN_get(stash);
425 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
428 basestash = gv_stashpvn(hvname, packlen, GV_ADD);
429 linear_av = mro_get_linear_isa(basestash);
432 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
435 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
436 items = AvFILLp(linear_av); /* no +1, to skip over self */
438 linear_sv = *linear_svp++;
440 cstash = gv_stashsv(linear_sv, 0);
443 if (ckWARN(WARN_SYNTAX))
444 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
445 SVfARG(linear_sv), hvname);
451 gvp = (GV**)hv_fetch(cstash, name, len, 0);
455 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
456 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
458 * Found real method, cache method in topgv if:
459 * 1. topgv has no synonyms (else inheritance crosses wires)
460 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
462 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
463 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
464 SvREFCNT_inc_simple_void_NN(cand_cv);
465 GvCV(topgv) = cand_cv;
466 GvCVGEN(topgv) = topgen_cmp;
472 /* Check UNIVERSAL without caching */
473 if(level == 0 || level == -1) {
474 candidate = gv_fetchmeth(NULL, name, len, 1);
476 cand_cv = GvCV(candidate);
477 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
478 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
479 SvREFCNT_inc_simple_void_NN(cand_cv);
480 GvCV(topgv) = cand_cv;
481 GvCVGEN(topgv) = topgen_cmp;
487 if (topgv && GvREFCNT(topgv) == 1) {
488 /* cache the fact that the method is not defined */
489 GvCVGEN(topgv) = topgen_cmp;
496 =for apidoc gv_fetchmeth_autoload
498 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
499 Returns a glob for the subroutine.
501 For an autoloaded subroutine without a GV, will create a GV even
502 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
503 of the result may be zero.
509 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
511 GV *gv = gv_fetchmeth(stash, name, len, level);
513 PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
520 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
521 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
523 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
526 if (!(CvROOT(cv) || CvXSUB(cv)))
528 /* Have an autoload */
529 if (level < 0) /* Cannot do without a stub */
530 gv_fetchmeth(stash, name, len, 0);
531 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
540 =for apidoc gv_fetchmethod_autoload
542 Returns the glob which contains the subroutine to call to invoke the method
543 on the C<stash>. In fact in the presence of autoloading this may be the
544 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
547 The third parameter of C<gv_fetchmethod_autoload> determines whether
548 AUTOLOAD lookup is performed if the given method is not present: non-zero
549 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
550 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
551 with a non-zero C<autoload> parameter.
553 These functions grant C<"SUPER"> token as a prefix of the method name. Note
554 that if you want to keep the returned glob for a long time, you need to
555 check for it being "AUTOLOAD", since at the later time the call may load a
556 different subroutine due to $AUTOLOAD changing its value. Use the glob
557 created via a side effect to do this.
559 These functions have the same side-effects and as C<gv_fetchmeth> with
560 C<level==0>. C<name> should be writable if contains C<':'> or C<'
561 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
562 C<call_sv> apply equally to these functions.
568 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
575 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
577 stash = gv_stashpvn(name, namelen, 0);
578 if(stash) return stash;
580 /* If we must create it, give it an @ISA array containing
581 the real package this SUPER is for, so that it's tied
582 into the cache invalidation code correctly */
583 stash = gv_stashpvn(name, namelen, GV_ADD);
584 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
586 gv_init(gv, stash, "ISA", 3, TRUE);
587 superisa = GvAVn(gv);
589 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
591 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
593 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
594 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
601 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
603 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
605 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
608 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
611 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
614 register const char *nend;
615 const char *nsplit = NULL;
618 const char * const origname = name;
619 SV *const error_report = MUTABLE_SV(stash);
620 const U32 autoload = flags & GV_AUTOLOAD;
621 const U32 do_croak = flags & GV_CROAK;
623 PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
625 if (SvTYPE(stash) < SVt_PVHV)
628 /* The only way stash can become NULL later on is if nsplit is set,
629 which in turn means that there is no need for a SVt_PVHV case
630 the error reporting code. */
633 for (nend = name; *nend; nend++) {
638 else if (*nend == ':' && *(nend + 1) == ':') {
644 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
645 /* ->SUPER::method should really be looked up in original stash */
646 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
647 CopSTASHPV(PL_curcop)));
648 /* __PACKAGE__::SUPER stash should be autovivified */
649 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
650 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
651 origname, HvNAME_get(stash), name) );
654 /* don't autovifify if ->NoSuchStash::method */
655 stash = gv_stashpvn(origname, nsplit - origname, 0);
657 /* however, explicit calls to Pkg::SUPER::method may
658 happen, and may require autovivification to work */
659 if (!stash && (nsplit - origname) >= 7 &&
660 strnEQ(nsplit - 7, "::SUPER", 7) &&
661 gv_stashpvn(origname, nsplit - origname - 7, 0))
662 stash = gv_get_super_pkg(origname, nsplit - origname);
667 gv = gv_fetchmeth(stash, name, nend - name, 0);
669 if (strEQ(name,"import") || strEQ(name,"unimport"))
670 gv = MUTABLE_GV(&PL_sv_yes);
672 gv = gv_autoload4(ostash, name, nend - name, TRUE);
673 if (!gv && do_croak) {
674 /* Right now this is exclusively for the benefit of S_method_common
678 "Can't locate object method \"%s\" via package \"%.*s\"",
679 name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
683 const char *packname;
686 packlen = nsplit - origname;
689 packname = SvPV_const(error_report, packlen);
693 "Can't locate object method \"%s\" via package \"%.*s\""
694 " (perhaps you forgot to load \"%.*s\"?)",
695 name, (int)packlen, packname, (int)packlen, packname);
700 CV* const cv = GvCV(gv);
701 if (!CvROOT(cv) && !CvXSUB(cv)) {
709 if (GvCV(stubgv) != cv) /* orphaned import */
712 autogv = gv_autoload4(GvSTASH(stubgv),
713 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
723 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
731 const char *packname = "";
732 STRLEN packname_len = 0;
734 PERL_ARGS_ASSERT_GV_AUTOLOAD4;
736 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
739 if (SvTYPE(stash) < SVt_PVHV) {
740 packname = SvPV_const(MUTABLE_SV(stash), packname_len);
744 packname = HvNAME_get(stash);
745 packname_len = HvNAMELEN_get(stash);
748 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
752 if (!(CvROOT(cv) || CvXSUB(cv)))
756 * Inheriting AUTOLOAD for non-methods works ... for now.
758 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
759 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
761 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
762 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
763 packname, (int)len, name);
766 /* rather than lookup/init $AUTOLOAD here
767 * only to have the XSUB do another lookup for $AUTOLOAD
768 * and split that value on the last '::',
769 * pass along the same data via some unused fields in the CV
772 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
778 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
779 * The subroutine's original name may not be "AUTOLOAD", so we don't
780 * use that, but for lack of anything better we will use the sub's
781 * original package to look up $AUTOLOAD.
783 varstash = GvSTASH(CvGV(cv));
784 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
788 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
789 #ifdef PERL_DONT_CREATE_GVSV
790 GvSV(vargv) = newSV(0);
794 varsv = GvSVn(vargv);
795 sv_setpvn(varsv, packname, packname_len);
796 sv_catpvs(varsv, "::");
797 sv_catpvn(varsv, name, len);
802 /* require_tie_mod() internal routine for requiring a module
803 * that implements the logic of automatical ties like %! and %-
805 * The "gv" parameter should be the glob.
806 * "varpv" holds the name of the var, used for error messages.
807 * "namesv" holds the module name. Its refcount will be decremented.
808 * "methpv" holds the method name to test for to check that things
809 * are working reasonably close to as expected.
810 * "flags": if flag & 1 then save the scalar before loading.
811 * For the protection of $! to work (it is set by this routine)
812 * the sv slot must already be magicalized.
815 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
818 HV* stash = gv_stashsv(namesv, 0);
820 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
822 if (!stash || !(gv_fetchmethod(stash, methpv))) {
823 SV *module = newSVsv(namesv);
824 char varname = *varpv; /* varpv might be clobbered by load_module,
825 so save it. For the moment it's always
831 PUSHSTACKi(PERLSI_MAGIC);
832 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
836 stash = gv_stashsv(namesv, 0);
838 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
839 varname, SVfARG(namesv));
840 else if (!gv_fetchmethod(stash, methpv))
841 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
842 varname, SVfARG(namesv), methpv);
844 SvREFCNT_dec(namesv);
849 =for apidoc gv_stashpv
851 Returns a pointer to the stash for a specified package. Uses C<strlen> to
852 determine the length of C<name>, then calls C<gv_stashpvn()>.
858 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
860 PERL_ARGS_ASSERT_GV_STASHPV;
861 return gv_stashpvn(name, strlen(name), create);
865 =for apidoc gv_stashpvn
867 Returns a pointer to the stash for a specified package. The C<namelen>
868 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
869 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
870 created if it does not already exist. If the package does not exist and
871 C<flags> is 0 (or any other setting that does not create packages) then NULL
879 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
886 PERL_ARGS_ASSERT_GV_STASHPVN;
888 if (namelen + 2 <= sizeof smallbuf)
891 Newx(tmpbuf, namelen + 2, char);
892 Copy(name,tmpbuf,namelen,char);
893 tmpbuf[namelen++] = ':';
894 tmpbuf[namelen++] = ':';
895 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
896 if (tmpbuf != smallbuf)
901 GvHV(tmpgv) = newHV();
903 if (!HvNAME_get(stash))
904 hv_name_set(stash, name, namelen, 0);
909 =for apidoc gv_stashsv
911 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
917 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
920 const char * const ptr = SvPV_const(sv,len);
922 PERL_ARGS_ASSERT_GV_STASHSV;
924 return gv_stashpvn(ptr, len, flags);
929 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
930 PERL_ARGS_ASSERT_GV_FETCHPV;
931 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
935 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
937 const char * const nambeg = SvPV_const(name, len);
938 PERL_ARGS_ASSERT_GV_FETCHSV;
939 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
943 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
944 const svtype sv_type)
947 register const char *name = nambeg;
948 register GV *gv = NULL;
951 register const char *name_cursor;
953 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
954 const I32 no_expand = flags & GV_NOEXPAND;
955 const I32 add = flags & ~GV_NOADD_MASK;
956 const char *const name_end = nambeg + full_len;
957 const char *const name_em1 = name_end - 1;
960 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
962 if (flags & GV_NOTQUAL) {
963 /* Caller promised that there is no stash, so we can skip the check. */
968 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
969 /* accidental stringify on a GV? */
973 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
974 if ((*name_cursor == ':' && name_cursor < name_em1
975 && name_cursor[1] == ':')
976 || (*name_cursor == '\'' && name_cursor[1]))
980 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
983 len = name_cursor - name;
988 if (len + 2 <= (I32)sizeof (smallbuf))
991 Newx(tmpbuf, len+2, char);
992 Copy(name, tmpbuf, len, char);
995 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
996 gv = gvp ? *gvp : NULL;
997 if (gv && gv != (const GV *)&PL_sv_undef) {
998 if (SvTYPE(gv) != SVt_PVGV)
999 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
1003 if (tmpbuf != smallbuf)
1005 if (!gv || gv == (const GV *)&PL_sv_undef)
1008 if (!(stash = GvHV(gv)))
1009 stash = GvHV(gv) = newHV();
1011 if (!HvNAME_get(stash))
1012 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1015 if (*name_cursor == ':')
1019 if (name == name_end)
1021 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1024 len = name_cursor - name;
1026 /* No stash in name, so see how we can default */
1030 if (len && isIDFIRST_lazy(name)) {
1031 bool global = FALSE;
1039 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1040 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1041 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1045 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1050 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1051 && name[3] == 'I' && name[4] == 'N')
1055 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1056 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1057 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1061 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1062 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1069 stash = PL_defstash;
1070 else if (IN_PERL_COMPILETIME) {
1071 stash = PL_curstash;
1072 if (add && (PL_hints & HINT_STRICT_VARS) &&
1073 sv_type != SVt_PVCV &&
1074 sv_type != SVt_PVGV &&
1075 sv_type != SVt_PVFM &&
1076 sv_type != SVt_PVIO &&
1077 !(len == 1 && sv_type == SVt_PV &&
1078 (*name == 'a' || *name == 'b')) )
1080 gvp = (GV**)hv_fetch(stash,name,len,0);
1082 *gvp == (const GV *)&PL_sv_undef ||
1083 SvTYPE(*gvp) != SVt_PVGV)
1087 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1088 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1089 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1091 /* diag_listed_as: Variable "%s" is not imported%s */
1092 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
1093 sv_type == SVt_PVAV ? '@' :
1094 sv_type == SVt_PVHV ? '%' : '$',
1097 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
1103 stash = CopSTASH(PL_curcop);
1106 stash = PL_defstash;
1109 /* By this point we should have a stash and a name */
1113 SV * const err = Perl_mess(aTHX_
1114 "Global symbol \"%s%s\" requires explicit package name",
1115 (sv_type == SVt_PV ? "$"
1116 : sv_type == SVt_PVAV ? "@"
1117 : sv_type == SVt_PVHV ? "%"
1120 if (USE_UTF8_IN_NAMES)
1123 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1125 /* symbol table under destruction */
1134 if (!SvREFCNT(stash)) /* symbol table under destruction */
1137 gvp = (GV**)hv_fetch(stash,name,len,add);
1138 if (!gvp || *gvp == (const GV *)&PL_sv_undef)
1141 if (SvTYPE(gv) == SVt_PVGV) {
1144 gv_init_sv(gv, sv_type);
1145 if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1147 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1148 else if (*name == '-' || *name == '+')
1149 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1153 } else if (no_init) {
1155 } else if (no_expand && SvROK(gv)) {
1159 /* Adding a new symbol.
1160 Unless of course there was already something non-GV here, in which case
1161 we want to behave as if there was always a GV here, containing some sort
1163 Otherwise we run the risk of creating things like GvIO, which can cause
1164 subtle bugs. eg the one that tripped up SQL::Translator */
1166 faking_it = SvOK(gv);
1168 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
1169 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1170 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1171 gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1173 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1174 : (PL_dowarn & G_WARN_ON ) ) )
1177 /* set up magic where warranted */
1182 /* Nothing else to do.
1183 The compiler will probably turn the switch statement into a
1184 branch table. Make sure we avoid even that small overhead for
1185 the common case of lower case variable names. */
1189 const char * const name2 = name + 1;
1192 if (strEQ(name2, "RGV")) {
1193 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1195 else if (strEQ(name2, "RGVOUT")) {
1200 if (strnEQ(name2, "XPORT", 5))
1204 if (strEQ(name2, "SA")) {
1205 AV* const av = GvAVn(gv);
1207 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1209 /* NOTE: No support for tied ISA */
1210 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1211 && AvFILLp(av) == -1)
1213 av_push(av, newSVpvs("NDBM_File"));
1214 gv_stashpvs("NDBM_File", GV_ADD);
1215 av_push(av, newSVpvs("DB_File"));
1216 gv_stashpvs("DB_File", GV_ADD);
1217 av_push(av, newSVpvs("GDBM_File"));
1218 gv_stashpvs("GDBM_File", GV_ADD);
1219 av_push(av, newSVpvs("SDBM_File"));
1220 gv_stashpvs("SDBM_File", GV_ADD);
1221 av_push(av, newSVpvs("ODBM_File"));
1222 gv_stashpvs("ODBM_File", GV_ADD);
1227 if (strEQ(name2, "VERLOAD")) {
1228 HV* const hv = GvHVn(gv);
1230 hv_magic(hv, NULL, PERL_MAGIC_overload);
1234 if (strEQ(name2, "IG")) {
1237 if (!PL_psig_name) {
1238 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1239 Newxz(PL_psig_pend, SIG_SIZE, int);
1240 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1242 /* I think that the only way to get here is to re-use an
1243 embedded perl interpreter, where the previous
1244 use didn't clean up fully because
1245 PL_perl_destruct_level was 0. I'm not sure that we
1246 "support" that, in that I suspect in that scenario
1247 there are sufficient other garbage values left in the
1248 interpreter structure that something else will crash
1249 before we get here. I suspect that this is one of
1250 those "doctor, it hurts when I do this" bugs. */
1251 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1252 Zero(PL_psig_pend, SIG_SIZE, int);
1256 hv_magic(hv, NULL, PERL_MAGIC_sig);
1257 for (i = 1; i < SIG_SIZE; i++) {
1258 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1260 sv_setsv(*init, &PL_sv_undef);
1265 if (strEQ(name2, "ERSION"))
1268 case '\003': /* $^CHILD_ERROR_NATIVE */
1269 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1272 case '\005': /* $^ENCODING */
1273 if (strEQ(name2, "NCODING"))
1276 case '\015': /* $^MATCH */
1277 if (strEQ(name2, "ATCH"))
1279 case '\017': /* $^OPEN */
1280 if (strEQ(name2, "PEN"))
1283 case '\020': /* $^PREMATCH $^POSTMATCH */
1284 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1286 case '\024': /* ${^TAINT} */
1287 if (strEQ(name2, "AINT"))
1290 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1291 if (strEQ(name2, "NICODE"))
1293 if (strEQ(name2, "TF8LOCALE"))
1295 if (strEQ(name2, "TF8CACHE"))
1298 case '\027': /* $^WARNING_BITS */
1299 if (strEQ(name2, "ARNING_BITS"))
1312 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1314 /* This snippet is taken from is_gv_magical */
1315 const char *end = name + len;
1316 while (--end > name) {
1317 if (!isDIGIT(*end)) return gv;
1324 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1325 be case '\0' in this switch statement (ie a default case) */
1331 sv_type == SVt_PVAV ||
1332 sv_type == SVt_PVHV ||
1333 sv_type == SVt_PVCV ||
1334 sv_type == SVt_PVFM ||
1337 PL_sawampersand = TRUE;
1341 sv_setpv(GvSVn(gv),PL_chopset);
1345 #ifdef COMPLEX_STATUS
1346 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1352 /* If %! has been used, automatically load Errno.pm. */
1354 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1356 /* magicalization must be done before require_tie_mod is called */
1357 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1358 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1363 GvMULTI_on(gv); /* no used once warnings here */
1365 AV* const av = GvAVn(gv);
1366 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1368 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1369 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1371 SvREADONLY_on(GvSVn(gv));
1374 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1375 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1381 if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
1382 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1383 "$%c is no longer supported", *name);
1386 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1389 case '\010': /* $^H */
1391 HV *const hv = GvHVn(gv);
1392 hv_magic(hv, NULL, PERL_MAGIC_hints);
1395 case '\023': /* $^S */
1397 SvREADONLY_on(GvSVn(gv));
1421 case '\001': /* $^A */
1422 case '\003': /* $^C */
1423 case '\004': /* $^D */
1424 case '\005': /* $^E */
1425 case '\006': /* $^F */
1426 case '\011': /* $^I, NOT \t in EBCDIC */
1427 case '\016': /* $^N */
1428 case '\017': /* $^O */
1429 case '\020': /* $^P */
1430 case '\024': /* $^T */
1431 case '\027': /* $^W */
1433 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1436 case '\014': /* $^L */
1437 sv_setpvs(GvSVn(gv),"\f");
1438 PL_formfeed = GvSVn(gv);
1441 sv_setpvs(GvSVn(gv),"\034");
1445 SV * const sv = GvSVn(gv);
1446 if (!sv_derived_from(PL_patchlevel, "version"))
1447 upg_version(PL_patchlevel, TRUE);
1448 GvSV(gv) = vnumify(PL_patchlevel);
1449 SvREADONLY_on(GvSV(gv));
1453 case '\026': /* $^V */
1455 SV * const sv = GvSVn(gv);
1456 GvSV(gv) = new_version(PL_patchlevel);
1457 SvREADONLY_on(GvSV(gv));
1467 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1471 const HV * const hv = GvSTASH(gv);
1473 PERL_ARGS_ASSERT_GV_FULLNAME4;
1479 sv_setpv(sv, prefix ? prefix : "");
1481 name = HvNAME_get(hv);
1483 namelen = HvNAMELEN_get(hv);
1489 if (keepmain || strNE(name, "main")) {
1490 sv_catpvn(sv,name,namelen);
1493 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1497 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1499 const GV * const egv = GvEGV(gv);
1501 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1503 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1511 IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO));
1512 /* This used to read SvREFCNT(io) = 1;
1513 It's not clear why the reference count needed an explicit reset. NWC
1515 assert (SvREFCNT(io) == 1);
1517 /* Clear the stashcache because a new IO could overrule a package name */
1518 hv_clear(PL_stashcache);
1519 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1520 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1521 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1522 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1523 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1528 Perl_gv_check(pTHX_ const HV *stash)
1533 PERL_ARGS_ASSERT_GV_CHECK;
1535 if (!HvARRAY(stash))
1537 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1539 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1542 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1543 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1545 if (hv != PL_defstash && hv != stash)
1546 gv_check(hv); /* nested package */
1548 else if (isALPHA(*HeKEY(entry))) {
1550 gv = MUTABLE_GV(HeVAL(entry));
1551 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1554 CopLINE_set(PL_curcop, GvLINE(gv));
1556 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1558 CopFILEGV(PL_curcop)
1559 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1561 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1562 "Name \"%s::%s\" used only once: possible typo",
1563 HvNAME_get(stash), GvNAME(gv));
1570 Perl_newGVgen(pTHX_ const char *pack)
1574 PERL_ARGS_ASSERT_NEWGVGEN;
1576 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1580 /* hopefully this is only called on local symbol table entries */
1583 Perl_gp_ref(pTHX_ GP *gp)
1591 /* If the GP they asked for a reference to contains
1592 a method cache entry, clear it first, so that we
1593 don't infect them with our cached entry */
1594 SvREFCNT_dec(gp->gp_cv);
1603 Perl_gp_free(pTHX_ GV *gv)
1608 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1610 if (gp->gp_refcnt == 0) {
1611 if (ckWARN_d(WARN_INTERNAL))
1612 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1613 "Attempt to free unreferenced glob pointers"
1614 pTHX__FORMAT pTHX__VALUE);
1617 if (--gp->gp_refcnt > 0) {
1618 if (gp->gp_egv == gv)
1624 if (gp->gp_file_hek)
1625 unshare_hek(gp->gp_file_hek);
1626 SvREFCNT_dec(gp->gp_sv);
1627 SvREFCNT_dec(gp->gp_av);
1628 /* FIXME - another reference loop GV -> symtab -> GV ?
1629 Somehow gp->gp_hv can end up pointing at freed garbage. */
1630 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1631 const char *hvname = HvNAME_get(gp->gp_hv);
1632 if (PL_stashcache && hvname)
1633 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1635 SvREFCNT_dec(gp->gp_hv);
1637 SvREFCNT_dec(gp->gp_io);
1638 SvREFCNT_dec(gp->gp_cv);
1639 SvREFCNT_dec(gp->gp_form);
1646 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1648 AMT * const amtp = (AMT*)mg->mg_ptr;
1649 PERL_UNUSED_ARG(sv);
1651 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1653 if (amtp && AMT_AMAGIC(amtp)) {
1655 for (i = 1; i < NofAMmeth; i++) {
1656 CV * const cv = amtp->table[i];
1658 SvREFCNT_dec(MUTABLE_SV(cv));
1659 amtp->table[i] = NULL;
1666 /* Updates and caches the CV's */
1669 Perl_Gv_AMupdate(pTHX_ HV *stash)
1672 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1674 const struct mro_meta* stash_meta = HvMROMETA(stash);
1677 PERL_ARGS_ASSERT_GV_AMUPDATE;
1679 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1681 const AMT * const amtp = (AMT*)mg->mg_ptr;
1682 if (amtp->was_ok_am == PL_amagic_generation
1683 && amtp->was_ok_sub == newgen) {
1684 return (bool)AMT_OVERLOADED(amtp);
1686 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1689 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1692 amt.was_ok_am = PL_amagic_generation;
1693 amt.was_ok_sub = newgen;
1694 amt.fallback = AMGfallNO;
1698 int filled = 0, have_ovl = 0;
1701 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1703 /* Try to find via inheritance. */
1704 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1705 SV * const sv = gv ? GvSV(gv) : NULL;
1709 lim = DESTROY_amg; /* Skip overloading entries. */
1710 #ifdef PERL_DONT_CREATE_GVSV
1712 NOOP; /* Equivalent to !SvTRUE and !SvOK */
1715 else if (SvTRUE(sv))
1716 amt.fallback=AMGfallYES;
1718 amt.fallback=AMGfallNEVER;
1720 for (i = 1; i < lim; i++)
1721 amt.table[i] = NULL;
1722 for (; i < NofAMmeth; i++) {
1723 const char * const cooky = PL_AMG_names[i];
1724 /* Human-readable form, for debugging: */
1725 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1726 const STRLEN l = PL_AMG_namelens[i];
1728 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1729 cp, HvNAME_get(stash)) );
1730 /* don't fill the cache while looking up!
1731 Creation of inheritance stubs in intermediate packages may
1732 conflict with the logic of runtime method substitution.
1733 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1734 then we could have created stubs for "(+0" in A and C too.
1735 But if B overloads "bool", we may want to use it for
1736 numifying instead of C's "+0". */
1737 if (i >= DESTROY_amg)
1738 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1739 else /* Autoload taken care of below */
1740 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1742 if (gv && (cv = GvCV(gv))) {
1744 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1745 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1746 /* This is a hack to support autoloading..., while
1747 knowing *which* methods were declared as overloaded. */
1748 /* GvSV contains the name of the method. */
1750 SV *gvsv = GvSV(gv);
1752 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1753 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1754 (void*)GvSV(gv), cp, hvname) );
1755 if (!gvsv || !SvPOK(gvsv)
1756 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1759 /* Can be an import stub (created by "can"). */
1760 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1761 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1762 "in package \"%.256s\"",
1763 (GvCVGEN(gv) ? "Stub found while resolving"
1767 cv = GvCV(gv = ngv);
1769 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1770 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1771 GvNAME(CvGV(cv))) );
1773 if (i < DESTROY_amg)
1775 } else if (gv) { /* Autoloaded... */
1776 cv = MUTABLE_CV(gv);
1779 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
1782 AMT_AMAGIC_on(&amt);
1784 AMT_OVERLOADED_on(&amt);
1785 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1786 (char*)&amt, sizeof(AMT));
1790 /* Here we have no table: */
1792 AMT_AMAGIC_off(&amt);
1793 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1794 (char*)&amt, sizeof(AMTS));
1800 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1806 struct mro_meta* stash_meta;
1808 if (!stash || !HvNAME_get(stash))
1811 stash_meta = HvMROMETA(stash);
1812 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1814 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1818 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1821 amtp = (AMT*)mg->mg_ptr;
1822 if ( amtp->was_ok_am != PL_amagic_generation
1823 || amtp->was_ok_sub != newgen )
1825 if (AMT_AMAGIC(amtp)) {
1826 CV * const ret = amtp->table[id];
1827 if (ret && isGV(ret)) { /* Autoloading stab */
1828 /* Passing it through may have resulted in a warning
1829 "Inherited AUTOLOAD for a non-method deprecated", since
1830 our caller is going through a function call, not a method call.
1831 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1832 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1845 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1850 CV **cvp=NULL, **ocvp=NULL;
1851 AMT *amtp=NULL, *oamtp=NULL;
1852 int off = 0, off1, lr = 0, notfound = 0;
1853 int postpr = 0, force_cpy = 0;
1854 int assign = AMGf_assign & flags;
1855 const int assignshift = assign ? 1 : 0;
1861 PERL_ARGS_ASSERT_AMAGIC_CALL;
1863 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
1864 SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1865 0, "overloading", 11, 0, 0);
1867 if ( !lex_mask || !SvOK(lex_mask) )
1868 /* overloading lexically disabled */
1870 else if ( lex_mask && SvPOK(lex_mask) ) {
1871 /* we have an entry in the hints hash, check if method has been
1872 * masked by overloading.pm */
1874 const int offset = method / 8;
1875 const int bit = method % 8;
1876 char *pv = SvPV(lex_mask, len);
1878 /* Bit set, so this overloading operator is disabled */
1879 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
1884 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1885 && (stash = SvSTASH(SvRV(left)))
1886 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
1887 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1888 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1890 && ((cv = cvp[off=method+assignshift])
1891 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1897 cv = cvp[off=method])))) {
1898 lr = -1; /* Call method for left argument */
1900 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1903 /* look for substituted methods */
1904 /* In all the covered cases we should be called with assign==0. */
1908 if ((cv = cvp[off=add_ass_amg])
1909 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1910 right = &PL_sv_yes; lr = -1; assign = 1;
1915 if ((cv = cvp[off = subtr_ass_amg])
1916 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1917 right = &PL_sv_yes; lr = -1; assign = 1;
1921 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1924 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1927 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1930 (void)((cv = cvp[off=bool__amg])
1931 || (cv = cvp[off=numer_amg])
1932 || (cv = cvp[off=string_amg]));
1938 * SV* ref causes confusion with the interpreter variable of
1941 SV* const tmpRef=SvRV(left);
1942 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1944 * Just to be extra cautious. Maybe in some
1945 * additional cases sv_setsv is safe, too.
1947 SV* const newref = newSVsv(tmpRef);
1948 SvOBJECT_on(newref);
1949 /* As a bit of a source compatibility hack, SvAMAGIC() and
1950 friends dereference an RV, to behave the same was as when
1951 overloading was stored on the reference, not the referant.
1952 Hence we can't use SvAMAGIC_on()
1954 SvFLAGS(newref) |= SVf_AMAGIC;
1955 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
1961 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1962 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1963 SV* const nullsv=sv_2mortal(newSViv(0));
1965 SV* const lessp = amagic_call(left,nullsv,
1966 lt_amg,AMGf_noright);
1967 logic = SvTRUE(lessp);
1969 SV* const lessp = amagic_call(left,nullsv,
1970 ncmp_amg,AMGf_noright);
1971 logic = (SvNV(lessp) < 0);
1974 if (off==subtr_amg) {
1985 if ((cv = cvp[off=subtr_amg])) {
1987 left = sv_2mortal(newSViv(0));
1992 case iter_amg: /* XXXX Eventually should do to_gv. */
1993 case ftest_amg: /* XXXX Eventually should do to_gv. */
1995 return NULL; /* Delegate operation to standard mechanisms. */
2003 return left; /* Delegate operation to standard mechanisms. */
2008 if (!cv) goto not_found;
2009 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2010 && (stash = SvSTASH(SvRV(right)))
2011 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2012 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2013 ? (amtp = (AMT*)mg->mg_ptr)->table
2015 && (cv = cvp[off=method])) { /* Method for right
2018 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
2019 && (cvp=ocvp) && (lr = -1))
2020 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
2021 && !(flags & AMGf_unary)) {
2022 /* We look for substitution for
2023 * comparison operations and
2025 if (method==concat_amg || method==concat_ass_amg
2026 || method==repeat_amg || method==repeat_ass_amg) {
2027 return NULL; /* Delegate operation to string conversion */
2037 postpr = 1; off=ncmp_amg; break;
2044 postpr = 1; off=scmp_amg; break;
2046 if (off != -1) cv = cvp[off];
2051 not_found: /* No method found, either report or croak */
2072 return left; /* Delegate operation to standard mechanisms. */
2075 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2076 notfound = 1; lr = -1;
2077 } else if (cvp && (cv=cvp[nomethod_amg])) {
2078 notfound = 1; lr = 1;
2079 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2080 /* Skip generating the "no method found" message. */
2084 if (off==-1) off=method;
2085 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2086 "Operation \"%s\": no method found,%sargument %s%s%s%s",
2087 AMG_id2name(method + assignshift),
2088 (flags & AMGf_unary ? " " : "\n\tleft "),
2090 "in overloaded package ":
2091 "has no overloaded magic",
2093 HvNAME_get(SvSTASH(SvRV(left))):
2096 ",\n\tright argument in overloaded package ":
2099 : ",\n\tright argument has no overloaded magic"),
2101 HvNAME_get(SvSTASH(SvRV(right))):
2103 if (amtp && amtp->fallback >= AMGfallYES) {
2104 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2106 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2110 force_cpy = force_cpy || assign;
2115 DEBUG_o(Perl_deb(aTHX_
2116 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2118 method+assignshift==off? "" :
2120 method+assignshift==off? "" :
2121 AMG_id2name(method+assignshift),
2122 method+assignshift==off? "" : "\")",
2123 flags & AMGf_unary? "" :
2124 lr==1 ? " for right argument": " for left argument",
2125 flags & AMGf_unary? " for argument" : "",
2126 stash ? HvNAME_get(stash) : "null",
2127 fl? ",\n\tassignment variant used": "") );
2130 /* Since we use shallow copy during assignment, we need
2131 * to dublicate the contents, probably calling user-supplied
2132 * version of copy operator
2134 /* We need to copy in following cases:
2135 * a) Assignment form was called.
2136 * assignshift==1, assign==T, method + 1 == off
2137 * b) Increment or decrement, called directly.
2138 * assignshift==0, assign==0, method + 0 == off
2139 * c) Increment or decrement, translated to assignment add/subtr.
2140 * assignshift==0, assign==T,
2142 * d) Increment or decrement, translated to nomethod.
2143 * assignshift==0, assign==0,
2145 * e) Assignment form translated to nomethod.
2146 * assignshift==1, assign==T, method + 1 != off
2149 /* off is method, method+assignshift, or a result of opcode substitution.
2150 * In the latter case assignshift==0, so only notfound case is important.
2152 if (( (method + assignshift == off)
2153 && (assign || (method == inc_amg) || (method == dec_amg)))
2160 const bool oldcatch = CATCH_GET;
2163 Zero(&myop, 1, BINOP);
2164 myop.op_last = (OP *) &myop;
2165 myop.op_next = NULL;
2166 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2168 PUSHSTACKi(PERLSI_OVERLOAD);
2171 PL_op = (OP *) &myop;
2172 if (PERLDB_SUB && PL_curstash != PL_debstash)
2173 PL_op->op_private |= OPpENTERSUB_DB;
2177 EXTEND(SP, notfound + 5);
2178 PUSHs(lr>0? right: left);
2179 PUSHs(lr>0? left: right);
2180 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2182 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2183 AMG_id2namelen(method + assignshift), SVs_TEMP));
2185 PUSHs(MUTABLE_SV(cv));
2188 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2196 CATCH_SET(oldcatch);
2203 ans=SvIV(res)<=0; break;
2206 ans=SvIV(res)<0; break;
2209 ans=SvIV(res)>=0; break;
2212 ans=SvIV(res)>0; break;
2215 ans=SvIV(res)==0; break;
2218 ans=SvIV(res)!=0; break;
2221 SvSetSV(left,res); return left;
2223 ans=!SvTRUE(res); break;
2228 } else if (method==copy_amg) {
2230 Perl_croak(aTHX_ "Copy method did not return a reference");
2232 return SvREFCNT_inc(SvRV(res));
2240 =for apidoc is_gv_magical_sv
2242 Returns C<TRUE> if given the name of a magical GV.
2244 Currently only useful internally when determining if a GV should be
2245 created even in rvalue contexts.
2247 C<flags> is not used at present but available for future extension to
2248 allow selecting particular classes of magical variable.
2250 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2251 This assumption is met by all callers within the perl core, which all pass
2252 pointers returned by SvPV.
2258 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2261 const char *const name = SvPV_const(name_sv, len);
2263 PERL_UNUSED_ARG(flags);
2264 PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2267 const char * const name1 = name + 1;
2270 if (len == 3 && name[1] == 'S' && name[2] == 'A')
2274 if (len == 8 && strEQ(name1, "VERLOAD"))
2278 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2281 /* Using ${^...} variables is likely to be sufficiently rare that
2282 it seems sensible to avoid the space hit of also checking the
2284 case '\017': /* ${^OPEN} */
2285 if (strEQ(name1, "PEN"))
2288 case '\024': /* ${^TAINT} */
2289 if (strEQ(name1, "AINT"))
2292 case '\025': /* ${^UNICODE} */
2293 if (strEQ(name1, "NICODE"))
2295 if (strEQ(name1, "TF8LOCALE"))
2298 case '\027': /* ${^WARNING_BITS} */
2299 if (strEQ(name1, "ARNING_BITS"))
2312 const char *end = name + len;
2313 while (--end > name) {
2321 /* Because we're already assuming that name is NUL terminated
2322 below, we can treat an empty name as "\0" */
2348 case '\001': /* $^A */
2349 case '\003': /* $^C */
2350 case '\004': /* $^D */
2351 case '\005': /* $^E */
2352 case '\006': /* $^F */
2353 case '\010': /* $^H */
2354 case '\011': /* $^I, NOT \t in EBCDIC */
2355 case '\014': /* $^L */
2356 case '\016': /* $^N */
2357 case '\017': /* $^O */
2358 case '\020': /* $^P */
2359 case '\023': /* $^S */
2360 case '\024': /* $^T */
2361 case '\026': /* $^V */
2362 case '\027': /* $^W */
2382 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2387 PERL_ARGS_ASSERT_GV_NAME_SET;
2388 PERL_UNUSED_ARG(flags);
2391 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2393 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2394 unshare_hek(GvNAME_HEK(gv));
2397 PERL_HASH(hash, name, len);
2398 GvNAME_HEK(gv) = share_hek(name, len, hash);
2403 * c-indentation-style: bsd
2405 * indent-tabs-mode: t
2408 * ex: set ts=8 sts=4 sw=4 noet: