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.
41 static const char S_autoload[] = "AUTOLOAD";
42 static const STRLEN S_autolen = sizeof(S_autoload)-1;
45 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
52 SvTYPE((const SV *)gv) != SVt_PVGV
53 && SvTYPE((const SV *)gv) != SVt_PVLV
57 if (type == SVt_PVIO) {
59 * if it walks like a dirhandle, then let's assume that
60 * this is a dirhandle.
62 what = PL_op->op_type == OP_READDIR ||
63 PL_op->op_type == OP_TELLDIR ||
64 PL_op->op_type == OP_SEEKDIR ||
65 PL_op->op_type == OP_REWINDDIR ||
66 PL_op->op_type == OP_CLOSEDIR ?
67 "dirhandle" : "filehandle";
68 /* diag_listed_as: Bad symbol for filehandle */
69 } else if (type == SVt_PVHV) {
72 what = type == SVt_PVAV ? "array" : "scalar";
74 Perl_croak(aTHX_ "Bad symbol for %s", what);
77 if (type == SVt_PVHV) {
78 where = (SV **)&GvHV(gv);
79 } else if (type == SVt_PVAV) {
80 where = (SV **)&GvAV(gv);
81 } else if (type == SVt_PVIO) {
82 where = (SV **)&GvIOp(gv);
88 *where = newSV_type(type);
93 Perl_gv_fetchfile(pTHX_ const char *name)
95 PERL_ARGS_ASSERT_GV_FETCHFILE;
96 return gv_fetchfile_flags(name, strlen(name), 0);
100 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
106 const STRLEN tmplen = namelen + 2;
109 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
110 PERL_UNUSED_ARG(flags);
115 if (tmplen <= sizeof smallbuf)
118 Newx(tmpbuf, tmplen, char);
119 /* This is where the debugger's %{"::_<$filename"} hash is created */
122 memcpy(tmpbuf + 2, name, namelen);
123 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
125 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
126 #ifdef PERL_DONT_CREATE_GVSV
127 GvSV(gv) = newSVpvn(name, namelen);
129 sv_setpvn(GvSV(gv), name, namelen);
132 if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
133 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
134 if (tmpbuf != smallbuf)
140 =for apidoc gv_const_sv
142 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
143 inlining, or C<gv> is a placeholder reference that would be promoted to such
144 a typeglob, then returns the value returned by the sub. Otherwise, returns
151 Perl_gv_const_sv(pTHX_ GV *gv)
153 PERL_ARGS_ASSERT_GV_CONST_SV;
155 if (SvTYPE(gv) == SVt_PVGV)
156 return cv_const_sv(GvCVu(gv));
157 return SvROK(gv) ? SvRV(gv) : NULL;
161 Perl_newGP(pTHX_ GV *const gv)
166 const char *const file
167 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
168 const STRLEN len = strlen(file);
170 SV *const temp_sv = CopFILESV(PL_curcop);
174 PERL_ARGS_ASSERT_NEWGP;
177 file = SvPVX(temp_sv);
178 len = SvCUR(temp_sv);
185 PERL_HASH(hash, file, len);
189 #ifndef PERL_DONT_CREATE_GVSV
190 gp->gp_sv = newSV(0);
193 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
194 /* XXX Ideally this cast would be replaced with a change to const char*
196 gp->gp_file_hek = share_hek(file, len, hash);
203 /* Assign CvGV(cv) = gv, handling weak references.
204 * See also S_anonymise_cv_maybe */
207 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
209 GV * const oldgv = CvGV(cv);
210 PERL_ARGS_ASSERT_CVGV_SET;
221 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
225 SvANY(cv)->xcv_gv = gv;
226 assert(!CvCVGV_RC(cv));
231 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
232 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
235 SvREFCNT_inc_simple_void_NN(gv);
239 /* Assign CvSTASH(cv) = st, handling weak references. */
242 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
244 HV *oldst = CvSTASH(cv);
245 PERL_ARGS_ASSERT_CVSTASH_SET;
249 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
250 SvANY(cv)->xcv_stash = st;
252 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
256 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
259 const U32 old_type = SvTYPE(gv);
260 const bool doproto = old_type > SVt_NULL;
261 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
262 const STRLEN protolen = proto ? SvCUR(gv) : 0;
263 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
264 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
266 PERL_ARGS_ASSERT_GV_INIT;
267 assert (!(proto && has_constant));
270 /* The constant has to be a simple scalar type. */
271 switch (SvTYPE(has_constant)) {
277 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
278 sv_reftype(has_constant, 0));
286 if (old_type < SVt_PVGV) {
287 if (old_type >= SVt_PV)
289 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
297 Safefree(SvPVX_mutable(gv));
302 GvGP_set(gv, Perl_newGP(aTHX_ gv));
305 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
306 gv_name_set(gv, name, len, GV_ADD);
307 if (multi || doproto) /* doproto means it _was_ mentioned */
309 if (doproto) { /* Replicate part of newSUB here. */
315 /* newCONSTSUB doesn't take a len arg, so make sure we
316 * give it a \0-terminated string */
317 name0 = savepvn(name,len);
319 /* newCONSTSUB takes ownership of the reference from us. */
320 cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
321 /* In case op.c:S_process_special_blocks stole it: */
323 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
324 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
327 /* If this reference was a copy of another, then the subroutine
328 must have been "imported", by a Perl space assignment to a GV
329 from a reference to CV. */
330 if (exported_constant)
331 GvIMPORTED_CV_on(gv);
333 (void) start_subparse(0,0); /* Create empty CV in compcv. */
339 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
341 CvFILE_set_from_cop(cv, PL_curcop);
342 CvSTASH_set(cv, PL_curstash);
344 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
345 SV_HAS_TRAILING_NUL);
351 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
353 PERL_ARGS_ASSERT_GV_INIT_SV;
365 #ifdef PERL_DONT_CREATE_GVSV
373 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
374 If we just cast GvSVn(gv) to void, it ignores evaluating it for
382 =for apidoc gv_fetchmeth
384 Returns the glob with the given C<name> and a defined subroutine or
385 C<NULL>. The glob lives in the given C<stash>, or in the stashes
386 accessible via @ISA and UNIVERSAL::.
388 The argument C<level> should be either 0 or -1. If C<level==0>, as a
389 side-effect creates a glob with the given C<name> in the given C<stash>
390 which in the case of success contains an alias for the subroutine, and sets
391 up caching info for this glob.
393 This function grants C<"SUPER"> token as a postfix of the stash name. The
394 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
395 visible to Perl code. So when calling C<call_sv>, you should not use
396 the GV directly; instead, you should use the method's CV, which can be
397 obtained from the GV with the C<GvCV> macro.
402 /* NOTE: No support for tied ISA */
405 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
413 GV* candidate = NULL;
417 I32 create = (level >= 0) ? 1 : 0;
422 PERL_ARGS_ASSERT_GV_FETCHMETH;
424 /* UNIVERSAL methods should be callable without a stash */
426 create = 0; /* probably appropriate */
427 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
433 hvname = HvNAME_get(stash);
435 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
440 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
442 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
444 /* check locally for a real method or a cache entry */
445 gvp = (GV**)hv_fetch(stash, name, len, create);
449 if (SvTYPE(topgv) != SVt_PVGV)
450 gv_init(topgv, stash, name, len, TRUE);
451 if ((cand_cv = GvCV(topgv))) {
452 /* If genuine method or valid cache entry, use it */
453 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
457 /* stale cache entry, junk it and move on */
458 SvREFCNT_dec(cand_cv);
459 GvCV_set(topgv, NULL);
464 else if (GvCVGEN(topgv) == topgen_cmp) {
465 /* cache indicates no such method definitively */
470 packlen = HvNAMELEN_get(stash);
471 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
474 basestash = gv_stashpvn(hvname, packlen, GV_ADD);
475 linear_av = mro_get_linear_isa(basestash);
478 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
481 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
482 items = AvFILLp(linear_av); /* no +1, to skip over self */
484 linear_sv = *linear_svp++;
486 cstash = gv_stashsv(linear_sv, 0);
489 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
490 SVfARG(linear_sv), hvname);
496 gvp = (GV**)hv_fetch(cstash, name, len, 0);
500 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
501 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
503 * Found real method, cache method in topgv if:
504 * 1. topgv has no synonyms (else inheritance crosses wires)
505 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
507 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
508 CV *old_cv = GvCV(topgv);
509 SvREFCNT_dec(old_cv);
510 SvREFCNT_inc_simple_void_NN(cand_cv);
511 GvCV_set(topgv, cand_cv);
512 GvCVGEN(topgv) = topgen_cmp;
518 /* Check UNIVERSAL without caching */
519 if(level == 0 || level == -1) {
520 candidate = gv_fetchmeth(NULL, name, len, 1);
522 cand_cv = GvCV(candidate);
523 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
524 CV *old_cv = GvCV(topgv);
525 SvREFCNT_dec(old_cv);
526 SvREFCNT_inc_simple_void_NN(cand_cv);
527 GvCV_set(topgv, cand_cv);
528 GvCVGEN(topgv) = topgen_cmp;
534 if (topgv && GvREFCNT(topgv) == 1) {
535 /* cache the fact that the method is not defined */
536 GvCVGEN(topgv) = topgen_cmp;
543 =for apidoc gv_fetchmeth_autoload
545 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
546 Returns a glob for the subroutine.
548 For an autoloaded subroutine without a GV, will create a GV even
549 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
550 of the result may be zero.
556 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
558 GV *gv = gv_fetchmeth(stash, name, len, level);
560 PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
567 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
568 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
570 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
573 if (!(CvROOT(cv) || CvXSUB(cv)))
575 /* Have an autoload */
576 if (level < 0) /* Cannot do without a stub */
577 gv_fetchmeth(stash, name, len, 0);
578 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
587 =for apidoc gv_fetchmethod_autoload
589 Returns the glob which contains the subroutine to call to invoke the method
590 on the C<stash>. In fact in the presence of autoloading this may be the
591 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
594 The third parameter of C<gv_fetchmethod_autoload> determines whether
595 AUTOLOAD lookup is performed if the given method is not present: non-zero
596 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
597 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
598 with a non-zero C<autoload> parameter.
600 These functions grant C<"SUPER"> token as a prefix of the method name. Note
601 that if you want to keep the returned glob for a long time, you need to
602 check for it being "AUTOLOAD", since at the later time the call may load a
603 different subroutine due to $AUTOLOAD changing its value. Use the glob
604 created via a side effect to do this.
606 These functions have the same side-effects and as C<gv_fetchmeth> with
607 C<level==0>. C<name> should be writable if contains C<':'> or C<'
608 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
609 C<call_sv> apply equally to these functions.
615 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
622 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
624 stash = gv_stashpvn(name, namelen, 0);
625 if(stash) return stash;
627 /* If we must create it, give it an @ISA array containing
628 the real package this SUPER is for, so that it's tied
629 into the cache invalidation code correctly */
630 stash = gv_stashpvn(name, namelen, GV_ADD);
631 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
633 gv_init(gv, stash, "ISA", 3, TRUE);
634 superisa = GvAVn(gv);
636 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
638 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
640 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
641 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
648 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
650 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
652 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
655 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
658 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
661 register const char *nend;
662 const char *nsplit = NULL;
665 const char * const origname = name;
666 SV *const error_report = MUTABLE_SV(stash);
667 const U32 autoload = flags & GV_AUTOLOAD;
668 const U32 do_croak = flags & GV_CROAK;
670 PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
672 if (SvTYPE(stash) < SVt_PVHV)
675 /* The only way stash can become NULL later on is if nsplit is set,
676 which in turn means that there is no need for a SVt_PVHV case
677 the error reporting code. */
680 for (nend = name; *nend; nend++) {
685 else if (*nend == ':' && *(nend + 1) == ':') {
691 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
692 /* ->SUPER::method should really be looked up in original stash */
693 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
694 CopSTASHPV(PL_curcop)));
695 /* __PACKAGE__::SUPER stash should be autovivified */
696 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
697 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
698 origname, HvNAME_get(stash), name) );
701 /* don't autovifify if ->NoSuchStash::method */
702 stash = gv_stashpvn(origname, nsplit - origname, 0);
704 /* however, explicit calls to Pkg::SUPER::method may
705 happen, and may require autovivification to work */
706 if (!stash && (nsplit - origname) >= 7 &&
707 strnEQ(nsplit - 7, "::SUPER", 7) &&
708 gv_stashpvn(origname, nsplit - origname - 7, 0))
709 stash = gv_get_super_pkg(origname, nsplit - origname);
714 gv = gv_fetchmeth(stash, name, nend - name, 0);
716 if (strEQ(name,"import") || strEQ(name,"unimport"))
717 gv = MUTABLE_GV(&PL_sv_yes);
719 gv = gv_autoload4(ostash, name, nend - name, TRUE);
720 if (!gv && do_croak) {
721 /* Right now this is exclusively for the benefit of S_method_common
724 /* If we can't find an IO::File method, it might be a call on
725 * a filehandle. If IO:File has not been loaded, try to
726 * require it first instead of croaking */
727 const char *stash_name = HvNAME_get(stash);
728 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
729 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
730 STR_WITH_LEN("IO/File.pm"), 0,
731 HV_FETCH_ISEXISTS, NULL, 0)
733 require_pv("IO/File.pm");
734 gv = gv_fetchmeth(stash, name, nend - name, 0);
739 "Can't locate object method \"%s\" via package \"%.*s\"",
740 name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
744 const char *packname;
747 packlen = nsplit - origname;
750 packname = SvPV_const(error_report, packlen);
754 "Can't locate object method \"%s\" via package \"%.*s\""
755 " (perhaps you forgot to load \"%.*s\"?)",
756 name, (int)packlen, packname, (int)packlen, packname);
761 CV* const cv = GvCV(gv);
762 if (!CvROOT(cv) && !CvXSUB(cv)) {
770 if (GvCV(stubgv) != cv) /* orphaned import */
773 autogv = gv_autoload4(GvSTASH(stubgv),
774 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
784 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
792 const char *packname = "";
793 STRLEN packname_len = 0;
795 PERL_ARGS_ASSERT_GV_AUTOLOAD4;
797 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
800 if (SvTYPE(stash) < SVt_PVHV) {
801 packname = SvPV_const(MUTABLE_SV(stash), packname_len);
805 packname = HvNAME_get(stash);
806 packname_len = HvNAMELEN_get(stash);
809 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
813 if (!(CvROOT(cv) || CvXSUB(cv)))
817 * Inheriting AUTOLOAD for non-methods works ... for now.
819 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
821 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
822 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
823 packname, (int)len, name);
826 /* rather than lookup/init $AUTOLOAD here
827 * only to have the XSUB do another lookup for $AUTOLOAD
828 * and split that value on the last '::',
829 * pass along the same data via some unused fields in the CV
831 CvSTASH_set(cv, stash);
832 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
838 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
839 * The subroutine's original name may not be "AUTOLOAD", so we don't
840 * use that, but for lack of anything better we will use the sub's
841 * original package to look up $AUTOLOAD.
843 varstash = GvSTASH(CvGV(cv));
844 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
848 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
849 #ifdef PERL_DONT_CREATE_GVSV
850 GvSV(vargv) = newSV(0);
854 varsv = GvSVn(vargv);
855 sv_setpvn(varsv, packname, packname_len);
856 sv_catpvs(varsv, "::");
857 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
858 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
859 sv_catpvn_mg(varsv, name, len);
864 /* require_tie_mod() internal routine for requiring a module
865 * that implements the logic of automatic ties like %! and %-
867 * The "gv" parameter should be the glob.
868 * "varpv" holds the name of the var, used for error messages.
869 * "namesv" holds the module name. Its refcount will be decremented.
870 * "methpv" holds the method name to test for to check that things
871 * are working reasonably close to as expected.
872 * "flags": if flag & 1 then save the scalar before loading.
873 * For the protection of $! to work (it is set by this routine)
874 * the sv slot must already be magicalized.
877 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
880 HV* stash = gv_stashsv(namesv, 0);
882 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
884 if (!stash || !(gv_fetchmethod(stash, methpv))) {
885 SV *module = newSVsv(namesv);
886 char varname = *varpv; /* varpv might be clobbered by load_module,
887 so save it. For the moment it's always
893 PUSHSTACKi(PERLSI_MAGIC);
894 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
898 stash = gv_stashsv(namesv, 0);
900 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
901 varname, SVfARG(namesv));
902 else if (!gv_fetchmethod(stash, methpv))
903 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
904 varname, SVfARG(namesv), methpv);
906 SvREFCNT_dec(namesv);
911 =for apidoc gv_stashpv
913 Returns a pointer to the stash for a specified package. Uses C<strlen> to
914 determine the length of C<name>, then calls C<gv_stashpvn()>.
920 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
922 PERL_ARGS_ASSERT_GV_STASHPV;
923 return gv_stashpvn(name, strlen(name), create);
927 =for apidoc gv_stashpvn
929 Returns a pointer to the stash for a specified package. The C<namelen>
930 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
931 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
932 created if it does not already exist. If the package does not exist and
933 C<flags> is 0 (or any other setting that does not create packages) then NULL
941 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
947 U32 tmplen = namelen + 2;
949 PERL_ARGS_ASSERT_GV_STASHPVN;
951 if (tmplen <= sizeof smallbuf)
954 Newx(tmpbuf, tmplen, char);
955 Copy(name, tmpbuf, namelen, char);
956 tmpbuf[namelen] = ':';
957 tmpbuf[namelen+1] = ':';
958 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
959 if (tmpbuf != smallbuf)
964 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
966 if (!HvNAME_get(stash)) {
967 hv_name_set(stash, name, namelen, 0);
969 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
970 /* If the containing stash has multiple effective
971 names, see that this one gets them, too. */
972 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
973 mro_package_moved(stash, NULL, tmpgv, 1);
979 =for apidoc gv_stashsv
981 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
987 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
990 const char * const ptr = SvPV_const(sv,len);
992 PERL_ARGS_ASSERT_GV_STASHSV;
994 return gv_stashpvn(ptr, len, flags);
999 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1000 PERL_ARGS_ASSERT_GV_FETCHPV;
1001 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1005 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1007 const char * const nambeg = SvPV_const(name, len);
1008 PERL_ARGS_ASSERT_GV_FETCHSV;
1009 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1013 S_gv_magicalize_isa(pTHX_ GV *gv)
1017 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1021 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1026 S_gv_magicalize_overload(pTHX_ GV *gv)
1030 PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1034 hv_magic(hv, NULL, PERL_MAGIC_overload);
1037 static void core_xsub(pTHX_ CV* cv);
1040 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1041 const svtype sv_type)
1044 register const char *name = nambeg;
1045 register GV *gv = NULL;
1048 register const char *name_cursor;
1050 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1051 const I32 no_expand = flags & GV_NOEXPAND;
1052 const I32 add = flags & ~GV_NOADD_MASK;
1053 bool addmg = !!(flags & GV_ADDMG);
1054 const char *const name_end = nambeg + full_len;
1055 const char *const name_em1 = name_end - 1;
1058 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1060 if (flags & GV_NOTQUAL) {
1061 /* Caller promised that there is no stash, so we can skip the check. */
1066 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1067 /* accidental stringify on a GV? */
1071 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1072 if (name_cursor < name_em1 &&
1073 ((*name_cursor == ':'
1074 && name_cursor[1] == ':')
1075 || *name_cursor == '\''))
1078 stash = PL_defstash;
1079 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1082 len = name_cursor - name;
1083 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1085 if (*name_cursor == ':') {
1090 Newx(tmpbuf, len+2, char);
1091 Copy(name, tmpbuf, len, char);
1092 tmpbuf[len++] = ':';
1093 tmpbuf[len++] = ':';
1096 gvp = (GV**)hv_fetch(stash, key, len, add);
1097 gv = gvp ? *gvp : NULL;
1098 if (gv && gv != (const GV *)&PL_sv_undef) {
1099 if (SvTYPE(gv) != SVt_PVGV)
1100 gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
1106 if (!gv || gv == (const GV *)&PL_sv_undef)
1109 if (!(stash = GvHV(gv)))
1111 stash = GvHV(gv) = newHV();
1112 if (!HvNAME_get(stash)) {
1113 if (GvSTASH(gv) == PL_defstash && len == 6
1114 && strnEQ(name, "CORE", 4))
1115 hv_name_set(stash, "CORE", 4, 0);
1118 stash, nambeg, name_cursor-nambeg, 0
1120 /* If the containing stash has multiple effective
1121 names, see that this one gets them, too. */
1122 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1123 mro_package_moved(stash, NULL, gv, 1);
1126 else if (!HvNAME_get(stash))
1127 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1130 if (*name_cursor == ':')
1132 name = name_cursor+1;
1133 if (name == name_end)
1135 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1138 len = name_cursor - name;
1140 /* No stash in name, so see how we can default */
1144 if (len && isIDFIRST_lazy(name)) {
1145 bool global = FALSE;
1153 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1154 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1155 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1159 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1164 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1165 && name[3] == 'I' && name[4] == 'N')
1169 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1170 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1171 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1175 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1176 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1183 stash = PL_defstash;
1184 else if (IN_PERL_COMPILETIME) {
1185 stash = PL_curstash;
1186 if (add && (PL_hints & HINT_STRICT_VARS) &&
1187 sv_type != SVt_PVCV &&
1188 sv_type != SVt_PVGV &&
1189 sv_type != SVt_PVFM &&
1190 sv_type != SVt_PVIO &&
1191 !(len == 1 && sv_type == SVt_PV &&
1192 (*name == 'a' || *name == 'b')) )
1194 gvp = (GV**)hv_fetch(stash,name,len,0);
1196 *gvp == (const GV *)&PL_sv_undef ||
1197 SvTYPE(*gvp) != SVt_PVGV)
1201 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1202 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1203 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1205 /* diag_listed_as: Variable "%s" is not imported%s */
1207 aTHX_ packWARN(WARN_MISC),
1208 "Variable \"%c%s\" is not imported",
1209 sv_type == SVt_PVAV ? '@' :
1210 sv_type == SVt_PVHV ? '%' : '$',
1214 aTHX_ packWARN(WARN_MISC),
1215 "\t(Did you mean &%s instead?)\n", name
1222 stash = CopSTASH(PL_curcop);
1225 stash = PL_defstash;
1228 /* By this point we should have a stash and a name */
1232 SV * const err = Perl_mess(aTHX_
1233 "Global symbol \"%s%s\" requires explicit package name",
1234 (sv_type == SVt_PV ? "$"
1235 : sv_type == SVt_PVAV ? "@"
1236 : sv_type == SVt_PVHV ? "%"
1239 if (USE_UTF8_IN_NAMES)
1242 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1244 /* symbol table under destruction */
1253 if (!SvREFCNT(stash)) /* symbol table under destruction */
1256 gvp = (GV**)hv_fetch(stash,name,len,add);
1257 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1258 if (addmg) gv = (GV *)newSV(0);
1262 if (SvTYPE(gv) == SVt_PVGV) {
1265 gv_init_sv(gv, sv_type);
1266 if (len == 1 && stash == PL_defstash
1267 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1269 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1270 else if (*name == '-' || *name == '+')
1271 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1273 else if (len == 3 && sv_type == SVt_PVAV
1274 && strnEQ(name, "ISA", 3)
1275 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1276 gv_magicalize_isa(gv);
1279 } else if (no_init) {
1282 } else if (no_expand && SvROK(gv)) {
1287 /* Adding a new symbol.
1288 Unless of course there was already something non-GV here, in which case
1289 we want to behave as if there was always a GV here, containing some sort
1291 Otherwise we run the risk of creating things like GvIO, which can cause
1292 subtle bugs. eg the one that tripped up SQL::Translator */
1294 faking_it = SvOK(gv);
1296 if (add & GV_ADDWARN)
1297 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1298 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1300 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1301 : (PL_dowarn & G_WARN_ON ) ) )
1304 /* set up magic where warranted */
1305 if (stash != PL_defstash) { /* not the main stash */
1306 /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1307 and VERSION. All the others apply only to the main stash or to
1308 CORE (which is checked right after this). */
1310 const char * const name2 = name + 1;
1313 if (strnEQ(name2, "XPORT", 5))
1317 if (strEQ(name2, "SA"))
1318 gv_magicalize_isa(gv);
1321 if (strEQ(name2, "VERLOAD"))
1322 gv_magicalize_overload(gv);
1325 if (strEQ(name2, "ERSION"))
1331 goto add_magical_gv;
1334 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1335 /* Avoid null warning: */
1336 const char * const stashname = HvNAME(stash); assert(stashname);
1337 if (strnEQ(stashname, "CORE", 4)) {
1338 const int code = keyword(name, len, 1);
1339 static const char file[] = __FILE__;
1343 bool ampable = TRUE; /* &{}-able */
1345 yy_parser *oldparser;
1346 I32 oldsavestack_ix;
1348 if (code >= 0) goto add_magical_gv; /* not overridable */
1350 /* no support for \&CORE::infix;
1351 no support for funcs that take labels, as their parsing is
1353 case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
1354 case KEY_eq: case KEY_ge:
1355 case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
1356 case KEY_or: case KEY_x: case KEY_xor:
1357 goto add_magical_gv;
1359 case KEY_chomp: case KEY_chop:
1360 case KEY_each: case KEY_eof: case KEY_exec:
1369 case KEY_truncate: case KEY_unlink:
1376 oldcurcop = PL_curcop;
1377 oldparser = PL_parser;
1378 lex_start(NULL, NULL, 0);
1379 oldcompcv = PL_compcv;
1380 PL_compcv = NULL; /* Prevent start_subparse from setting
1382 oldsavestack_ix = start_subparse(FALSE,0);
1386 /* Avoid calling newXS, as it calls us, and things start to
1388 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
1391 mro_method_changed_in(GvSTASH(gv));
1393 CvXSUB(cv) = core_xsub;
1395 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
1397 (void)gv_fetchfile(file);
1398 CvFILE(cv) = (char *)file;
1399 /* XXX This is inefficient, as doing things this order causes
1400 a prototype check in newATTRSUB. But we have to do
1401 it this order as we need an op number before calling
1403 (void)core_prototype((SV *)cv, name, code, &opnum);
1406 (void)hv_store(stash,name,len,(SV *)gv,0);
1410 newATTRSUB(oldsavestack_ix,
1413 newSVpvn_share(nambeg,full_len,0)
1418 ? newSVuv((UV)opnum)
1419 : newSVpvn(name,len),
1423 assert(GvCV(gv) == cv);
1424 if (opnum != OP_VEC && opnum != OP_SUBSTR)
1425 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
1427 PL_parser = oldparser;
1428 PL_curcop = oldcurcop;
1429 PL_compcv = oldcompcv;
1431 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
1432 cv_set_call_checker(
1433 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
1435 SvREFCNT_dec(opnumsv);
1443 /* Nothing else to do.
1444 The compiler will probably turn the switch statement into a
1445 branch table. Make sure we avoid even that small overhead for
1446 the common case of lower case variable names. */
1450 const char * const name2 = name + 1;
1453 if (strEQ(name2, "RGV")) {
1454 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1456 else if (strEQ(name2, "RGVOUT")) {
1461 if (strnEQ(name2, "XPORT", 5))
1465 if (strEQ(name2, "SA")) {
1466 gv_magicalize_isa(gv);
1470 if (strEQ(name2, "VERLOAD")) {
1471 gv_magicalize_overload(gv);
1475 if (strEQ(name2, "IG")) {
1478 if (!PL_psig_name) {
1479 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1480 Newxz(PL_psig_pend, SIG_SIZE, int);
1481 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1483 /* I think that the only way to get here is to re-use an
1484 embedded perl interpreter, where the previous
1485 use didn't clean up fully because
1486 PL_perl_destruct_level was 0. I'm not sure that we
1487 "support" that, in that I suspect in that scenario
1488 there are sufficient other garbage values left in the
1489 interpreter structure that something else will crash
1490 before we get here. I suspect that this is one of
1491 those "doctor, it hurts when I do this" bugs. */
1492 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1493 Zero(PL_psig_pend, SIG_SIZE, int);
1497 hv_magic(hv, NULL, PERL_MAGIC_sig);
1498 for (i = 1; i < SIG_SIZE; i++) {
1499 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1501 sv_setsv(*init, &PL_sv_undef);
1506 if (strEQ(name2, "ERSION"))
1509 case '\003': /* $^CHILD_ERROR_NATIVE */
1510 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1513 case '\005': /* $^ENCODING */
1514 if (strEQ(name2, "NCODING"))
1517 case '\007': /* $^GLOBAL_PHASE */
1518 if (strEQ(name2, "LOBAL_PHASE"))
1521 case '\015': /* $^MATCH */
1522 if (strEQ(name2, "ATCH"))
1524 case '\017': /* $^OPEN */
1525 if (strEQ(name2, "PEN"))
1528 case '\020': /* $^PREMATCH $^POSTMATCH */
1529 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1532 case '\024': /* ${^TAINT} */
1533 if (strEQ(name2, "AINT"))
1536 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1537 if (strEQ(name2, "NICODE"))
1539 if (strEQ(name2, "TF8LOCALE"))
1541 if (strEQ(name2, "TF8CACHE"))
1544 case '\027': /* $^WARNING_BITS */
1545 if (strEQ(name2, "ARNING_BITS"))
1558 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1560 /* This snippet is taken from is_gv_magical */
1561 const char *end = name + len;
1562 while (--end > name) {
1563 if (!isDIGIT(*end)) goto add_magical_gv;
1570 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1571 be case '\0' in this switch statement (ie a default case) */
1577 sv_type == SVt_PVAV ||
1578 sv_type == SVt_PVHV ||
1579 sv_type == SVt_PVCV ||
1580 sv_type == SVt_PVFM ||
1583 PL_sawampersand = TRUE;
1587 sv_setpv(GvSVn(gv),PL_chopset);
1591 #ifdef COMPLEX_STATUS
1592 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1598 /* If %! has been used, automatically load Errno.pm. */
1600 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1602 /* magicalization must be done before require_tie_mod is called */
1603 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1604 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1609 GvMULTI_on(gv); /* no used once warnings here */
1611 AV* const av = GvAVn(gv);
1612 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1614 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1615 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1617 SvREADONLY_on(GvSVn(gv));
1620 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1621 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1627 if (sv_type == SVt_PV)
1628 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1629 "$%c is no longer supported", *name);
1632 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1635 case '\010': /* $^H */
1637 HV *const hv = GvHVn(gv);
1638 hv_magic(hv, NULL, PERL_MAGIC_hints);
1641 case '\023': /* $^S */
1643 SvREADONLY_on(GvSVn(gv));
1668 case '\001': /* $^A */
1669 case '\003': /* $^C */
1670 case '\004': /* $^D */
1671 case '\005': /* $^E */
1672 case '\006': /* $^F */
1673 case '\011': /* $^I, NOT \t in EBCDIC */
1674 case '\016': /* $^N */
1675 case '\017': /* $^O */
1676 case '\020': /* $^P */
1677 case '\024': /* $^T */
1678 case '\027': /* $^W */
1680 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1683 case '\014': /* $^L */
1684 sv_setpvs(GvSVn(gv),"\f");
1685 PL_formfeed = GvSVn(gv);
1688 sv_setpvs(GvSVn(gv),"\034");
1692 SV * const sv = GvSV(gv);
1693 if (!sv_derived_from(PL_patchlevel, "version"))
1694 upg_version(PL_patchlevel, TRUE);
1695 GvSV(gv) = vnumify(PL_patchlevel);
1696 SvREADONLY_on(GvSV(gv));
1700 case '\026': /* $^V */
1702 SV * const sv = GvSV(gv);
1703 GvSV(gv) = new_version(PL_patchlevel);
1704 SvREADONLY_on(GvSV(gv));
1712 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1713 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1715 (void)hv_store(stash,name,len,(SV *)gv,0);
1716 else SvREFCNT_dec(gv), gv = NULL;
1718 if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1723 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1727 const HV * const hv = GvSTASH(gv);
1729 PERL_ARGS_ASSERT_GV_FULLNAME4;
1735 sv_setpv(sv, prefix ? prefix : "");
1737 name = HvNAME_get(hv);
1739 namelen = HvNAMELEN_get(hv);
1745 if (keepmain || strNE(name, "main")) {
1746 sv_catpvn(sv,name,namelen);
1749 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1753 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1755 const GV * const egv = GvEGVx(gv);
1757 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1759 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1763 Perl_gv_check(pTHX_ const HV *stash)
1768 PERL_ARGS_ASSERT_GV_CHECK;
1770 if (!HvARRAY(stash))
1772 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1774 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1777 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1778 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1780 if (hv != PL_defstash && hv != stash)
1781 gv_check(hv); /* nested package */
1783 else if (isALPHA(*HeKEY(entry))) {
1785 gv = MUTABLE_GV(HeVAL(entry));
1786 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1789 CopLINE_set(PL_curcop, GvLINE(gv));
1791 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1793 CopFILEGV(PL_curcop)
1794 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1796 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1797 "Name \"%s::%s\" used only once: possible typo",
1798 HvNAME_get(stash), GvNAME(gv));
1805 Perl_newGVgen(pTHX_ const char *pack)
1809 PERL_ARGS_ASSERT_NEWGVGEN;
1811 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1815 /* hopefully this is only called on local symbol table entries */
1818 Perl_gp_ref(pTHX_ GP *gp)
1826 /* If the GP they asked for a reference to contains
1827 a method cache entry, clear it first, so that we
1828 don't infect them with our cached entry */
1829 SvREFCNT_dec(gp->gp_cv);
1838 Perl_gp_free(pTHX_ GV *gv)
1844 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1846 if (gp->gp_refcnt == 0) {
1847 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1848 "Attempt to free unreferenced glob pointers"
1849 pTHX__FORMAT pTHX__VALUE);
1852 if (--gp->gp_refcnt > 0) {
1853 if (gp->gp_egv == gv)
1860 /* Copy and null out all the glob slots, so destructors do not see
1862 HEK * const file_hek = gp->gp_file_hek;
1863 SV * const sv = gp->gp_sv;
1864 AV * const av = gp->gp_av;
1865 HV * const hv = gp->gp_hv;
1866 IO * const io = gp->gp_io;
1867 CV * const cv = gp->gp_cv;
1868 CV * const form = gp->gp_form;
1870 gp->gp_file_hek = NULL;
1879 unshare_hek(file_hek);
1883 /* FIXME - another reference loop GV -> symtab -> GV ?
1884 Somehow gp->gp_hv can end up pointing at freed garbage. */
1885 if (hv && SvTYPE(hv) == SVt_PVHV) {
1886 const char *hvname = HvNAME_get(hv);
1887 if (PL_stashcache && hvname)
1888 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
1896 if (!gp->gp_file_hek
1902 && !gp->gp_form) break;
1904 if (--attempts == 0) {
1906 "panic: gp_free failed to free glob pointer - "
1907 "something is repeatedly re-creating entries"
1917 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1919 AMT * const amtp = (AMT*)mg->mg_ptr;
1920 PERL_UNUSED_ARG(sv);
1922 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1924 if (amtp && AMT_AMAGIC(amtp)) {
1926 for (i = 1; i < NofAMmeth; i++) {
1927 CV * const cv = amtp->table[i];
1929 SvREFCNT_dec(MUTABLE_SV(cv));
1930 amtp->table[i] = NULL;
1937 /* Updates and caches the CV's */
1939 * 1 on success and there is some overload
1940 * 0 if there is no overload
1941 * -1 if some error occurred and it couldn't croak
1945 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1948 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1950 const struct mro_meta* stash_meta = HvMROMETA(stash);
1953 PERL_ARGS_ASSERT_GV_AMUPDATE;
1955 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1957 const AMT * const amtp = (AMT*)mg->mg_ptr;
1958 if (amtp->was_ok_am == PL_amagic_generation
1959 && amtp->was_ok_sub == newgen) {
1960 return AMT_OVERLOADED(amtp) ? 1 : 0;
1962 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1965 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1968 amt.was_ok_am = PL_amagic_generation;
1969 amt.was_ok_sub = newgen;
1970 amt.fallback = AMGfallNO;
1974 int filled = 0, have_ovl = 0;
1977 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1979 /* Try to find via inheritance. */
1980 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1981 SV * const sv = gv ? GvSV(gv) : NULL;
1985 lim = DESTROY_amg; /* Skip overloading entries. */
1986 #ifdef PERL_DONT_CREATE_GVSV
1988 NOOP; /* Equivalent to !SvTRUE and !SvOK */
1991 else if (SvTRUE(sv))
1992 amt.fallback=AMGfallYES;
1994 amt.fallback=AMGfallNEVER;
1996 for (i = 1; i < lim; i++)
1997 amt.table[i] = NULL;
1998 for (; i < NofAMmeth; i++) {
1999 const char * const cooky = PL_AMG_names[i];
2000 /* Human-readable form, for debugging: */
2001 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2002 const STRLEN l = PL_AMG_namelens[i];
2004 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2005 cp, HvNAME_get(stash)) );
2006 /* don't fill the cache while looking up!
2007 Creation of inheritance stubs in intermediate packages may
2008 conflict with the logic of runtime method substitution.
2009 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2010 then we could have created stubs for "(+0" in A and C too.
2011 But if B overloads "bool", we may want to use it for
2012 numifying instead of C's "+0". */
2013 if (i >= DESTROY_amg)
2014 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
2015 else /* Autoload taken care of below */
2016 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
2018 if (gv && (cv = GvCV(gv))) {
2020 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
2021 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
2022 /* This is a hack to support autoloading..., while
2023 knowing *which* methods were declared as overloaded. */
2024 /* GvSV contains the name of the method. */
2026 SV *gvsv = GvSV(gv);
2028 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2029 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2030 (void*)GvSV(gv), cp, hvname) );
2031 if (!gvsv || !SvPOK(gvsv)
2032 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
2035 /* Can be an import stub (created by "can"). */
2040 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
2041 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2042 "in package \"%.256s\"",
2043 (GvCVGEN(gv) ? "Stub found while resolving"
2048 cv = GvCV(gv = ngv);
2050 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2051 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2052 GvNAME(CvGV(cv))) );
2054 if (i < DESTROY_amg)
2056 } else if (gv) { /* Autoloaded... */
2057 cv = MUTABLE_CV(gv);
2060 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2063 AMT_AMAGIC_on(&amt);
2065 AMT_OVERLOADED_on(&amt);
2066 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2067 (char*)&amt, sizeof(AMT));
2071 /* Here we have no table: */
2073 AMT_AMAGIC_off(&amt);
2074 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2075 (char*)&amt, sizeof(AMTS));
2081 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2087 struct mro_meta* stash_meta;
2089 if (!stash || !HvNAME_get(stash))
2092 stash_meta = HvMROMETA(stash);
2093 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2095 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2098 /* If we're looking up a destructor to invoke, we must avoid
2099 * that Gv_AMupdate croaks, because we might be dying already */
2100 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2101 /* and if it didn't found a destructor, we fall back
2102 * to a simpler method that will only look for the
2103 * destructor instead of the whole magic */
2104 if (id == DESTROY_amg) {
2105 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2111 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2114 amtp = (AMT*)mg->mg_ptr;
2115 if ( amtp->was_ok_am != PL_amagic_generation
2116 || amtp->was_ok_sub != newgen )
2118 if (AMT_AMAGIC(amtp)) {
2119 CV * const ret = amtp->table[id];
2120 if (ret && isGV(ret)) { /* Autoloading stab */
2121 /* Passing it through may have resulted in a warning
2122 "Inherited AUTOLOAD for a non-method deprecated", since
2123 our caller is going through a function call, not a method call.
2124 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2125 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2137 /* Implement tryAMAGICun_MG macro.
2138 Do get magic, then see if the stack arg is overloaded and if so call it.
2140 AMGf_set return the arg using SETs rather than assigning to
2142 AMGf_numeric apply sv_2num to the stack arg.
2146 Perl_try_amagic_un(pTHX_ int method, int flags) {
2150 SV* const arg = TOPs;
2154 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2155 AMGf_noright | AMGf_unary))) {
2156 if (flags & AMGf_set) {
2161 if (SvPADMY(TARG)) {
2162 sv_setsv(TARG, tmpsv);
2172 if ((flags & AMGf_numeric) && SvROK(arg))
2178 /* Implement tryAMAGICbin_MG macro.
2179 Do get magic, then see if the two stack args are overloaded and if so
2182 AMGf_set return the arg using SETs rather than assigning to
2184 AMGf_assign op may be called as mutator (eg +=)
2185 AMGf_numeric apply sv_2num to the stack arg.
2189 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2192 SV* const left = TOPm1s;
2193 SV* const right = TOPs;
2199 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2200 SV * const tmpsv = amagic_call(left, right, method,
2201 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2203 if (flags & AMGf_set) {
2210 if (opASSIGN || SvPADMY(TARG)) {
2211 sv_setsv(TARG, tmpsv);
2221 if(left==right && SvGMAGICAL(left)) {
2222 SV * const left = sv_newmortal();
2224 /* Print the uninitialized warning now, so it includes the vari-
2227 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2228 sv_setsv_flags(left, &PL_sv_no, 0);
2230 else sv_setsv_flags(left, right, 0);
2233 if (flags & AMGf_numeric) {
2235 *(sp-1) = sv_2num(TOPm1s);
2237 *sp = sv_2num(right);
2243 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2246 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2248 while (SvAMAGIC(ref) &&
2249 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2250 AMGf_noright | AMGf_unary))) {
2252 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2253 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2254 /* Bail out if it returns us the same reference. */
2259 return tmpsv ? tmpsv : ref;
2263 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2268 CV **cvp=NULL, **ocvp=NULL;
2269 AMT *amtp=NULL, *oamtp=NULL;
2270 int off = 0, off1, lr = 0, notfound = 0;
2271 int postpr = 0, force_cpy = 0;
2272 int assign = AMGf_assign & flags;
2273 const int assignshift = assign ? 1 : 0;
2274 int use_default_op = 0;
2280 PERL_ARGS_ASSERT_AMAGIC_CALL;
2282 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2283 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2285 if ( !lex_mask || !SvOK(lex_mask) )
2286 /* overloading lexically disabled */
2288 else if ( lex_mask && SvPOK(lex_mask) ) {
2289 /* we have an entry in the hints hash, check if method has been
2290 * masked by overloading.pm */
2292 const int offset = method / 8;
2293 const int bit = method % 8;
2294 char *pv = SvPV(lex_mask, len);
2296 /* Bit set, so this overloading operator is disabled */
2297 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2302 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2303 && (stash = SvSTASH(SvRV(left)))
2304 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2305 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2306 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2308 && ((cv = cvp[off=method+assignshift])
2309 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2315 cv = cvp[off=method])))) {
2316 lr = -1; /* Call method for left argument */
2318 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2321 /* look for substituted methods */
2322 /* In all the covered cases we should be called with assign==0. */
2326 if ((cv = cvp[off=add_ass_amg])
2327 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2328 right = &PL_sv_yes; lr = -1; assign = 1;
2333 if ((cv = cvp[off = subtr_ass_amg])
2334 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2335 right = &PL_sv_yes; lr = -1; assign = 1;
2339 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2342 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2345 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2348 (void)((cv = cvp[off=bool__amg])
2349 || (cv = cvp[off=numer_amg])
2350 || (cv = cvp[off=string_amg]));
2357 * SV* ref causes confusion with the interpreter variable of
2360 SV* const tmpRef=SvRV(left);
2361 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2363 * Just to be extra cautious. Maybe in some
2364 * additional cases sv_setsv is safe, too.
2366 SV* const newref = newSVsv(tmpRef);
2367 SvOBJECT_on(newref);
2368 /* As a bit of a source compatibility hack, SvAMAGIC() and
2369 friends dereference an RV, to behave the same was as when
2370 overloading was stored on the reference, not the referant.
2371 Hence we can't use SvAMAGIC_on()
2373 SvFLAGS(newref) |= SVf_AMAGIC;
2374 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2380 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2381 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2382 SV* const nullsv=sv_2mortal(newSViv(0));
2384 SV* const lessp = amagic_call(left,nullsv,
2385 lt_amg,AMGf_noright);
2386 logic = SvTRUE(lessp);
2388 SV* const lessp = amagic_call(left,nullsv,
2389 ncmp_amg,AMGf_noright);
2390 logic = (SvNV(lessp) < 0);
2393 if (off==subtr_amg) {
2404 if ((cv = cvp[off=subtr_amg])) {
2406 left = sv_2mortal(newSViv(0));
2411 case iter_amg: /* XXXX Eventually should do to_gv. */
2412 case ftest_amg: /* XXXX Eventually should do to_gv. */
2415 return NULL; /* Delegate operation to standard mechanisms. */
2423 return left; /* Delegate operation to standard mechanisms. */
2428 if (!cv) goto not_found;
2429 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2430 && (stash = SvSTASH(SvRV(right)))
2431 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2432 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2433 ? (amtp = (AMT*)mg->mg_ptr)->table
2435 && (cv = cvp[off=method])) { /* Method for right
2438 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2439 || (ocvp && oamtp->fallback > AMGfallNEVER))
2440 && !(flags & AMGf_unary)) {
2441 /* We look for substitution for
2442 * comparison operations and
2444 if (method==concat_amg || method==concat_ass_amg
2445 || method==repeat_amg || method==repeat_ass_amg) {
2446 return NULL; /* Delegate operation to string conversion */
2468 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2472 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2482 not_found: /* No method found, either report or croak */
2490 return left; /* Delegate operation to standard mechanisms. */
2493 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2494 notfound = 1; lr = -1;
2495 } else if (cvp && (cv=cvp[nomethod_amg])) {
2496 notfound = 1; lr = 1;
2497 } else if ((use_default_op =
2498 (!ocvp || oamtp->fallback >= AMGfallYES)
2499 && (!cvp || amtp->fallback >= AMGfallYES))
2501 /* Skip generating the "no method found" message. */
2505 if (off==-1) off=method;
2506 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2507 "Operation \"%s\": no method found,%sargument %s%s%s%s",
2508 AMG_id2name(method + assignshift),
2509 (flags & AMGf_unary ? " " : "\n\tleft "),
2511 "in overloaded package ":
2512 "has no overloaded magic",
2514 HvNAME_get(SvSTASH(SvRV(left))):
2517 ",\n\tright argument in overloaded package ":
2520 : ",\n\tright argument has no overloaded magic"),
2522 HvNAME_get(SvSTASH(SvRV(right))):
2524 if (use_default_op) {
2525 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2527 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2531 force_cpy = force_cpy || assign;
2536 DEBUG_o(Perl_deb(aTHX_
2537 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2539 method+assignshift==off? "" :
2541 method+assignshift==off? "" :
2542 AMG_id2name(method+assignshift),
2543 method+assignshift==off? "" : "\")",
2544 flags & AMGf_unary? "" :
2545 lr==1 ? " for right argument": " for left argument",
2546 flags & AMGf_unary? " for argument" : "",
2547 stash ? HvNAME_get(stash) : "null",
2548 fl? ",\n\tassignment variant used": "") );
2551 /* Since we use shallow copy during assignment, we need
2552 * to dublicate the contents, probably calling user-supplied
2553 * version of copy operator
2555 /* We need to copy in following cases:
2556 * a) Assignment form was called.
2557 * assignshift==1, assign==T, method + 1 == off
2558 * b) Increment or decrement, called directly.
2559 * assignshift==0, assign==0, method + 0 == off
2560 * c) Increment or decrement, translated to assignment add/subtr.
2561 * assignshift==0, assign==T,
2563 * d) Increment or decrement, translated to nomethod.
2564 * assignshift==0, assign==0,
2566 * e) Assignment form translated to nomethod.
2567 * assignshift==1, assign==T, method + 1 != off
2570 /* off is method, method+assignshift, or a result of opcode substitution.
2571 * In the latter case assignshift==0, so only notfound case is important.
2573 if (( (method + assignshift == off)
2574 && (assign || (method == inc_amg) || (method == dec_amg)))
2577 /* newSVsv does not behave as advertised, so we copy missing
2578 * information by hand */
2579 SV *tmpRef = SvRV(left);
2581 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2582 SvRV_set(left, rv_copy);
2584 SvREFCNT_dec(tmpRef);
2592 const bool oldcatch = CATCH_GET;
2595 Zero(&myop, 1, BINOP);
2596 myop.op_last = (OP *) &myop;
2597 myop.op_next = NULL;
2598 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2600 PUSHSTACKi(PERLSI_OVERLOAD);
2603 PL_op = (OP *) &myop;
2604 if (PERLDB_SUB && PL_curstash != PL_debstash)
2605 PL_op->op_private |= OPpENTERSUB_DB;
2607 Perl_pp_pushmark(aTHX);
2609 EXTEND(SP, notfound + 5);
2610 PUSHs(lr>0? right: left);
2611 PUSHs(lr>0? left: right);
2612 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2614 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2615 AMG_id2namelen(method + assignshift), SVs_TEMP));
2617 PUSHs(MUTABLE_SV(cv));
2620 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2628 CATCH_SET(oldcatch);
2635 ans=SvIV(res)<=0; break;
2638 ans=SvIV(res)<0; break;
2641 ans=SvIV(res)>=0; break;
2644 ans=SvIV(res)>0; break;
2647 ans=SvIV(res)==0; break;
2650 ans=SvIV(res)!=0; break;
2653 SvSetSV(left,res); return left;
2655 ans=!SvTRUE(res); break;
2660 } else if (method==copy_amg) {
2662 Perl_croak(aTHX_ "Copy method did not return a reference");
2664 return SvREFCNT_inc(SvRV(res));
2672 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2677 PERL_ARGS_ASSERT_GV_NAME_SET;
2678 PERL_UNUSED_ARG(flags);
2681 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2683 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2684 unshare_hek(GvNAME_HEK(gv));
2687 PERL_HASH(hash, name, len);
2688 GvNAME_HEK(gv) = share_hek(name, len, hash);
2692 =for apidoc gv_try_downgrade
2694 If the typeglob C<gv> can be expressed more succinctly, by having
2695 something other than a real GV in its place in the stash, replace it
2696 with the optimised form. Basic requirements for this are that C<gv>
2697 is a real typeglob, is sufficiently ordinary, and is only referenced
2698 from its package. This function is meant to be used when a GV has been
2699 looked up in part to see what was there, causing upgrading, but based
2700 on what was found it turns out that the real GV isn't required after all.
2702 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2704 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2705 sub, the typeglob is replaced with a scalar-reference placeholder that
2706 more compactly represents the same thing.
2712 Perl_gv_try_downgrade(pTHX_ GV *gv)
2718 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2720 /* XXX Why and where does this leave dangling pointers during global
2722 if (PL_phase == PERL_PHASE_DESTRUCT) return;
2724 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2725 !SvOBJECT(gv) && !SvREADONLY(gv) &&
2726 isGV_with_GP(gv) && GvGP(gv) &&
2727 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2728 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2729 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2731 if (SvMAGICAL(gv)) {
2733 /* only backref magic is allowed */
2734 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2736 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2737 if (mg->mg_type != PERL_MAGIC_backref)
2743 HEK *gvnhek = GvNAME_HEK(gv);
2744 (void)hv_delete(stash, HEK_KEY(gvnhek),
2745 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2746 } else if (GvMULTI(gv) && cv &&
2747 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2748 CvSTASH(cv) == stash && CvGV(cv) == gv &&
2749 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2750 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2751 (namehek = GvNAME_HEK(gv)) &&
2752 (gvp = hv_fetch(stash, HEK_KEY(namehek),
2753 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2755 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2759 SvFLAGS(gv) = SVt_IV|SVf_ROK;
2760 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2761 STRUCT_OFFSET(XPVIV, xiv_iv));
2762 SvRV_set(gv, value);
2769 core_xsub(pTHX_ CV* cv)
2772 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2778 * c-indentation-style: bsd
2780 * indent-tabs-mode: t
2783 * ex: set ts=8 sts=4 sw=4 noet: