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 const char *const name_end = nambeg + full_len;
1054 const char *const name_em1 = name_end - 1;
1057 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1059 if (flags & GV_NOTQUAL) {
1060 /* Caller promised that there is no stash, so we can skip the check. */
1065 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1066 /* accidental stringify on a GV? */
1070 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1071 if (name_cursor < name_em1 &&
1072 ((*name_cursor == ':'
1073 && name_cursor[1] == ':')
1074 || *name_cursor == '\''))
1077 stash = PL_defstash;
1078 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1081 len = name_cursor - name;
1082 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1084 if (*name_cursor == ':') {
1089 Newx(tmpbuf, len+2, char);
1090 Copy(name, tmpbuf, len, char);
1091 tmpbuf[len++] = ':';
1092 tmpbuf[len++] = ':';
1095 gvp = (GV**)hv_fetch(stash, key, len, add);
1096 gv = gvp ? *gvp : NULL;
1097 if (gv && gv != (const GV *)&PL_sv_undef) {
1098 if (SvTYPE(gv) != SVt_PVGV)
1099 gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
1105 if (!gv || gv == (const GV *)&PL_sv_undef)
1108 if (!(stash = GvHV(gv)))
1110 stash = GvHV(gv) = newHV();
1111 if (!HvNAME_get(stash)) {
1112 if (GvSTASH(gv) == PL_defstash && len == 6
1113 && strnEQ(name, "CORE", 4))
1114 hv_name_set(stash, "CORE", 4, 0);
1117 stash, nambeg, name_cursor-nambeg, 0
1119 /* If the containing stash has multiple effective
1120 names, see that this one gets them, too. */
1121 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1122 mro_package_moved(stash, NULL, gv, 1);
1125 else if (!HvNAME_get(stash))
1126 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1129 if (*name_cursor == ':')
1131 name = name_cursor+1;
1132 if (name == name_end)
1134 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1137 len = name_cursor - name;
1139 /* No stash in name, so see how we can default */
1143 if (len && isIDFIRST_lazy(name)) {
1144 bool global = FALSE;
1152 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1153 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1154 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1158 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1163 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1164 && name[3] == 'I' && name[4] == 'N')
1168 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1169 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1170 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1174 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1175 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1182 stash = PL_defstash;
1183 else if (IN_PERL_COMPILETIME) {
1184 stash = PL_curstash;
1185 if (add && (PL_hints & HINT_STRICT_VARS) &&
1186 sv_type != SVt_PVCV &&
1187 sv_type != SVt_PVGV &&
1188 sv_type != SVt_PVFM &&
1189 sv_type != SVt_PVIO &&
1190 !(len == 1 && sv_type == SVt_PV &&
1191 (*name == 'a' || *name == 'b')) )
1193 gvp = (GV**)hv_fetch(stash,name,len,0);
1195 *gvp == (const GV *)&PL_sv_undef ||
1196 SvTYPE(*gvp) != SVt_PVGV)
1200 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1201 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1202 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1204 /* diag_listed_as: Variable "%s" is not imported%s */
1206 aTHX_ packWARN(WARN_MISC),
1207 "Variable \"%c%s\" is not imported",
1208 sv_type == SVt_PVAV ? '@' :
1209 sv_type == SVt_PVHV ? '%' : '$',
1213 aTHX_ packWARN(WARN_MISC),
1214 "\t(Did you mean &%s instead?)\n", name
1221 stash = CopSTASH(PL_curcop);
1224 stash = PL_defstash;
1227 /* By this point we should have a stash and a name */
1231 SV * const err = Perl_mess(aTHX_
1232 "Global symbol \"%s%s\" requires explicit package name",
1233 (sv_type == SVt_PV ? "$"
1234 : sv_type == SVt_PVAV ? "@"
1235 : sv_type == SVt_PVHV ? "%"
1238 if (USE_UTF8_IN_NAMES)
1241 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1243 /* symbol table under destruction */
1252 if (!SvREFCNT(stash)) /* symbol table under destruction */
1255 gvp = (GV**)hv_fetch(stash,name,len,add);
1256 if (!gvp || *gvp == (const GV *)&PL_sv_undef)
1259 if (SvTYPE(gv) == SVt_PVGV) {
1262 gv_init_sv(gv, sv_type);
1263 if (len == 1 && stash == PL_defstash
1264 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1266 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1267 else if (*name == '-' || *name == '+')
1268 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1270 else if (len == 3 && sv_type == SVt_PVAV
1271 && strnEQ(name, "ISA", 3)
1272 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1273 gv_magicalize_isa(gv);
1276 } else if (no_init) {
1278 } else if (no_expand && SvROK(gv)) {
1282 /* Adding a new symbol.
1283 Unless of course there was already something non-GV here, in which case
1284 we want to behave as if there was always a GV here, containing some sort
1286 Otherwise we run the risk of creating things like GvIO, which can cause
1287 subtle bugs. eg the one that tripped up SQL::Translator */
1289 faking_it = SvOK(gv);
1291 if (add & GV_ADDWARN)
1292 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1293 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1294 gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1296 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1297 : (PL_dowarn & G_WARN_ON ) ) )
1300 /* set up magic where warranted */
1301 if (stash != PL_defstash) { /* not the main stash */
1302 /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1303 and VERSION. All the others apply only to the main stash or to
1304 CORE (which is checked right after this). */
1306 const char * const name2 = name + 1;
1309 if (strnEQ(name2, "XPORT", 5))
1313 if (strEQ(name2, "SA"))
1314 gv_magicalize_isa(gv);
1317 if (strEQ(name2, "VERLOAD"))
1318 gv_magicalize_overload(gv);
1321 if (strEQ(name2, "ERSION"))
1330 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1331 /* Avoid null warning: */
1332 const char * const stashname = HvNAME(stash); assert(stashname);
1333 if (strnEQ(stashname, "CORE", 4)) {
1334 const int code = keyword(name, len, 1);
1335 static const char file[] = __FILE__;
1339 bool ampable = FALSE; /* &{}-able */
1342 yy_parser *oldparser;
1343 I32 oldsavestack_ix;
1345 if (code >= 0) return gv; /* not overridable */
1347 /* no support for \&CORE::infix;
1348 no support for funcs that take labels, as their parsing is
1350 case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
1351 case KEY_eq: case KEY_ge:
1352 case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
1353 case KEY_or: case KEY_x: case KEY_xor:
1355 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
1356 case KEY_continue: case KEY_endgrent: case KEY_endhostent:
1357 case KEY_endnetent: case KEY_endprotoent: case KEY_endpwent:
1358 case KEY_endservent: case KEY_getgrent: case KEY_gethostent:
1360 case KEY_getlogin: case KEY_getnetent: case KEY_getppid:
1361 case KEY_getprotoent: case KEY_getservent: case KEY_getpwent:
1363 case KEY_setpwent: case KEY_time: case KEY_times:
1364 case KEY_wait: case KEY_wantarray:
1369 oldcurcop = PL_curcop;
1370 oldparser = PL_parser;
1371 lex_start(NULL, NULL, 0);
1372 oldcompcv = PL_compcv;
1373 PL_compcv = NULL; /* Prevent start_subparse from setting
1375 oldsavestack_ix = start_subparse(FALSE,0);
1379 /* Avoid calling newXS, as it calls us, and things start to
1381 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
1384 mro_method_changed_in(GvSTASH(gv));
1386 CvXSUB(cv) = core_xsub;
1388 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
1390 (void)gv_fetchfile(file);
1391 CvFILE(cv) = (char *)file;
1392 /* XXX This is inefficient, as doing things this order causes
1393 a prototype check in newATTRSUB. But we have to do
1394 it this order as we need an op number before calling
1396 (void)core_prototype((SV *)cv, name, code, &opnum);
1399 newSVOP(OP_COREARGS,0,
1400 opnum ? newSVuv((UV)opnum) : newSVpvn(name,len));
1406 case KEY___FILE__ : index = 1; break;
1407 case KEY___LINE__ : index = 2; break;
1409 o = op_append_elem(OP_LINESEQ,
1412 newSVOP(OP_CONST, 0,
1421 o = op_append_elem(OP_LINESEQ, argop,
1423 opnum == OP_WANTARRAY
1429 newATTRSUB(oldsavestack_ix,
1432 newSVpvn_share(nambeg,full_len,0)
1436 assert(GvCV(gv) == cv);
1438 PL_parser = oldparser;
1439 PL_curcop = oldcurcop;
1440 PL_compcv = oldcompcv;
1442 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
1443 cv_set_call_checker(
1444 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
1446 SvREFCNT_dec(opnumsv);
1454 /* Nothing else to do.
1455 The compiler will probably turn the switch statement into a
1456 branch table. Make sure we avoid even that small overhead for
1457 the common case of lower case variable names. */
1461 const char * const name2 = name + 1;
1464 if (strEQ(name2, "RGV")) {
1465 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1467 else if (strEQ(name2, "RGVOUT")) {
1472 if (strnEQ(name2, "XPORT", 5))
1476 if (strEQ(name2, "SA")) {
1477 gv_magicalize_isa(gv);
1481 if (strEQ(name2, "VERLOAD")) {
1482 gv_magicalize_overload(gv);
1486 if (strEQ(name2, "IG")) {
1489 if (!PL_psig_name) {
1490 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1491 Newxz(PL_psig_pend, SIG_SIZE, int);
1492 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1494 /* I think that the only way to get here is to re-use an
1495 embedded perl interpreter, where the previous
1496 use didn't clean up fully because
1497 PL_perl_destruct_level was 0. I'm not sure that we
1498 "support" that, in that I suspect in that scenario
1499 there are sufficient other garbage values left in the
1500 interpreter structure that something else will crash
1501 before we get here. I suspect that this is one of
1502 those "doctor, it hurts when I do this" bugs. */
1503 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1504 Zero(PL_psig_pend, SIG_SIZE, int);
1508 hv_magic(hv, NULL, PERL_MAGIC_sig);
1509 for (i = 1; i < SIG_SIZE; i++) {
1510 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1512 sv_setsv(*init, &PL_sv_undef);
1517 if (strEQ(name2, "ERSION"))
1520 case '\003': /* $^CHILD_ERROR_NATIVE */
1521 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1524 case '\005': /* $^ENCODING */
1525 if (strEQ(name2, "NCODING"))
1528 case '\007': /* $^GLOBAL_PHASE */
1529 if (strEQ(name2, "LOBAL_PHASE"))
1532 case '\015': /* $^MATCH */
1533 if (strEQ(name2, "ATCH"))
1535 case '\017': /* $^OPEN */
1536 if (strEQ(name2, "PEN"))
1539 case '\020': /* $^PREMATCH $^POSTMATCH */
1540 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1543 case '\024': /* ${^TAINT} */
1544 if (strEQ(name2, "AINT"))
1547 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1548 if (strEQ(name2, "NICODE"))
1550 if (strEQ(name2, "TF8LOCALE"))
1552 if (strEQ(name2, "TF8CACHE"))
1555 case '\027': /* $^WARNING_BITS */
1556 if (strEQ(name2, "ARNING_BITS"))
1569 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1571 /* This snippet is taken from is_gv_magical */
1572 const char *end = name + len;
1573 while (--end > name) {
1574 if (!isDIGIT(*end)) return gv;
1581 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1582 be case '\0' in this switch statement (ie a default case) */
1588 sv_type == SVt_PVAV ||
1589 sv_type == SVt_PVHV ||
1590 sv_type == SVt_PVCV ||
1591 sv_type == SVt_PVFM ||
1594 PL_sawampersand = TRUE;
1598 sv_setpv(GvSVn(gv),PL_chopset);
1602 #ifdef COMPLEX_STATUS
1603 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1609 /* If %! has been used, automatically load Errno.pm. */
1611 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1613 /* magicalization must be done before require_tie_mod is called */
1614 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1615 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1620 GvMULTI_on(gv); /* no used once warnings here */
1622 AV* const av = GvAVn(gv);
1623 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1625 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1626 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1628 SvREADONLY_on(GvSVn(gv));
1631 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1632 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1638 if (sv_type == SVt_PV)
1639 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1640 "$%c is no longer supported", *name);
1643 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1646 case '\010': /* $^H */
1648 HV *const hv = GvHVn(gv);
1649 hv_magic(hv, NULL, PERL_MAGIC_hints);
1652 case '\023': /* $^S */
1654 SvREADONLY_on(GvSVn(gv));
1679 case '\001': /* $^A */
1680 case '\003': /* $^C */
1681 case '\004': /* $^D */
1682 case '\005': /* $^E */
1683 case '\006': /* $^F */
1684 case '\011': /* $^I, NOT \t in EBCDIC */
1685 case '\016': /* $^N */
1686 case '\017': /* $^O */
1687 case '\020': /* $^P */
1688 case '\024': /* $^T */
1689 case '\027': /* $^W */
1691 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1694 case '\014': /* $^L */
1695 sv_setpvs(GvSVn(gv),"\f");
1696 PL_formfeed = GvSVn(gv);
1699 sv_setpvs(GvSVn(gv),"\034");
1703 SV * const sv = GvSVn(gv);
1704 if (!sv_derived_from(PL_patchlevel, "version"))
1705 upg_version(PL_patchlevel, TRUE);
1706 GvSV(gv) = vnumify(PL_patchlevel);
1707 SvREADONLY_on(GvSV(gv));
1711 case '\026': /* $^V */
1713 SV * const sv = GvSVn(gv);
1714 GvSV(gv) = new_version(PL_patchlevel);
1715 SvREADONLY_on(GvSV(gv));
1725 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1729 const HV * const hv = GvSTASH(gv);
1731 PERL_ARGS_ASSERT_GV_FULLNAME4;
1737 sv_setpv(sv, prefix ? prefix : "");
1739 name = HvNAME_get(hv);
1741 namelen = HvNAMELEN_get(hv);
1747 if (keepmain || strNE(name, "main")) {
1748 sv_catpvn(sv,name,namelen);
1751 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1755 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1757 const GV * const egv = GvEGVx(gv);
1759 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1761 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1765 Perl_gv_check(pTHX_ const HV *stash)
1770 PERL_ARGS_ASSERT_GV_CHECK;
1772 if (!HvARRAY(stash))
1774 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1776 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1779 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1780 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1782 if (hv != PL_defstash && hv != stash)
1783 gv_check(hv); /* nested package */
1785 else if (isALPHA(*HeKEY(entry))) {
1787 gv = MUTABLE_GV(HeVAL(entry));
1788 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1791 CopLINE_set(PL_curcop, GvLINE(gv));
1793 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1795 CopFILEGV(PL_curcop)
1796 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1798 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1799 "Name \"%s::%s\" used only once: possible typo",
1800 HvNAME_get(stash), GvNAME(gv));
1807 Perl_newGVgen(pTHX_ const char *pack)
1811 PERL_ARGS_ASSERT_NEWGVGEN;
1813 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1817 /* hopefully this is only called on local symbol table entries */
1820 Perl_gp_ref(pTHX_ GP *gp)
1828 /* If the GP they asked for a reference to contains
1829 a method cache entry, clear it first, so that we
1830 don't infect them with our cached entry */
1831 SvREFCNT_dec(gp->gp_cv);
1840 Perl_gp_free(pTHX_ GV *gv)
1846 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1848 if (gp->gp_refcnt == 0) {
1849 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1850 "Attempt to free unreferenced glob pointers"
1851 pTHX__FORMAT pTHX__VALUE);
1854 if (--gp->gp_refcnt > 0) {
1855 if (gp->gp_egv == gv)
1862 /* Copy and null out all the glob slots, so destructors do not see
1864 HEK * const file_hek = gp->gp_file_hek;
1865 SV * const sv = gp->gp_sv;
1866 AV * const av = gp->gp_av;
1867 HV * const hv = gp->gp_hv;
1868 IO * const io = gp->gp_io;
1869 CV * const cv = gp->gp_cv;
1870 CV * const form = gp->gp_form;
1872 gp->gp_file_hek = NULL;
1881 unshare_hek(file_hek);
1885 /* FIXME - another reference loop GV -> symtab -> GV ?
1886 Somehow gp->gp_hv can end up pointing at freed garbage. */
1887 if (hv && SvTYPE(hv) == SVt_PVHV) {
1888 const char *hvname = HvNAME_get(hv);
1889 if (PL_stashcache && hvname)
1890 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
1898 if (!gp->gp_file_hek
1904 && !gp->gp_form) break;
1906 if (--attempts == 0) {
1908 "panic: gp_free failed to free glob pointer - "
1909 "something is repeatedly re-creating entries"
1919 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1921 AMT * const amtp = (AMT*)mg->mg_ptr;
1922 PERL_UNUSED_ARG(sv);
1924 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1926 if (amtp && AMT_AMAGIC(amtp)) {
1928 for (i = 1; i < NofAMmeth; i++) {
1929 CV * const cv = amtp->table[i];
1931 SvREFCNT_dec(MUTABLE_SV(cv));
1932 amtp->table[i] = NULL;
1939 /* Updates and caches the CV's */
1941 * 1 on success and there is some overload
1942 * 0 if there is no overload
1943 * -1 if some error occurred and it couldn't croak
1947 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1950 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1952 const struct mro_meta* stash_meta = HvMROMETA(stash);
1955 PERL_ARGS_ASSERT_GV_AMUPDATE;
1957 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1959 const AMT * const amtp = (AMT*)mg->mg_ptr;
1960 if (amtp->was_ok_am == PL_amagic_generation
1961 && amtp->was_ok_sub == newgen) {
1962 return AMT_OVERLOADED(amtp) ? 1 : 0;
1964 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1967 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1970 amt.was_ok_am = PL_amagic_generation;
1971 amt.was_ok_sub = newgen;
1972 amt.fallback = AMGfallNO;
1976 int filled = 0, have_ovl = 0;
1979 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1981 /* Try to find via inheritance. */
1982 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1983 SV * const sv = gv ? GvSV(gv) : NULL;
1987 lim = DESTROY_amg; /* Skip overloading entries. */
1988 #ifdef PERL_DONT_CREATE_GVSV
1990 NOOP; /* Equivalent to !SvTRUE and !SvOK */
1993 else if (SvTRUE(sv))
1994 amt.fallback=AMGfallYES;
1996 amt.fallback=AMGfallNEVER;
1998 for (i = 1; i < lim; i++)
1999 amt.table[i] = NULL;
2000 for (; i < NofAMmeth; i++) {
2001 const char * const cooky = PL_AMG_names[i];
2002 /* Human-readable form, for debugging: */
2003 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2004 const STRLEN l = PL_AMG_namelens[i];
2006 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2007 cp, HvNAME_get(stash)) );
2008 /* don't fill the cache while looking up!
2009 Creation of inheritance stubs in intermediate packages may
2010 conflict with the logic of runtime method substitution.
2011 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2012 then we could have created stubs for "(+0" in A and C too.
2013 But if B overloads "bool", we may want to use it for
2014 numifying instead of C's "+0". */
2015 if (i >= DESTROY_amg)
2016 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
2017 else /* Autoload taken care of below */
2018 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
2020 if (gv && (cv = GvCV(gv))) {
2022 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
2023 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
2024 /* This is a hack to support autoloading..., while
2025 knowing *which* methods were declared as overloaded. */
2026 /* GvSV contains the name of the method. */
2028 SV *gvsv = GvSV(gv);
2030 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2031 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2032 (void*)GvSV(gv), cp, hvname) );
2033 if (!gvsv || !SvPOK(gvsv)
2034 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
2037 /* Can be an import stub (created by "can"). */
2042 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
2043 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2044 "in package \"%.256s\"",
2045 (GvCVGEN(gv) ? "Stub found while resolving"
2050 cv = GvCV(gv = ngv);
2052 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2053 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2054 GvNAME(CvGV(cv))) );
2056 if (i < DESTROY_amg)
2058 } else if (gv) { /* Autoloaded... */
2059 cv = MUTABLE_CV(gv);
2062 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2065 AMT_AMAGIC_on(&amt);
2067 AMT_OVERLOADED_on(&amt);
2068 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2069 (char*)&amt, sizeof(AMT));
2073 /* Here we have no table: */
2075 AMT_AMAGIC_off(&amt);
2076 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2077 (char*)&amt, sizeof(AMTS));
2083 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2089 struct mro_meta* stash_meta;
2091 if (!stash || !HvNAME_get(stash))
2094 stash_meta = HvMROMETA(stash);
2095 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2097 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2100 /* If we're looking up a destructor to invoke, we must avoid
2101 * that Gv_AMupdate croaks, because we might be dying already */
2102 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2103 /* and if it didn't found a destructor, we fall back
2104 * to a simpler method that will only look for the
2105 * destructor instead of the whole magic */
2106 if (id == DESTROY_amg) {
2107 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2113 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2116 amtp = (AMT*)mg->mg_ptr;
2117 if ( amtp->was_ok_am != PL_amagic_generation
2118 || amtp->was_ok_sub != newgen )
2120 if (AMT_AMAGIC(amtp)) {
2121 CV * const ret = amtp->table[id];
2122 if (ret && isGV(ret)) { /* Autoloading stab */
2123 /* Passing it through may have resulted in a warning
2124 "Inherited AUTOLOAD for a non-method deprecated", since
2125 our caller is going through a function call, not a method call.
2126 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2127 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2139 /* Implement tryAMAGICun_MG macro.
2140 Do get magic, then see if the stack arg is overloaded and if so call it.
2142 AMGf_set return the arg using SETs rather than assigning to
2144 AMGf_numeric apply sv_2num to the stack arg.
2148 Perl_try_amagic_un(pTHX_ int method, int flags) {
2152 SV* const arg = TOPs;
2156 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2157 AMGf_noright | AMGf_unary))) {
2158 if (flags & AMGf_set) {
2163 if (SvPADMY(TARG)) {
2164 sv_setsv(TARG, tmpsv);
2174 if ((flags & AMGf_numeric) && SvROK(arg))
2180 /* Implement tryAMAGICbin_MG macro.
2181 Do get magic, then see if the two stack args are overloaded and if so
2184 AMGf_set return the arg using SETs rather than assigning to
2186 AMGf_assign op may be called as mutator (eg +=)
2187 AMGf_numeric apply sv_2num to the stack arg.
2191 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2194 SV* const left = TOPm1s;
2195 SV* const right = TOPs;
2201 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2202 SV * const tmpsv = amagic_call(left, right, method,
2203 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2205 if (flags & AMGf_set) {
2212 if (opASSIGN || SvPADMY(TARG)) {
2213 sv_setsv(TARG, tmpsv);
2223 if(left==right && SvGMAGICAL(left)) {
2224 SV * const left = sv_newmortal();
2226 /* Print the uninitialized warning now, so it includes the vari-
2229 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2230 sv_setsv_flags(left, &PL_sv_no, 0);
2232 else sv_setsv_flags(left, right, 0);
2235 if (flags & AMGf_numeric) {
2237 *(sp-1) = sv_2num(TOPm1s);
2239 *sp = sv_2num(right);
2245 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2248 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2250 while (SvAMAGIC(ref) &&
2251 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2252 AMGf_noright | AMGf_unary))) {
2254 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2255 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2256 /* Bail out if it returns us the same reference. */
2261 return tmpsv ? tmpsv : ref;
2265 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2270 CV **cvp=NULL, **ocvp=NULL;
2271 AMT *amtp=NULL, *oamtp=NULL;
2272 int off = 0, off1, lr = 0, notfound = 0;
2273 int postpr = 0, force_cpy = 0;
2274 int assign = AMGf_assign & flags;
2275 const int assignshift = assign ? 1 : 0;
2276 int use_default_op = 0;
2282 PERL_ARGS_ASSERT_AMAGIC_CALL;
2284 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2285 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2287 if ( !lex_mask || !SvOK(lex_mask) )
2288 /* overloading lexically disabled */
2290 else if ( lex_mask && SvPOK(lex_mask) ) {
2291 /* we have an entry in the hints hash, check if method has been
2292 * masked by overloading.pm */
2294 const int offset = method / 8;
2295 const int bit = method % 8;
2296 char *pv = SvPV(lex_mask, len);
2298 /* Bit set, so this overloading operator is disabled */
2299 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2304 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2305 && (stash = SvSTASH(SvRV(left)))
2306 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2307 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2308 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2310 && ((cv = cvp[off=method+assignshift])
2311 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2317 cv = cvp[off=method])))) {
2318 lr = -1; /* Call method for left argument */
2320 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2323 /* look for substituted methods */
2324 /* In all the covered cases we should be called with assign==0. */
2328 if ((cv = cvp[off=add_ass_amg])
2329 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2330 right = &PL_sv_yes; lr = -1; assign = 1;
2335 if ((cv = cvp[off = subtr_ass_amg])
2336 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2337 right = &PL_sv_yes; lr = -1; assign = 1;
2341 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2344 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2347 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2350 (void)((cv = cvp[off=bool__amg])
2351 || (cv = cvp[off=numer_amg])
2352 || (cv = cvp[off=string_amg]));
2359 * SV* ref causes confusion with the interpreter variable of
2362 SV* const tmpRef=SvRV(left);
2363 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2365 * Just to be extra cautious. Maybe in some
2366 * additional cases sv_setsv is safe, too.
2368 SV* const newref = newSVsv(tmpRef);
2369 SvOBJECT_on(newref);
2370 /* As a bit of a source compatibility hack, SvAMAGIC() and
2371 friends dereference an RV, to behave the same was as when
2372 overloading was stored on the reference, not the referant.
2373 Hence we can't use SvAMAGIC_on()
2375 SvFLAGS(newref) |= SVf_AMAGIC;
2376 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2382 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2383 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2384 SV* const nullsv=sv_2mortal(newSViv(0));
2386 SV* const lessp = amagic_call(left,nullsv,
2387 lt_amg,AMGf_noright);
2388 logic = SvTRUE(lessp);
2390 SV* const lessp = amagic_call(left,nullsv,
2391 ncmp_amg,AMGf_noright);
2392 logic = (SvNV(lessp) < 0);
2395 if (off==subtr_amg) {
2406 if ((cv = cvp[off=subtr_amg])) {
2408 left = sv_2mortal(newSViv(0));
2413 case iter_amg: /* XXXX Eventually should do to_gv. */
2414 case ftest_amg: /* XXXX Eventually should do to_gv. */
2417 return NULL; /* Delegate operation to standard mechanisms. */
2425 return left; /* Delegate operation to standard mechanisms. */
2430 if (!cv) goto not_found;
2431 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2432 && (stash = SvSTASH(SvRV(right)))
2433 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2434 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2435 ? (amtp = (AMT*)mg->mg_ptr)->table
2437 && (cv = cvp[off=method])) { /* Method for right
2440 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2441 || (ocvp && oamtp->fallback > AMGfallNEVER))
2442 && !(flags & AMGf_unary)) {
2443 /* We look for substitution for
2444 * comparison operations and
2446 if (method==concat_amg || method==concat_ass_amg
2447 || method==repeat_amg || method==repeat_ass_amg) {
2448 return NULL; /* Delegate operation to string conversion */
2470 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2474 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2484 not_found: /* No method found, either report or croak */
2492 return left; /* Delegate operation to standard mechanisms. */
2495 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2496 notfound = 1; lr = -1;
2497 } else if (cvp && (cv=cvp[nomethod_amg])) {
2498 notfound = 1; lr = 1;
2499 } else if ((use_default_op =
2500 (!ocvp || oamtp->fallback >= AMGfallYES)
2501 && (!cvp || amtp->fallback >= AMGfallYES))
2503 /* Skip generating the "no method found" message. */
2507 if (off==-1) off=method;
2508 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2509 "Operation \"%s\": no method found,%sargument %s%s%s%s",
2510 AMG_id2name(method + assignshift),
2511 (flags & AMGf_unary ? " " : "\n\tleft "),
2513 "in overloaded package ":
2514 "has no overloaded magic",
2516 HvNAME_get(SvSTASH(SvRV(left))):
2519 ",\n\tright argument in overloaded package ":
2522 : ",\n\tright argument has no overloaded magic"),
2524 HvNAME_get(SvSTASH(SvRV(right))):
2526 if (use_default_op) {
2527 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2529 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2533 force_cpy = force_cpy || assign;
2538 DEBUG_o(Perl_deb(aTHX_
2539 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2541 method+assignshift==off? "" :
2543 method+assignshift==off? "" :
2544 AMG_id2name(method+assignshift),
2545 method+assignshift==off? "" : "\")",
2546 flags & AMGf_unary? "" :
2547 lr==1 ? " for right argument": " for left argument",
2548 flags & AMGf_unary? " for argument" : "",
2549 stash ? HvNAME_get(stash) : "null",
2550 fl? ",\n\tassignment variant used": "") );
2553 /* Since we use shallow copy during assignment, we need
2554 * to dublicate the contents, probably calling user-supplied
2555 * version of copy operator
2557 /* We need to copy in following cases:
2558 * a) Assignment form was called.
2559 * assignshift==1, assign==T, method + 1 == off
2560 * b) Increment or decrement, called directly.
2561 * assignshift==0, assign==0, method + 0 == off
2562 * c) Increment or decrement, translated to assignment add/subtr.
2563 * assignshift==0, assign==T,
2565 * d) Increment or decrement, translated to nomethod.
2566 * assignshift==0, assign==0,
2568 * e) Assignment form translated to nomethod.
2569 * assignshift==1, assign==T, method + 1 != off
2572 /* off is method, method+assignshift, or a result of opcode substitution.
2573 * In the latter case assignshift==0, so only notfound case is important.
2575 if (( (method + assignshift == off)
2576 && (assign || (method == inc_amg) || (method == dec_amg)))
2579 /* newSVsv does not behave as advertised, so we copy missing
2580 * information by hand */
2581 SV *tmpRef = SvRV(left);
2583 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2584 SvRV_set(left, rv_copy);
2586 SvREFCNT_dec(tmpRef);
2594 const bool oldcatch = CATCH_GET;
2597 Zero(&myop, 1, BINOP);
2598 myop.op_last = (OP *) &myop;
2599 myop.op_next = NULL;
2600 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2602 PUSHSTACKi(PERLSI_OVERLOAD);
2605 PL_op = (OP *) &myop;
2606 if (PERLDB_SUB && PL_curstash != PL_debstash)
2607 PL_op->op_private |= OPpENTERSUB_DB;
2609 Perl_pp_pushmark(aTHX);
2611 EXTEND(SP, notfound + 5);
2612 PUSHs(lr>0? right: left);
2613 PUSHs(lr>0? left: right);
2614 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2616 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2617 AMG_id2namelen(method + assignshift), SVs_TEMP));
2619 PUSHs(MUTABLE_SV(cv));
2622 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2630 CATCH_SET(oldcatch);
2637 ans=SvIV(res)<=0; break;
2640 ans=SvIV(res)<0; break;
2643 ans=SvIV(res)>=0; break;
2646 ans=SvIV(res)>0; break;
2649 ans=SvIV(res)==0; break;
2652 ans=SvIV(res)!=0; break;
2655 SvSetSV(left,res); return left;
2657 ans=!SvTRUE(res); break;
2662 } else if (method==copy_amg) {
2664 Perl_croak(aTHX_ "Copy method did not return a reference");
2666 return SvREFCNT_inc(SvRV(res));
2674 =for apidoc is_gv_magical_sv
2676 Returns C<TRUE> if given the name of a magical GV.
2678 Currently only useful internally when determining if a GV should be
2679 created even in rvalue contexts.
2681 C<flags> is not used at present but available for future extension to
2682 allow selecting particular classes of magical variable.
2688 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2691 const char *const name = SvPV_const(name_sv, len);
2693 PERL_UNUSED_ARG(flags);
2694 PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2697 const char * const name1 = name + 1;
2700 if (len == 3 && name[1] == 'S' && name[2] == 'A')
2704 if (len == 8 && strEQ(name1, "VERLOAD"))
2708 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2711 /* Using ${^...} variables is likely to be sufficiently rare that
2712 it seems sensible to avoid the space hit of also checking the
2714 case '\017': /* ${^OPEN} */
2715 if (strEQ(name1, "PEN"))
2718 case '\024': /* ${^TAINT} */
2719 if (strEQ(name1, "AINT"))
2722 case '\025': /* ${^UNICODE} */
2723 if (strEQ(name1, "NICODE"))
2725 if (strEQ(name1, "TF8LOCALE"))
2728 case '\027': /* ${^WARNING_BITS} */
2729 if (strEQ(name1, "ARNING_BITS"))
2742 const char *end = name + len;
2743 while (--end > name) {
2751 /* Because we're already assuming that name is NUL terminated
2752 below, we can treat an empty name as "\0" */
2779 case '\001': /* $^A */
2780 case '\003': /* $^C */
2781 case '\004': /* $^D */
2782 case '\005': /* $^E */
2783 case '\006': /* $^F */
2784 case '\010': /* $^H */
2785 case '\011': /* $^I, NOT \t in EBCDIC */
2786 case '\014': /* $^L */
2787 case '\016': /* $^N */
2788 case '\017': /* $^O */
2789 case '\020': /* $^P */
2790 case '\023': /* $^S */
2791 case '\024': /* $^T */
2792 case '\026': /* $^V */
2793 case '\027': /* $^W */
2813 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2818 PERL_ARGS_ASSERT_GV_NAME_SET;
2819 PERL_UNUSED_ARG(flags);
2822 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2824 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2825 unshare_hek(GvNAME_HEK(gv));
2828 PERL_HASH(hash, name, len);
2829 GvNAME_HEK(gv) = share_hek(name, len, hash);
2833 =for apidoc gv_try_downgrade
2835 If the typeglob C<gv> can be expressed more succinctly, by having
2836 something other than a real GV in its place in the stash, replace it
2837 with the optimised form. Basic requirements for this are that C<gv>
2838 is a real typeglob, is sufficiently ordinary, and is only referenced
2839 from its package. This function is meant to be used when a GV has been
2840 looked up in part to see what was there, causing upgrading, but based
2841 on what was found it turns out that the real GV isn't required after all.
2843 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2845 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2846 sub, the typeglob is replaced with a scalar-reference placeholder that
2847 more compactly represents the same thing.
2853 Perl_gv_try_downgrade(pTHX_ GV *gv)
2859 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2861 /* XXX Why and where does this leave dangling pointers during global
2863 if (PL_phase == PERL_PHASE_DESTRUCT) return;
2865 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2866 !SvOBJECT(gv) && !SvREADONLY(gv) &&
2867 isGV_with_GP(gv) && GvGP(gv) &&
2868 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2869 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2870 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2872 if (SvMAGICAL(gv)) {
2874 /* only backref magic is allowed */
2875 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2877 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2878 if (mg->mg_type != PERL_MAGIC_backref)
2884 HEK *gvnhek = GvNAME_HEK(gv);
2885 (void)hv_delete(stash, HEK_KEY(gvnhek),
2886 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2887 } else if (GvMULTI(gv) && cv &&
2888 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2889 CvSTASH(cv) == stash && CvGV(cv) == gv &&
2890 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2891 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2892 (namehek = GvNAME_HEK(gv)) &&
2893 (gvp = hv_fetch(stash, HEK_KEY(namehek),
2894 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2896 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2900 SvFLAGS(gv) = SVt_IV|SVf_ROK;
2901 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2902 STRUCT_OFFSET(XPVIV, xiv_iv));
2903 SvRV_set(gv, value);
2910 core_xsub(pTHX_ CV* cv)
2913 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2919 * c-indentation-style: bsd
2921 * indent-tabs-mode: t
2924 * ex: set ts=8 sts=4 sw=4 noet: