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"]
24 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
25 It is a structure that holds a pointer to a scalar, an array, a hash etc,
26 corresponding to $foo, @foo, %foo.
28 GVs are usually found as values in stashes (symbol table hashes) where
29 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 = OP_IS_DIRHOP(PL_op->op_type) ?
63 "dirhandle" : "filehandle";
64 } else if (type == SVt_PVHV) {
67 what = type == SVt_PVAV ? "array" : "scalar";
69 /* diag_listed_as: Bad symbol for filehandle */
70 Perl_croak(aTHX_ "Bad symbol for %s", what);
73 if (type == SVt_PVHV) {
74 where = (SV **)&GvHV(gv);
75 } else if (type == SVt_PVAV) {
76 where = (SV **)&GvAV(gv);
77 } else if (type == SVt_PVIO) {
78 where = (SV **)&GvIOp(gv);
85 *where = newSV_type(type);
86 if (type == SVt_PVAV && GvNAMELEN(gv) == 3
87 && strnEQ(GvNAME(gv), "ISA", 3))
88 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
94 Perl_gv_fetchfile(pTHX_ const char *name)
96 PERL_ARGS_ASSERT_GV_FETCHFILE;
97 return gv_fetchfile_flags(name, strlen(name), 0);
101 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), GvAVn(gv), 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;
156 if (SvTYPE(gv) == SVt_PVGV)
157 return cv_const_sv(GvCVu(gv));
158 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
162 Perl_newGP(pTHX_ GV *const gv)
173 PERL_ARGS_ASSERT_NEWGP;
175 gp->gp_egv = gv; /* allow compiler to reuse gv after this */
176 #ifndef PERL_DONT_CREATE_GVSV
177 gp->gp_sv = newSV(0);
180 /* PL_curcop may be null here. E.g.,
181 INIT { bless {} and exit }
182 frees INIT before looking up DESTROY (and creating *DESTROY)
185 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
187 if (CopFILE(PL_curcop)) {
188 file = CopFILE(PL_curcop);
192 filegv = CopFILEGV(PL_curcop);
194 file = GvNAME(filegv)+2;
195 len = GvNAMELEN(filegv)-2;
206 PERL_HASH(hash, file, len);
207 gp->gp_file_hek = share_hek(file, len, hash);
213 /* Assign CvGV(cv) = gv, handling weak references.
214 * See also S_anonymise_cv_maybe */
217 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
219 GV * const oldgv = CvGV(cv);
221 PERL_ARGS_ASSERT_CVGV_SET;
228 SvREFCNT_dec_NN(oldgv);
232 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
235 else if ((hek = CvNAME_HEK(cv))) {
240 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
241 assert(!CvCVGV_RC(cv));
246 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
247 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
250 SvREFCNT_inc_simple_void_NN(gv);
254 /* Assign CvSTASH(cv) = st, handling weak references. */
257 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
259 HV *oldst = CvSTASH(cv);
260 PERL_ARGS_ASSERT_CVSTASH_SET;
264 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
265 SvANY(cv)->xcv_stash = st;
267 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
271 =for apidoc gv_init_pvn
273 Converts a scalar into a typeglob. This is an incoercible typeglob;
274 assigning a reference to it will assign to one of its slots, instead of
275 overwriting it as happens with typeglobs created by SvSetSV. Converting
276 any scalar that is SvOK() may produce unpredictable results and is reserved
277 for perl's internal use.
279 C<gv> is the scalar to be converted.
281 C<stash> is the parent stash/package, if any.
283 C<name> and C<len> give the name. The name must be unqualified;
284 that is, it must not include the package name. If C<gv> is a
285 stash element, it is the caller's responsibility to ensure that the name
286 passed to this function matches the name of the element. If it does not
287 match, perl's internal bookkeeping will get out of sync.
289 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
290 the return value of SvUTF8(sv). It can also take the
291 GV_ADDMULTI flag, which means to pretend that the GV has been
292 seen before (i.e., suppress "Used once" warnings).
296 The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
297 has no flags parameter. If the C<multi> parameter is set, the
298 GV_ADDMULTI flag will be passed to gv_init_pvn().
300 =for apidoc gv_init_pv
302 Same as gv_init_pvn(), but takes a nul-terminated string for the name
303 instead of separate char * and length parameters.
305 =for apidoc gv_init_sv
307 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
308 char * and length parameters. C<flags> is currently unused.
314 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
318 PERL_ARGS_ASSERT_GV_INIT_SV;
319 namepv = SvPV(namesv, namelen);
322 gv_init_pvn(gv, stash, namepv, namelen, flags);
326 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
328 PERL_ARGS_ASSERT_GV_INIT_PV;
329 gv_init_pvn(gv, stash, name, strlen(name), flags);
333 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
335 const U32 old_type = SvTYPE(gv);
336 const bool doproto = old_type > SVt_NULL;
337 char * const proto = (doproto && SvPOK(gv))
338 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
340 const STRLEN protolen = proto ? SvCUR(gv) : 0;
341 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
342 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
343 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
345 PERL_ARGS_ASSERT_GV_INIT_PVN;
346 assert (!(proto && has_constant));
349 /* The constant has to be a simple scalar type. */
350 switch (SvTYPE(has_constant)) {
355 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
356 sv_reftype(has_constant, 0));
365 if (old_type < SVt_PVGV) {
366 if (old_type >= SVt_PV)
368 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
376 Safefree(SvPVX_mutable(gv));
381 GvGP_set(gv, Perl_newGP(aTHX_ gv));
384 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
385 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
386 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
387 GvMULTI_on(gv); /* _was_ mentioned */
391 /* newCONSTSUB takes ownership of the reference from us. */
392 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
393 /* In case op.c:S_process_special_blocks stole it: */
395 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
396 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
397 /* If this reference was a copy of another, then the subroutine
398 must have been "imported", by a Perl space assignment to a GV
399 from a reference to CV. */
400 if (exported_constant)
401 GvIMPORTED_CV_on(gv);
402 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
407 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
408 SV_HAS_TRAILING_NUL);
409 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
415 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
417 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
429 #ifdef PERL_DONT_CREATE_GVSV
437 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
438 If we just cast GvSVn(gv) to void, it ignores evaluating it for
445 static void core_xsub(pTHX_ CV* cv);
448 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
449 const char * const name, const STRLEN len)
451 const int code = keyword(name, len, 1);
452 static const char file[] = __FILE__;
453 CV *cv, *oldcompcv = NULL;
455 bool ampable = TRUE; /* &{}-able */
456 COP *oldcurcop = NULL;
457 yy_parser *oldparser = NULL;
458 I32 oldsavestack_ix = 0;
463 if (!code) return NULL; /* Not a keyword */
464 switch (code < 0 ? -code : code) {
465 /* no support for \&CORE::infix;
466 no support for funcs that do not parse like funcs */
467 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
468 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
469 case KEY_default : case KEY_DESTROY:
470 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
471 case KEY_END : case KEY_eq : case KEY_eval :
472 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
473 case KEY_given : case KEY_goto : case KEY_grep :
474 case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
475 case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
476 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
477 case KEY_package: case KEY_print: case KEY_printf:
478 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
479 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
480 case KEY_s : case KEY_say : case KEY_sort :
481 case KEY_state: case KEY_sub :
482 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
483 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
484 case KEY_x : case KEY_xor : case KEY_y :
487 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
488 case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
494 case KEY_splice: case KEY_split:
497 case KEY_truncate: case KEY_unlink:
504 gv_init(gv, stash, name, len, TRUE);
509 oldcurcop = PL_curcop;
510 oldparser = PL_parser;
511 lex_start(NULL, NULL, 0);
512 oldcompcv = PL_compcv;
513 PL_compcv = NULL; /* Prevent start_subparse from setting
515 oldsavestack_ix = start_subparse(FALSE,0);
519 /* Avoid calling newXS, as it calls us, and things start to
521 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
525 CvXSUB(cv) = core_xsub;
527 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
529 (void)gv_fetchfile(file);
530 CvFILE(cv) = (char *)file;
531 /* XXX This is inefficient, as doing things this order causes
532 a prototype check in newATTRSUB. But we have to do
533 it this order as we need an op number before calling
535 (void)core_prototype((SV *)cv, name, code, &opnum);
537 (void)hv_store(stash,name,len,(SV *)gv,0);
543 /* newATTRSUB will free the CV and return NULL if we're still
544 compiling after a syntax error */
545 if ((cv = newATTRSUB_x(
546 oldsavestack_ix, (OP *)gv,
551 : newSVpvn(name,len),
556 assert(GvCV(gv) == orig_cv);
557 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
558 && opnum != OP_UNDEF)
559 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
562 PL_parser = oldparser;
563 PL_curcop = oldcurcop;
564 PL_compcv = oldcompcv;
567 SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
569 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
571 SvREFCNT_dec(opnumsv);
578 =for apidoc gv_fetchmeth
580 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
582 =for apidoc gv_fetchmeth_sv
584 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
585 of an SV instead of a string/length pair.
591 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
595 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
596 namepv = SvPV(namesv, namelen);
599 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
603 =for apidoc gv_fetchmeth_pv
605 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
606 instead of a string/length pair.
612 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
614 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
615 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
619 =for apidoc gv_fetchmeth_pvn
621 Returns the glob with the given C<name> and a defined subroutine or
622 C<NULL>. The glob lives in the given C<stash>, or in the stashes
623 accessible via @ISA and UNIVERSAL::.
625 The argument C<level> should be either 0 or -1. If C<level==0>, as a
626 side-effect creates a glob with the given C<name> in the given C<stash>
627 which in the case of success contains an alias for the subroutine, and sets
628 up caching info for this glob.
630 The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
632 GV_SUPER indicates that we want to look up the method in the superclasses
636 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
637 visible to Perl code. So when calling C<call_sv>, you should not use
638 the GV directly; instead, you should use the method's CV, which can be
639 obtained from the GV with the C<GvCV> macro.
644 /* NOTE: No support for tied ISA */
647 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
653 HV* cstash, *cachestash;
654 GV* candidate = NULL;
658 I32 create = (level >= 0) ? 1 : 0;
661 U32 is_utf8 = flags & SVf_UTF8;
663 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
665 /* UNIVERSAL methods should be callable without a stash */
667 create = 0; /* probably appropriate */
668 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
674 hvname = HvNAME_get(stash);
676 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
681 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
682 flags & GV_SUPER ? "SUPER " : "",name,hvname) );
684 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
686 if (flags & GV_SUPER) {
687 if (!HvAUX(stash)->xhv_mro_meta->super)
688 HvAUX(stash)->xhv_mro_meta->super = newHV();
689 cachestash = HvAUX(stash)->xhv_mro_meta->super;
691 else cachestash = stash;
693 /* check locally for a real method or a cache entry */
694 gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
700 if (SvTYPE(topgv) != SVt_PVGV)
701 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
702 if ((cand_cv = GvCV(topgv))) {
703 /* If genuine method or valid cache entry, use it */
704 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
708 /* stale cache entry, junk it and move on */
709 SvREFCNT_dec_NN(cand_cv);
710 GvCV_set(topgv, NULL);
715 else if (GvCVGEN(topgv) == topgen_cmp) {
716 /* cache indicates no such method definitively */
719 else if (stash == cachestash
720 && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
721 && strnEQ(hvname, "CORE", 4)
722 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
726 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
727 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
728 items = AvFILLp(linear_av); /* no +1, to skip over self */
730 linear_sv = *linear_svp++;
732 cstash = gv_stashsv(linear_sv, 0);
735 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
736 "Can't locate package %"SVf" for @%"HEKf"::ISA",
738 HEKfARG(HvNAME_HEK(stash)));
744 gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
746 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
747 const char *hvname = HvNAME(cstash); assert(hvname);
748 if (strnEQ(hvname, "CORE", 4)
750 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
756 else candidate = *gvp;
759 if (SvTYPE(candidate) != SVt_PVGV)
760 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
761 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
763 * Found real method, cache method in topgv if:
764 * 1. topgv has no synonyms (else inheritance crosses wires)
765 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
767 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
768 CV *old_cv = GvCV(topgv);
769 SvREFCNT_dec(old_cv);
770 SvREFCNT_inc_simple_void_NN(cand_cv);
771 GvCV_set(topgv, cand_cv);
772 GvCVGEN(topgv) = topgen_cmp;
778 /* Check UNIVERSAL without caching */
779 if(level == 0 || level == -1) {
780 candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
782 cand_cv = GvCV(candidate);
783 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
784 CV *old_cv = GvCV(topgv);
785 SvREFCNT_dec(old_cv);
786 SvREFCNT_inc_simple_void_NN(cand_cv);
787 GvCV_set(topgv, cand_cv);
788 GvCVGEN(topgv) = topgen_cmp;
794 if (topgv && GvREFCNT(topgv) == 1) {
795 /* cache the fact that the method is not defined */
796 GvCVGEN(topgv) = topgen_cmp;
803 =for apidoc gv_fetchmeth_autoload
805 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
808 =for apidoc gv_fetchmeth_sv_autoload
810 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
811 of an SV instead of a string/length pair.
817 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
821 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
822 namepv = SvPV(namesv, namelen);
825 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
829 =for apidoc gv_fetchmeth_pv_autoload
831 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
832 instead of a string/length pair.
838 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
840 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
841 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
845 =for apidoc gv_fetchmeth_pvn_autoload
847 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
848 Returns a glob for the subroutine.
850 For an autoloaded subroutine without a GV, will create a GV even
851 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
852 of the result may be zero.
854 Currently, the only significant value for C<flags> is SVf_UTF8.
860 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
862 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
864 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
871 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
872 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
874 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
877 if (!(CvROOT(cv) || CvXSUB(cv)))
879 /* Have an autoload */
880 if (level < 0) /* Cannot do without a stub */
881 gv_fetchmeth_pvn(stash, name, len, 0, flags);
882 gvp = (GV**)hv_fetch(stash, name,
883 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
892 =for apidoc gv_fetchmethod_autoload
894 Returns the glob which contains the subroutine to call to invoke the method
895 on the C<stash>. In fact in the presence of autoloading this may be the
896 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
899 The third parameter of C<gv_fetchmethod_autoload> determines whether
900 AUTOLOAD lookup is performed if the given method is not present: non-zero
901 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
902 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
903 with a non-zero C<autoload> parameter.
905 These functions grant C<"SUPER"> token
906 as a prefix of the method name. Note
907 that if you want to keep the returned glob for a long time, you need to
908 check for it being "AUTOLOAD", since at the later time the call may load a
909 different subroutine due to $AUTOLOAD changing its value. Use the glob
910 created as a side effect to do this.
912 These functions have the same side-effects as C<gv_fetchmeth> with
913 C<level==0>. The warning against passing the GV returned by
914 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
920 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
922 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
924 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
928 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
932 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
933 namepv = SvPV(namesv, namelen);
936 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
940 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
942 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
943 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
946 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
949 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
952 const char *nsplit = NULL;
955 const char * const origname = name;
956 SV *const error_report = MUTABLE_SV(stash);
957 const U32 autoload = flags & GV_AUTOLOAD;
958 const U32 do_croak = flags & GV_CROAK;
959 const U32 is_utf8 = flags & SVf_UTF8;
961 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
963 if (SvTYPE(stash) < SVt_PVHV)
966 /* The only way stash can become NULL later on is if nsplit is set,
967 which in turn means that there is no need for a SVt_PVHV case
968 the error reporting code. */
971 for (nend = name; *nend || nend != (origname + len); nend++) {
976 else if (*nend == ':' && *(nend + 1) == ':') {
982 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
983 /* ->SUPER::method should really be looked up in original stash */
984 stash = CopSTASH(PL_curcop);
986 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
987 origname, HvENAME_get(stash), name) );
989 else if ((nsplit - origname) >= 7 &&
990 strnEQ(nsplit - 7, "::SUPER", 7)) {
991 /* don't autovifify if ->NoSuchStash::SUPER::method */
992 stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
993 if (stash) flags |= GV_SUPER;
996 /* don't autovifify if ->NoSuchStash::method */
997 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1002 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1004 if (strEQ(name,"import") || strEQ(name,"unimport"))
1005 gv = MUTABLE_GV(&PL_sv_yes);
1007 gv = gv_autoload_pvn(
1008 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1010 if (!gv && do_croak) {
1011 /* Right now this is exclusively for the benefit of S_method_common
1014 /* If we can't find an IO::File method, it might be a call on
1015 * a filehandle. If IO:File has not been loaded, try to
1016 * require it first instead of croaking */
1017 const char *stash_name = HvNAME_get(stash);
1018 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1019 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1020 STR_WITH_LEN("IO/File.pm"), 0,
1021 HV_FETCH_ISEXISTS, NULL, 0)
1023 require_pv("IO/File.pm");
1024 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1029 "Can't locate object method \"%"UTF8f
1030 "\" via package \"%"HEKf"\"",
1031 UTF8fARG(is_utf8, nend - name, name),
1032 HEKfARG(HvNAME_HEK(stash)));
1038 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1039 SVs_TEMP | is_utf8);
1041 packnamesv = error_report;
1045 "Can't locate object method \"%"UTF8f
1046 "\" via package \"%"SVf"\""
1047 " (perhaps you forgot to load \"%"SVf"\"?)",
1048 UTF8fARG(is_utf8, nend - name, name),
1049 SVfARG(packnamesv), SVfARG(packnamesv));
1053 else if (autoload) {
1054 CV* const cv = GvCV(gv);
1055 if (!CvROOT(cv) && !CvXSUB(cv)) {
1059 if (CvANON(cv) || !CvGV(cv))
1063 if (GvCV(stubgv) != cv) /* orphaned import */
1066 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1067 GvNAME(stubgv), GvNAMELEN(stubgv),
1068 GV_AUTOLOAD_ISMETHOD
1069 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1079 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1083 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1084 namepv = SvPV(namesv, namelen);
1087 return gv_autoload_pvn(stash, namepv, namelen, flags);
1091 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1093 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1094 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1098 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1105 SV *packname = NULL;
1106 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1108 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1110 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1113 if (SvTYPE(stash) < SVt_PVHV) {
1114 STRLEN packname_len = 0;
1115 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1116 packname = newSVpvn_flags(packname_ptr, packname_len,
1117 SVs_TEMP | SvUTF8(stash));
1121 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1122 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1124 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1125 is_utf8 | (flags & GV_SUPER))))
1129 if (!(CvROOT(cv) || CvXSUB(cv)))
1133 * Inheriting AUTOLOAD for non-methods works ... for now.
1136 !(flags & GV_AUTOLOAD_ISMETHOD)
1137 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1139 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1140 "Use of inherited AUTOLOAD for non-method %"SVf
1141 "::%"UTF8f"() is deprecated",
1143 UTF8fARG(is_utf8, len, name));
1146 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1147 * and split that value on the last '::', pass along the same data
1148 * via the SvPVX field in the CV, and the stash in CvSTASH.
1150 * Due to an unfortunate accident of history, the SvPVX field
1151 * serves two purposes. It is also used for the subroutine's pro-
1152 * type. Since SvPVX has been documented as returning the sub name
1153 * for a long time, but not as returning the prototype, we have
1154 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1157 * We put the prototype in the same allocated buffer, but after
1158 * the sub name. The SvPOK flag indicates the presence of a proto-
1159 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1160 * If both flags are on, then SvLEN is used to indicate the end of
1161 * the prototype (artificially lower than what is actually allo-
1162 * cated), at the risk of having to reallocate a few bytes unneces-
1163 * sarily--but that should happen very rarely, if ever.
1165 * We use SvUTF8 for both prototypes and sub names, so if one is
1166 * UTF8, the other must be upgraded.
1168 CvSTASH_set(cv, stash);
1169 if (SvPOK(cv)) { /* Ouch! */
1170 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1172 const char *proto = CvPROTO(cv);
1175 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1176 ulen = SvCUR(tmpsv);
1177 SvCUR(tmpsv)++; /* include null in string */
1179 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1181 SvTEMP_on(tmpsv); /* Allow theft */
1182 sv_setsv_nomg((SV *)cv, tmpsv);
1184 SvREFCNT_dec_NN(tmpsv);
1185 SvLEN(cv) = SvCUR(cv) + 1;
1189 sv_setpvn((SV *)cv, name, len);
1193 else SvUTF8_off(cv);
1199 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1200 * The subroutine's original name may not be "AUTOLOAD", so we don't
1201 * use that, but for lack of anything better we will use the sub's
1202 * original package to look up $AUTOLOAD.
1204 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1205 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1209 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1210 #ifdef PERL_DONT_CREATE_GVSV
1211 GvSV(vargv) = newSV(0);
1215 varsv = GvSVn(vargv);
1216 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1217 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1218 sv_setsv(varsv, packname);
1219 sv_catpvs(varsv, "::");
1220 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1221 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1224 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1232 /* require_tie_mod() internal routine for requiring a module
1233 * that implements the logic of automatic ties like %! and %-
1235 * The "gv" parameter should be the glob.
1236 * "varpv" holds the name of the var, used for error messages.
1237 * "namesv" holds the module name. Its refcount will be decremented.
1238 * "methpv" holds the method name to test for to check that things
1239 * are working reasonably close to as expected.
1240 * "flags": if flag & 1 then save the scalar before loading.
1241 * For the protection of $! to work (it is set by this routine)
1242 * the sv slot must already be magicalized.
1245 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1247 HV* stash = gv_stashsv(namesv, 0);
1249 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1251 if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1252 SV *module = newSVsv(namesv);
1253 char varname = *varpv; /* varpv might be clobbered by load_module,
1254 so save it. For the moment it's always
1256 const char type = varname == '[' ? '$' : '%';
1264 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1265 assert(sp == PL_stack_sp);
1266 stash = gv_stashsv(namesv, 0);
1268 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1269 type, varname, SVfARG(namesv));
1270 else if (!gv_fetchmethod(stash, methpv))
1271 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1272 type, varname, SVfARG(namesv), methpv);
1275 else SvREFCNT_dec_NN(namesv);
1280 =for apidoc gv_stashpv
1282 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1283 determine the length of C<name>, then calls C<gv_stashpvn()>.
1289 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1291 PERL_ARGS_ASSERT_GV_STASHPV;
1292 return gv_stashpvn(name, strlen(name), create);
1296 =for apidoc gv_stashpvn
1298 Returns a pointer to the stash for a specified package. The C<namelen>
1299 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1300 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1301 created if it does not already exist. If the package does not exist and
1302 C<flags> is 0 (or any other setting that does not create packages) then NULL
1305 Flags may be one of:
1314 The most important of which are probably GV_ADD and SVf_UTF8.
1316 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1317 recommended for performance reasons.
1323 gv_stashpvn_internal
1325 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1326 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1330 PERL_STATIC_INLINE HV*
1331 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1337 U32 tmplen = namelen + 2;
1339 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1341 if (tmplen <= sizeof smallbuf)
1344 Newx(tmpbuf, tmplen, char);
1345 Copy(name, tmpbuf, namelen, char);
1346 tmpbuf[namelen] = ':';
1347 tmpbuf[namelen+1] = ':';
1348 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1349 if (tmpbuf != smallbuf)
1353 stash = GvHV(tmpgv);
1354 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1356 if (!HvNAME_get(stash)) {
1357 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1359 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1360 /* If the containing stash has multiple effective
1361 names, see that this one gets them, too. */
1362 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1363 mro_package_moved(stash, NULL, tmpgv, 1);
1369 gv_stashsvpvn_cached
1371 Returns a pointer to the stash for a specified package, possibly
1372 cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
1374 Requires one of either namesv or namepv to be non-null.
1376 See C<gv_stashpvn> for details on "flags".
1378 Note the sv interface is strongly preferred for performance reasons.
1382 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1383 assert(namesv || name)
1385 PERL_STATIC_INLINE HV*
1386 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1391 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1393 he = (HE *)hv_common(
1394 PL_stashcache, namesv, name, namelen,
1395 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1398 if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
1399 else if (flags & GV_CACHE_ONLY) return NULL;
1402 if (SvOK(namesv)) { /* prevent double uninit warning */
1404 name = SvPV_const(namesv, len);
1406 flags |= SvUTF8(namesv);
1408 name = ""; namelen = 0;
1411 stash = gv_stashpvn_internal(name, namelen, flags);
1413 if (stash && namelen) {
1414 SV* const ref = newSViv(PTR2IV(stash));
1415 (void)hv_store(PL_stashcache, name,
1416 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1423 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1425 PERL_ARGS_ASSERT_GV_STASHPVN;
1426 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1430 =for apidoc gv_stashsv
1432 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
1434 Note this interface is strongly preferred over C<gv_stashpvn> for performance reasons.
1440 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1442 PERL_ARGS_ASSERT_GV_STASHSV;
1443 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1448 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1449 PERL_ARGS_ASSERT_GV_FETCHPV;
1450 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1454 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1456 const char * const nambeg =
1457 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1458 PERL_ARGS_ASSERT_GV_FETCHSV;
1459 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1462 PERL_STATIC_INLINE void
1463 S_gv_magicalize_isa(pTHX_ GV *gv)
1467 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1471 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1475 /* This function grabs name and tries to split a stash and glob
1476 * from its contents. TODO better description, comments
1478 * If the function returns TRUE and 'name == name_end', then
1479 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1481 PERL_STATIC_INLINE bool
1482 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1483 STRLEN *len, const char *nambeg, STRLEN full_len,
1484 const U32 is_utf8, const I32 add)
1486 const char *name_cursor;
1487 const char *const name_end = nambeg + full_len;
1488 const char *const name_em1 = name_end - 1;
1490 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1492 if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
1493 /* accidental stringify on a GV? */
1497 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1498 if (name_cursor < name_em1 &&
1499 ((*name_cursor == ':' && name_cursor[1] == ':')
1500 || *name_cursor == '\''))
1503 *stash = PL_defstash;
1504 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1507 *len = name_cursor - *name;
1508 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1511 if (*name_cursor == ':') {
1517 Newx(tmpbuf, *len+2, char);
1518 Copy(*name, tmpbuf, *len, char);
1519 tmpbuf[(*len)++] = ':';
1520 tmpbuf[(*len)++] = ':';
1523 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1524 *gv = gvp ? *gvp : NULL;
1525 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1526 if (SvTYPE(*gv) != SVt_PVGV)
1527 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1533 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1536 if (!(*stash = GvHV(*gv))) {
1537 *stash = GvHV(*gv) = newHV();
1538 if (!HvNAME_get(*stash)) {
1539 if (GvSTASH(*gv) == PL_defstash && *len == 6
1540 && strnEQ(*name, "CORE", 4))
1541 hv_name_set(*stash, "CORE", 4, 0);
1544 *stash, nambeg, name_cursor-nambeg, is_utf8
1546 /* If the containing stash has multiple effective
1547 names, see that this one gets them, too. */
1548 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1549 mro_package_moved(*stash, NULL, *gv, 1);
1552 else if (!HvNAME_get(*stash))
1553 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1556 if (*name_cursor == ':')
1558 *name = name_cursor+1;
1559 if (*name == name_end) {
1561 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1566 *len = name_cursor - *name;
1570 /* Checks if an unqualified name is in the main stash */
1571 PERL_STATIC_INLINE bool
1572 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1574 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1576 /* If it's an alphanumeric variable */
1577 if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
1578 /* Some "normal" variables are always in main::,
1579 * like INC or STDOUT.
1587 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1588 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1589 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1593 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1598 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1599 && name[3] == 'I' && name[4] == 'N')
1603 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1604 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1605 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1609 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1610 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1616 /* *{""}, or a special variable like $@ */
1624 /* This function is called if parse_gv_stash_name() failed to
1625 * find a stash, or if GV_NOTQUAL or an empty name was passed
1626 * to gv_fetchpvn_flags.
1628 * It returns FALSE if the default stash can't be found nor created,
1629 * which might happen during global destruction.
1631 PERL_STATIC_INLINE bool
1632 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1633 const U32 is_utf8, const I32 add,
1634 const svtype sv_type)
1636 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1638 /* No stash in name, so see how we can default */
1640 if ( gv_is_in_main(name, len, is_utf8) ) {
1641 *stash = PL_defstash;
1644 if (IN_PERL_COMPILETIME) {
1645 *stash = PL_curstash;
1646 if (add && (PL_hints & HINT_STRICT_VARS) &&
1647 sv_type != SVt_PVCV &&
1648 sv_type != SVt_PVGV &&
1649 sv_type != SVt_PVFM &&
1650 sv_type != SVt_PVIO &&
1651 !(len == 1 && sv_type == SVt_PV &&
1652 (*name == 'a' || *name == 'b')) )
1654 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1655 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1656 SvTYPE(*gvp) != SVt_PVGV)
1660 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1661 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1662 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1664 /* diag_listed_as: Variable "%s" is not imported%s */
1666 aTHX_ packWARN(WARN_MISC),
1667 "Variable \"%c%"UTF8f"\" is not imported",
1668 sv_type == SVt_PVAV ? '@' :
1669 sv_type == SVt_PVHV ? '%' : '$',
1670 UTF8fARG(is_utf8, len, name));
1673 aTHX_ packWARN(WARN_MISC),
1674 "\t(Did you mean &%"UTF8f" instead?)\n",
1675 UTF8fARG(is_utf8, len, name)
1682 /* Use the current op's stash */
1683 *stash = CopSTASH(PL_curcop);
1688 if (add && !PL_in_clean_all) {
1689 SV * const err = Perl_mess(aTHX_
1690 "Global symbol \"%s%"UTF8f
1691 "\" requires explicit package name",
1692 (sv_type == SVt_PV ? "$"
1693 : sv_type == SVt_PVAV ? "@"
1694 : sv_type == SVt_PVHV ? "%"
1695 : ""), UTF8fARG(is_utf8, len, name));
1700 /* To maintain the output of errors after the strict exception
1701 * above, and to keep compat with older releases, rather than
1702 * placing the variables in the pad, we place
1703 * them in the <none>:: stash.
1705 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1707 /* symbol table under destruction */
1716 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1722 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1724 * Note that it does not insert the GV into the stash prior to
1725 * magicalization, which some variables require need in order
1726 * to work (like $[, %+, %-, %!), so callers must take care of
1729 * The return value has a specific meaning for gv_fetchpvn_flags:
1730 * If it returns true, and the gv is empty, it indicates that its
1731 * refcount should be decreased.
1733 PERL_STATIC_INLINE bool
1734 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1735 bool addmg, const svtype sv_type)
1739 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1741 if (stash != PL_defstash) { /* not the main stash */
1742 /* We only have to check for a few names here: a, b, EXPORT, ISA
1743 and VERSION. All the others apply only to the main stash or to
1744 CORE (which is checked right after this). */
1746 const char * const name2 = name + 1;
1749 if (strnEQ(name2, "XPORT", 5))
1753 if (strEQ(name2, "SA"))
1754 gv_magicalize_isa(gv);
1757 if (strEQ(name2, "ERSION"))
1762 if (len == 1 && sv_type == SVt_PV)
1771 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1772 /* Avoid null warning: */
1773 const char * const stashname = HvNAME(stash); assert(stashname);
1774 if (strnEQ(stashname, "CORE", 4))
1775 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1782 /* Nothing else to do.
1783 The compiler will probably turn the switch statement into a
1784 branch table. Make sure we avoid even that small overhead for
1785 the common case of lower case variable names. (On EBCDIC
1786 platforms, we can't just do:
1787 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1788 because cases like '\027' in the switch statement below are
1789 C1 (non-ASCII) controls on those platforms, so the remapping
1790 would make them larger than 'V')
1795 const char * const name2 = name + 1;
1798 if (strEQ(name2, "RGV")) {
1799 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1801 else if (strEQ(name2, "RGVOUT")) {
1806 if (strnEQ(name2, "XPORT", 5))
1810 if (strEQ(name2, "SA")) {
1811 gv_magicalize_isa(gv);
1815 if (strEQ(name2, "IG")) {
1818 if (!PL_psig_name) {
1819 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1820 Newxz(PL_psig_pend, SIG_SIZE, int);
1821 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1823 /* I think that the only way to get here is to re-use an
1824 embedded perl interpreter, where the previous
1825 use didn't clean up fully because
1826 PL_perl_destruct_level was 0. I'm not sure that we
1827 "support" that, in that I suspect in that scenario
1828 there are sufficient other garbage values left in the
1829 interpreter structure that something else will crash
1830 before we get here. I suspect that this is one of
1831 those "doctor, it hurts when I do this" bugs. */
1832 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1833 Zero(PL_psig_pend, SIG_SIZE, int);
1837 hv_magic(hv, NULL, PERL_MAGIC_sig);
1838 for (i = 1; i < SIG_SIZE; i++) {
1839 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1841 sv_setsv(*init, &PL_sv_undef);
1846 if (strEQ(name2, "ERSION"))
1849 case '\003': /* $^CHILD_ERROR_NATIVE */
1850 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1853 case '\005': /* $^ENCODING */
1854 if (strEQ(name2, "NCODING"))
1857 case '\007': /* $^GLOBAL_PHASE */
1858 if (strEQ(name2, "LOBAL_PHASE"))
1861 case '\014': /* $^LAST_FH */
1862 if (strEQ(name2, "AST_FH"))
1865 case '\015': /* $^MATCH */
1866 if (strEQ(name2, "ATCH")) {
1867 paren = RX_BUFF_IDX_CARET_FULLMATCH;
1871 case '\017': /* $^OPEN */
1872 if (strEQ(name2, "PEN"))
1875 case '\020': /* $^PREMATCH $^POSTMATCH */
1876 if (strEQ(name2, "REMATCH")) {
1877 paren = RX_BUFF_IDX_CARET_PREMATCH;
1880 if (strEQ(name2, "OSTMATCH")) {
1881 paren = RX_BUFF_IDX_CARET_POSTMATCH;
1885 case '\024': /* ${^TAINT} */
1886 if (strEQ(name2, "AINT"))
1889 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1890 if (strEQ(name2, "NICODE"))
1892 if (strEQ(name2, "TF8LOCALE"))
1894 if (strEQ(name2, "TF8CACHE"))
1897 case '\027': /* $^WARNING_BITS */
1898 if (strEQ(name2, "ARNING_BITS"))
1911 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1913 /* This snippet is taken from is_gv_magical */
1914 const char *end = name + len;
1915 while (--end > name) {
1919 paren = grok_atou(name, NULL);
1925 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1926 be case '\0' in this switch statement (ie a default case) */
1929 paren = RX_BUFF_IDX_FULLMATCH;
1932 paren = RX_BUFF_IDX_PREMATCH;
1935 paren = RX_BUFF_IDX_POSTMATCH;
1937 #ifdef PERL_SAWAMPERSAND
1939 sv_type == SVt_PVAV ||
1940 sv_type == SVt_PVHV ||
1941 sv_type == SVt_PVCV ||
1942 sv_type == SVt_PVFM ||
1944 )) { PL_sawampersand |=
1948 ? SAWAMPERSAND_MIDDLE
1949 : SAWAMPERSAND_RIGHT;
1962 paren = *name - '0';
1965 /* Flag the capture variables with a NULL mg_ptr
1966 Use mg_len for the array index to lookup. */
1967 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
1971 sv_setpv(GvSVn(gv),PL_chopset);
1975 #ifdef COMPLEX_STATUS
1976 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1982 /* If %! has been used, automatically load Errno.pm. */
1984 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1986 /* magicalization must be done before require_tie_mod is called */
1987 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1989 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1996 GvMULTI_on(gv); /* no used once warnings here */
1998 AV* const av = GvAVn(gv);
1999 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
2001 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
2002 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2004 SvREADONLY_on(GvSVn(gv));
2007 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2009 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2017 if (sv_type == SVt_PV)
2018 /* diag_listed_as: $* is no longer supported */
2019 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
2020 "$%c is no longer supported", *name);
2022 case '\010': /* $^H */
2024 HV *const hv = GvHVn(gv);
2025 hv_magic(hv, NULL, PERL_MAGIC_hints);
2029 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2030 && FEATURE_ARYBASE_IS_ENABLED) {
2031 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2034 else goto magicalize;
2036 case '\023': /* $^S */
2038 SvREADONLY_on(GvSVn(gv));
2054 case '\001': /* $^A */
2055 case '\003': /* $^C */
2056 case '\004': /* $^D */
2057 case '\005': /* $^E */
2058 case '\006': /* $^F */
2059 case '\011': /* $^I, NOT \t in EBCDIC */
2060 case '\016': /* $^N */
2061 case '\017': /* $^O */
2062 case '\020': /* $^P */
2063 case '\024': /* $^T */
2064 case '\027': /* $^W */
2066 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2069 case '\014': /* $^L */
2070 sv_setpvs(GvSVn(gv),"\f");
2073 sv_setpvs(GvSVn(gv),"\034");
2077 SV * const sv = GvSV(gv);
2078 if (!sv_derived_from(PL_patchlevel, "version"))
2079 upg_version(PL_patchlevel, TRUE);
2080 GvSV(gv) = vnumify(PL_patchlevel);
2081 SvREADONLY_on(GvSV(gv));
2085 case '\026': /* $^V */
2087 SV * const sv = GvSV(gv);
2088 GvSV(gv) = new_version(PL_patchlevel);
2089 SvREADONLY_on(GvSV(gv));
2095 if (sv_type == SVt_PV)
2103 /* This function is called when the stash already holds the GV of the magic
2104 * variable we're looking for, but we need to check that it has the correct
2105 * kind of magic. For example, if someone first uses $! and then %!, the
2106 * latter would end up here, and we add the Errno tie to the HASH slot of
2109 PERL_STATIC_INLINE void
2110 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2112 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2114 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2116 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2117 else if (*name == '-' || *name == '+')
2118 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2119 } else if (sv_type == SVt_PV) {
2120 if (*name == '*' || *name == '#') {
2121 /* diag_listed_as: $* is no longer supported */
2122 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2124 "$%c is no longer supported", *name);
2127 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2130 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2132 #ifdef PERL_SAWAMPERSAND
2134 PL_sawampersand |= SAWAMPERSAND_LEFT;
2138 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2142 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2151 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2152 const svtype sv_type)
2154 const char *name = nambeg;
2159 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2160 const I32 no_expand = flags & GV_NOEXPAND;
2161 const I32 add = flags & ~GV_NOADD_MASK;
2162 const U32 is_utf8 = flags & SVf_UTF8;
2163 bool addmg = cBOOL(flags & GV_ADDMG);
2164 const char *const name_end = nambeg + full_len;
2167 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2169 /* If we have GV_NOTQUAL, the caller promised that
2170 * there is no stash, so we can skip the check.
2171 * Similarly if full_len is 0, since then we're
2172 * dealing with something like *{""} or ""->foo()
2174 if ((flags & GV_NOTQUAL) || !full_len) {
2177 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2178 if (name == name_end) return gv;
2184 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2188 /* By this point we should have a stash and a name */
2189 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2190 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2191 if (addmg) gv = (GV *)newSV(0);
2194 else gv = *gvp, addmg = 0;
2195 /* From this point on, addmg means gv has not been inserted in the
2198 if (SvTYPE(gv) == SVt_PVGV) {
2199 /* The GV already exists, so return it, but check if we need to do
2200 * anything else with it before that.
2203 /* This is the heuristic that handles if a variable triggers the
2204 * 'used only once' warning. If there's already a GV in the stash
2205 * with this name, then we assume that the variable has been used
2206 * before and turn its MULTI flag on.
2207 * It's a heuristic because it can easily be "tricked", like with
2208 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2209 * not warning about $main::foo being used just once
2212 gv_init_svtype(gv, sv_type);
2213 /* You reach this path once the typeglob has already been created,
2214 either by the same or a different sigil. If this path didn't
2215 exist, then (say) referencing $! first, and %! second would
2216 mean that %! was not handled correctly. */
2217 if (len == 1 && stash == PL_defstash) {
2218 maybe_multimagic_gv(gv, name, sv_type);
2220 else if (len == 3 && sv_type == SVt_PVAV
2221 && strnEQ(name, "ISA", 3)
2222 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2223 gv_magicalize_isa(gv);
2226 } else if (no_init) {
2230 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2231 * don't expand it to a glob. This is an optimization so that things
2232 * copying constants over, like Exporter, don't have to be rewritten
2233 * to take into account that you can store more than just globs in
2236 else if (no_expand && SvROK(gv)) {
2241 /* Adding a new symbol.
2242 Unless of course there was already something non-GV here, in which case
2243 we want to behave as if there was always a GV here, containing some sort
2245 Otherwise we run the risk of creating things like GvIO, which can cause
2246 subtle bugs. eg the one that tripped up SQL::Translator */
2248 faking_it = SvOK(gv);
2250 if (add & GV_ADDWARN)
2251 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2252 "Had to create %"UTF8f" unexpectedly",
2253 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2254 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2256 if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
2259 /* First, store the gv in the symtab if we're adding magic,
2260 * but only for non-empty GVs
2262 #define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
2263 || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
2265 if ( addmg && !GvEMPTY(gv) ) {
2266 (void)hv_store(stash,name,len,(SV *)gv,0);
2269 /* set up magic where warranted */
2270 if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
2273 if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
2274 /* The GV was and still is "empty", except that now
2275 * it has the magic flags turned on, so we want it
2276 * stored in the symtab.
2278 (void)hv_store(stash,name,len,(SV *)gv,0);
2281 /* Most likely the temporary GV created above */
2282 SvREFCNT_dec_NN(gv);
2288 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2293 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2296 const HV * const hv = GvSTASH(gv);
2298 PERL_ARGS_ASSERT_GV_FULLNAME4;
2300 sv_setpv(sv, prefix ? prefix : "");
2302 if (hv && (name = HvNAME(hv))) {
2303 const STRLEN len = HvNAMELEN(hv);
2304 if (keepmain || strnNE(name, "main", len)) {
2305 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2309 else sv_catpvs(sv,"__ANON__::");
2310 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2314 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2316 const GV * const egv = GvEGVx(gv);
2318 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2320 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2324 /* recursively scan a stash and any nested stashes looking for entries
2325 * that need the "only used once" warning raised
2329 Perl_gv_check(pTHX_ HV *stash)
2333 PERL_ARGS_ASSERT_GV_CHECK;
2335 if (!HvARRAY(stash))
2338 assert(SvOOK(stash));
2340 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2342 /* mark stash is being scanned, to avoid recursing */
2343 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2344 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2347 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2348 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2350 if (hv != PL_defstash && hv != stash
2352 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2354 gv_check(hv); /* nested package */
2356 else if ( *HeKEY(entry) != '_'
2357 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2359 gv = MUTABLE_GV(HeVAL(entry));
2360 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2363 CopLINE_set(PL_curcop, GvLINE(gv));
2365 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2367 CopFILEGV(PL_curcop)
2368 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2370 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2371 "Name \"%"HEKf"::%"HEKf
2372 "\" used only once: possible typo",
2373 HEKfARG(HvNAME_HEK(stash)),
2374 HEKfARG(GvNAME_HEK(gv)));
2377 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2382 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2384 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2385 assert(!(flags & ~SVf_UTF8));
2387 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2388 UTF8fARG(flags, strlen(pack), pack),
2393 /* hopefully this is only called on local symbol table entries */
2396 Perl_gp_ref(pTHX_ GP *gp)
2403 /* If the GP they asked for a reference to contains
2404 a method cache entry, clear it first, so that we
2405 don't infect them with our cached entry */
2406 SvREFCNT_dec_NN(gp->gp_cv);
2415 Perl_gp_free(pTHX_ GV *gv)
2420 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2422 if (gp->gp_refcnt == 0) {
2423 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2424 "Attempt to free unreferenced glob pointers"
2425 pTHX__FORMAT pTHX__VALUE);
2428 if (gp->gp_refcnt > 1) {
2430 if (gp->gp_egv == gv)
2438 /* Copy and null out all the glob slots, so destructors do not see
2440 HEK * const file_hek = gp->gp_file_hek;
2441 SV * const sv = gp->gp_sv;
2442 AV * const av = gp->gp_av;
2443 HV * const hv = gp->gp_hv;
2444 IO * const io = gp->gp_io;
2445 CV * const cv = gp->gp_cv;
2446 CV * const form = gp->gp_form;
2448 gp->gp_file_hek = NULL;
2457 unshare_hek(file_hek);
2461 /* FIXME - another reference loop GV -> symtab -> GV ?
2462 Somehow gp->gp_hv can end up pointing at freed garbage. */
2463 if (hv && SvTYPE(hv) == SVt_PVHV) {
2464 const HEK *hvname_hek = HvNAME_HEK(hv);
2465 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek)));
2466 if (PL_stashcache && hvname_hek)
2467 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2474 /* Possibly reallocated by a destructor */
2477 if (!gp->gp_file_hek
2483 && !gp->gp_form) break;
2485 if (--attempts == 0) {
2487 "panic: gp_free failed to free glob pointer - "
2488 "something is repeatedly re-creating entries"
2493 /* Possibly incremented by a destructor doing glob assignment */
2494 if (gp->gp_refcnt > 1) goto borrowed;
2500 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2502 AMT * const amtp = (AMT*)mg->mg_ptr;
2503 PERL_UNUSED_ARG(sv);
2505 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2507 if (amtp && AMT_AMAGIC(amtp)) {
2509 for (i = 1; i < NofAMmeth; i++) {
2510 CV * const cv = amtp->table[i];
2512 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2513 amtp->table[i] = NULL;
2520 /* Updates and caches the CV's */
2522 * 1 on success and there is some overload
2523 * 0 if there is no overload
2524 * -1 if some error occurred and it couldn't croak
2528 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2530 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2532 const struct mro_meta* stash_meta = HvMROMETA(stash);
2535 PERL_ARGS_ASSERT_GV_AMUPDATE;
2537 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2539 const AMT * const amtp = (AMT*)mg->mg_ptr;
2540 if (amtp->was_ok_sub == newgen) {
2541 return AMT_AMAGIC(amtp) ? 1 : 0;
2543 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2546 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2549 amt.was_ok_sub = newgen;
2550 amt.fallback = AMGfallNO;
2556 bool deref_seen = 0;
2559 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2561 /* Try to find via inheritance. */
2562 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2563 SV * const sv = gv ? GvSV(gv) : NULL;
2568 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2571 #ifdef PERL_DONT_CREATE_GVSV
2573 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2576 else if (SvTRUE(sv))
2577 /* don't need to set overloading here because fallback => 1
2578 * is the default setting for classes without overloading */
2579 amt.fallback=AMGfallYES;
2580 else if (SvOK(sv)) {
2581 amt.fallback=AMGfallNEVER;
2588 assert(SvOOK(stash));
2589 /* initially assume the worst */
2590 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2592 for (i = 1; i < NofAMmeth; i++) {
2593 const char * const cooky = PL_AMG_names[i];
2594 /* Human-readable form, for debugging: */
2595 const char * const cp = AMG_id2name(i);
2596 const STRLEN l = PL_AMG_namelens[i];
2598 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2599 cp, HvNAME_get(stash)) );
2600 /* don't fill the cache while looking up!
2601 Creation of inheritance stubs in intermediate packages may
2602 conflict with the logic of runtime method substitution.
2603 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2604 then we could have created stubs for "(+0" in A and C too.
2605 But if B overloads "bool", we may want to use it for
2606 numifying instead of C's "+0". */
2607 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2609 if (gv && (cv = GvCV(gv)) && CvGV(cv)) {
2610 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2611 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2612 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2613 && strEQ(hvname, "overload")) {
2614 /* This is a hack to support autoloading..., while
2615 knowing *which* methods were declared as overloaded. */
2616 /* GvSV contains the name of the method. */
2618 SV *gvsv = GvSV(gv);
2620 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2621 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2622 (void*)GvSV(gv), cp, HvNAME(stash)) );
2623 if (!gvsv || !SvPOK(gvsv)
2624 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2626 /* Can be an import stub (created by "can"). */
2631 const SV * const name = (gvsv && SvPOK(gvsv))
2633 : newSVpvs_flags("???", SVs_TEMP);
2634 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2635 Perl_croak(aTHX_ "%s method \"%"SVf256
2636 "\" overloading \"%s\" "\
2637 "in package \"%"HEKf256"\"",
2638 (GvCVGEN(gv) ? "Stub found while resolving"
2646 cv = GvCV(gv = ngv);
2649 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2650 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2651 GvNAME(CvGV(cv))) );
2653 } else if (gv) { /* Autoloaded... */
2654 cv = MUTABLE_CV(gv);
2657 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2673 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2674 * NB - aux var invalid here, HvARRAY() could have been
2675 * reallocated since it was assigned to */
2676 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2679 AMT_AMAGIC_on(&amt);
2680 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2681 (char*)&amt, sizeof(AMT));
2685 /* Here we have no table: */
2687 AMT_AMAGIC_off(&amt);
2688 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2689 (char*)&amt, sizeof(AMTS));
2695 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2700 struct mro_meta* stash_meta;
2702 if (!stash || !HvNAME_get(stash))
2705 stash_meta = HvMROMETA(stash);
2706 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2708 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2711 if (Gv_AMupdate(stash, 0) == -1)
2713 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2716 amtp = (AMT*)mg->mg_ptr;
2717 if ( amtp->was_ok_sub != newgen )
2719 if (AMT_AMAGIC(amtp)) {
2720 CV * const ret = amtp->table[id];
2721 if (ret && isGV(ret)) { /* Autoloading stab */
2722 /* Passing it through may have resulted in a warning
2723 "Inherited AUTOLOAD for a non-method deprecated", since
2724 our caller is going through a function call, not a method call.
2725 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2726 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2738 /* Implement tryAMAGICun_MG macro.
2739 Do get magic, then see if the stack arg is overloaded and if so call it.
2741 AMGf_set return the arg using SETs rather than assigning to
2743 AMGf_numeric apply sv_2num to the stack arg.
2747 Perl_try_amagic_un(pTHX_ int method, int flags) {
2750 SV* const arg = TOPs;
2754 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2755 AMGf_noright | AMGf_unary))) {
2756 if (flags & AMGf_set) {
2761 if (SvPADMY(TARG)) {
2762 sv_setsv(TARG, tmpsv);
2772 if ((flags & AMGf_numeric) && SvROK(arg))
2778 /* Implement tryAMAGICbin_MG macro.
2779 Do get magic, then see if the two stack args are overloaded and if so
2782 AMGf_set return the arg using SETs rather than assigning to
2784 AMGf_assign op may be called as mutator (eg +=)
2785 AMGf_numeric apply sv_2num to the stack arg.
2789 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2791 SV* const left = TOPm1s;
2792 SV* const right = TOPs;
2798 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2799 SV * const tmpsv = amagic_call(left, right, method,
2800 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2802 if (flags & AMGf_set) {
2809 if (opASSIGN || SvPADMY(TARG)) {
2810 sv_setsv(TARG, tmpsv);
2820 if(left==right && SvGMAGICAL(left)) {
2821 SV * const left = sv_newmortal();
2823 /* Print the uninitialized warning now, so it includes the vari-
2826 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2827 sv_setsv_flags(left, &PL_sv_no, 0);
2829 else sv_setsv_flags(left, right, 0);
2832 if (flags & AMGf_numeric) {
2834 *(sp-1) = sv_2num(TOPm1s);
2836 *sp = sv_2num(right);
2842 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2846 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2850 /* return quickly if none of the deref ops are overloaded */
2851 stash = SvSTASH(SvRV(ref));
2852 assert(SvOOK(stash));
2853 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
2856 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
2857 AMGf_noright | AMGf_unary))) {
2859 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2860 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2861 /* Bail out if it returns us the same reference. */
2868 return tmpsv ? tmpsv : ref;
2872 Perl_amagic_is_enabled(pTHX_ int method)
2874 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2876 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2878 if ( !lex_mask || !SvOK(lex_mask) )
2879 /* overloading lexically disabled */
2881 else if ( lex_mask && SvPOK(lex_mask) ) {
2882 /* we have an entry in the hints hash, check if method has been
2883 * masked by overloading.pm */
2885 const int offset = method / 8;
2886 const int bit = method % 8;
2887 char *pv = SvPV(lex_mask, len);
2889 /* Bit set, so this overloading operator is disabled */
2890 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2897 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2902 CV **cvp=NULL, **ocvp=NULL;
2903 AMT *amtp=NULL, *oamtp=NULL;
2904 int off = 0, off1, lr = 0, notfound = 0;
2905 int postpr = 0, force_cpy = 0;
2906 int assign = AMGf_assign & flags;
2907 const int assignshift = assign ? 1 : 0;
2908 int use_default_op = 0;
2909 int force_scalar = 0;
2915 PERL_ARGS_ASSERT_AMAGIC_CALL;
2917 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2918 if (!amagic_is_enabled(method)) return NULL;
2921 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2922 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2923 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2924 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2925 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2927 && ((cv = cvp[off=method+assignshift])
2928 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2934 cv = cvp[off=method])))) {
2935 lr = -1; /* Call method for left argument */
2937 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2940 /* look for substituted methods */
2941 /* In all the covered cases we should be called with assign==0. */
2945 if ((cv = cvp[off=add_ass_amg])
2946 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2947 right = &PL_sv_yes; lr = -1; assign = 1;
2952 if ((cv = cvp[off = subtr_ass_amg])
2953 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2954 right = &PL_sv_yes; lr = -1; assign = 1;
2958 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2961 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2964 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2967 (void)((cv = cvp[off=bool__amg])
2968 || (cv = cvp[off=numer_amg])
2969 || (cv = cvp[off=string_amg]));
2976 * SV* ref causes confusion with the interpreter variable of
2979 SV* const tmpRef=SvRV(left);
2980 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2982 * Just to be extra cautious. Maybe in some
2983 * additional cases sv_setsv is safe, too.
2985 SV* const newref = newSVsv(tmpRef);
2986 SvOBJECT_on(newref);
2987 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2988 delegate to the stash. */
2989 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2995 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2996 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2997 SV* const nullsv=sv_2mortal(newSViv(0));
2999 SV* const lessp = amagic_call(left,nullsv,
3000 lt_amg,AMGf_noright);
3001 logic = SvTRUE(lessp);
3003 SV* const lessp = amagic_call(left,nullsv,
3004 ncmp_amg,AMGf_noright);
3005 logic = (SvNV(lessp) < 0);
3008 if (off==subtr_amg) {
3019 if ((cv = cvp[off=subtr_amg])) {
3021 left = sv_2mortal(newSViv(0));
3026 case iter_amg: /* XXXX Eventually should do to_gv. */
3027 case ftest_amg: /* XXXX Eventually should do to_gv. */
3030 return NULL; /* Delegate operation to standard mechanisms. */
3038 return left; /* Delegate operation to standard mechanisms. */
3043 if (!cv) goto not_found;
3044 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3045 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3046 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3047 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3048 ? (amtp = (AMT*)mg->mg_ptr)->table
3050 && (cv = cvp[off=method])) { /* Method for right
3053 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3054 || (ocvp && oamtp->fallback > AMGfallNEVER))
3055 && !(flags & AMGf_unary)) {
3056 /* We look for substitution for
3057 * comparison operations and
3059 if (method==concat_amg || method==concat_ass_amg
3060 || method==repeat_amg || method==repeat_ass_amg) {
3061 return NULL; /* Delegate operation to string conversion */
3083 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3087 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3097 not_found: /* No method found, either report or croak */
3105 return left; /* Delegate operation to standard mechanisms. */
3107 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3108 notfound = 1; lr = -1;
3109 } else if (cvp && (cv=cvp[nomethod_amg])) {
3110 notfound = 1; lr = 1;
3111 } else if ((use_default_op =
3112 (!ocvp || oamtp->fallback >= AMGfallYES)
3113 && (!cvp || amtp->fallback >= AMGfallYES))
3115 /* Skip generating the "no method found" message. */
3119 if (off==-1) off=method;
3120 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3121 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3122 AMG_id2name(method + assignshift),
3123 (flags & AMGf_unary ? " " : "\n\tleft "),
3125 "in overloaded package ":
3126 "has no overloaded magic",
3128 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3131 ",\n\tright argument in overloaded package ":
3134 : ",\n\tright argument has no overloaded magic"),
3136 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3137 SVfARG(&PL_sv_no)));
3138 if (use_default_op) {
3139 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3141 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3145 force_cpy = force_cpy || assign;
3150 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3151 * operation. we need this to return a value, so that it can be assigned
3152 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3153 * increment or decrement was itself called in void context */
3159 if (off == subtr_amg)
3162 /* in these cases, we're calling an assignment variant of an operator
3163 * (+= rather than +, for instance). regardless of whether it's a
3164 * fallback or not, it always has to return a value, which will be
3165 * assigned to the proper variable later */
3182 /* the copy constructor always needs to return a value */
3186 /* because of the way these are implemented (they don't perform the
3187 * dereferencing themselves, they return a reference that perl then
3188 * dereferences later), they always have to be in scalar context */
3196 /* these don't have an op of their own; they're triggered by their parent
3197 * op, so the context there isn't meaningful ('$a and foo()' in void
3198 * context still needs to pass scalar context on to $a's bool overload) */
3208 DEBUG_o(Perl_deb(aTHX_
3209 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3211 method+assignshift==off? "" :
3213 method+assignshift==off? "" :
3214 AMG_id2name(method+assignshift),
3215 method+assignshift==off? "" : "\")",
3216 flags & AMGf_unary? "" :
3217 lr==1 ? " for right argument": " for left argument",
3218 flags & AMGf_unary? " for argument" : "",
3219 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3220 fl? ",\n\tassignment variant used": "") );
3223 /* Since we use shallow copy during assignment, we need
3224 * to dublicate the contents, probably calling user-supplied
3225 * version of copy operator
3227 /* We need to copy in following cases:
3228 * a) Assignment form was called.
3229 * assignshift==1, assign==T, method + 1 == off
3230 * b) Increment or decrement, called directly.
3231 * assignshift==0, assign==0, method + 0 == off
3232 * c) Increment or decrement, translated to assignment add/subtr.
3233 * assignshift==0, assign==T,
3235 * d) Increment or decrement, translated to nomethod.
3236 * assignshift==0, assign==0,
3238 * e) Assignment form translated to nomethod.
3239 * assignshift==1, assign==T, method + 1 != off
3242 /* off is method, method+assignshift, or a result of opcode substitution.
3243 * In the latter case assignshift==0, so only notfound case is important.
3245 if ( (lr == -1) && ( ( (method + assignshift == off)
3246 && (assign || (method == inc_amg) || (method == dec_amg)))
3249 /* newSVsv does not behave as advertised, so we copy missing
3250 * information by hand */
3251 SV *tmpRef = SvRV(left);
3253 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3254 SvRV_set(left, rv_copy);
3256 SvREFCNT_dec_NN(tmpRef);
3264 const bool oldcatch = CATCH_GET;
3266 int gimme = force_scalar ? G_SCALAR : GIMME_V;
3269 Zero(&myop, 1, BINOP);
3270 myop.op_last = (OP *) &myop;
3271 myop.op_next = NULL;
3272 myop.op_flags = OPf_STACKED;
3276 myop.op_flags |= OPf_WANT_VOID;
3279 if (flags & AMGf_want_list) {
3280 myop.op_flags |= OPf_WANT_LIST;
3285 myop.op_flags |= OPf_WANT_SCALAR;
3289 PUSHSTACKi(PERLSI_OVERLOAD);
3292 PL_op = (OP *) &myop;
3293 if (PERLDB_SUB && PL_curstash != PL_debstash)
3294 PL_op->op_private |= OPpENTERSUB_DB;
3295 Perl_pp_pushmark(aTHX);
3297 EXTEND(SP, notfound + 5);
3298 PUSHs(lr>0? right: left);
3299 PUSHs(lr>0? left: right);
3300 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3302 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3303 AMG_id2namelen(method + assignshift), SVs_TEMP));
3305 PUSHs(MUTABLE_SV(cv));
3309 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3313 nret = SP - (PL_stack_base + oldmark);
3317 /* returning NULL has another meaning, and we check the context
3318 * at the call site too, so this can be differentiated from the
3321 SP = PL_stack_base + oldmark;
3324 if (flags & AMGf_want_list) {
3325 res = sv_2mortal((SV *)newAV());
3326 av_extend((AV *)res, nret);
3328 av_store((AV *)res, nret, POPs);
3340 CATCH_SET(oldcatch);
3347 ans=SvIV(res)<=0; break;
3350 ans=SvIV(res)<0; break;
3353 ans=SvIV(res)>=0; break;
3356 ans=SvIV(res)>0; break;
3359 ans=SvIV(res)==0; break;
3362 ans=SvIV(res)!=0; break;
3365 SvSetSV(left,res); return left;
3367 ans=!SvTRUE(res); break;
3372 } else if (method==copy_amg) {
3374 Perl_croak(aTHX_ "Copy method did not return a reference");
3376 return SvREFCNT_inc(SvRV(res));
3384 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3389 PERL_ARGS_ASSERT_GV_NAME_SET;
3392 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3394 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3395 unshare_hek(GvNAME_HEK(gv));
3398 PERL_HASH(hash, name, len);
3399 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3403 =for apidoc gv_try_downgrade
3405 If the typeglob C<gv> can be expressed more succinctly, by having
3406 something other than a real GV in its place in the stash, replace it
3407 with the optimised form. Basic requirements for this are that C<gv>
3408 is a real typeglob, is sufficiently ordinary, and is only referenced
3409 from its package. This function is meant to be used when a GV has been
3410 looked up in part to see what was there, causing upgrading, but based
3411 on what was found it turns out that the real GV isn't required after all.
3413 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3415 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3416 sub, the typeglob is replaced with a scalar-reference placeholder that
3417 more compactly represents the same thing.
3423 Perl_gv_try_downgrade(pTHX_ GV *gv)
3429 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3431 /* XXX Why and where does this leave dangling pointers during global
3433 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3435 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3436 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3437 isGV_with_GP(gv) && GvGP(gv) &&
3438 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3439 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3440 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3442 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3444 if (SvMAGICAL(gv)) {
3446 /* only backref magic is allowed */
3447 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3449 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3450 if (mg->mg_type != PERL_MAGIC_backref)
3456 HEK *gvnhek = GvNAME_HEK(gv);
3457 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3458 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3459 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3460 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3461 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3462 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3463 (namehek = GvNAME_HEK(gv)) &&
3464 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3466 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3467 const bool imported = !!GvIMPORTED_CV(gv);
3471 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3472 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3473 STRUCT_OFFSET(XPVIV, xiv_iv));
3474 SvRV_set(gv, value);
3479 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3481 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3483 PERL_ARGS_ASSERT_GV_OVERRIDE;
3484 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3485 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3486 gv = gvp ? *gvp : NULL;
3487 if (gv && !isGV(gv)) {
3488 if (!SvPCS_IMPORTED(gv)) return NULL;
3489 gv_init(gv, PL_globalstash, name, len, 0);
3492 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3498 core_xsub(pTHX_ CV* cv)
3501 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3507 * c-indentation-style: bsd
3509 * indent-tabs-mode: nil
3512 * ex: set ts=8 sts=4 sw=4 et: