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.
42 static const char S_autoload[] = "AUTOLOAD";
43 static const STRLEN S_autolen = sizeof(S_autoload)-1;
46 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
53 SvTYPE((const SV *)gv) != SVt_PVGV
54 && SvTYPE((const SV *)gv) != SVt_PVLV
58 if (type == SVt_PVIO) {
60 * if it walks like a dirhandle, then let's assume that
61 * this is a dirhandle.
63 what = OP_IS_DIRHOP(PL_op->op_type) ?
64 "dirhandle" : "filehandle";
65 } else if (type == SVt_PVHV) {
68 what = type == SVt_PVAV ? "array" : "scalar";
70 /* diag_listed_as: Bad symbol for filehandle */
71 Perl_croak(aTHX_ "Bad symbol for %s", what);
74 if (type == SVt_PVHV) {
75 where = (SV **)&GvHV(gv);
76 } else if (type == SVt_PVAV) {
77 where = (SV **)&GvAV(gv);
78 } else if (type == SVt_PVIO) {
79 where = (SV **)&GvIOp(gv);
86 *where = newSV_type(type);
87 if (type == SVt_PVAV && GvNAMELEN(gv) == 3
88 && strnEQ(GvNAME(gv), "ISA", 3))
89 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
95 Perl_gv_fetchfile(pTHX_ const char *name)
97 PERL_ARGS_ASSERT_GV_FETCHFILE;
98 return gv_fetchfile_flags(name, strlen(name), 0);
102 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
108 const STRLEN tmplen = namelen + 2;
111 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
112 PERL_UNUSED_ARG(flags);
117 if (tmplen <= sizeof smallbuf)
120 Newx(tmpbuf, tmplen, char);
121 /* This is where the debugger's %{"::_<$filename"} hash is created */
124 memcpy(tmpbuf + 2, name, namelen);
125 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
127 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
128 #ifdef PERL_DONT_CREATE_GVSV
129 GvSV(gv) = newSVpvn(name, namelen);
131 sv_setpvn(GvSV(gv), name, namelen);
134 if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
135 hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
136 if (tmpbuf != smallbuf)
142 =for apidoc gv_const_sv
144 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
145 inlining, or C<gv> is a placeholder reference that would be promoted to such
146 a typeglob, then returns the value returned by the sub. Otherwise, returns
153 Perl_gv_const_sv(pTHX_ GV *gv)
155 PERL_ARGS_ASSERT_GV_CONST_SV;
157 if (SvTYPE(gv) == SVt_PVGV)
158 return cv_const_sv(GvCVu(gv));
159 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
163 Perl_newGP(pTHX_ GV *const gv)
174 PERL_ARGS_ASSERT_NEWGP;
176 gp->gp_egv = gv; /* allow compiler to reuse gv after this */
177 #ifndef PERL_DONT_CREATE_GVSV
178 gp->gp_sv = newSV(0);
181 /* PL_curcop may be null here. E.g.,
182 INIT { bless {} and exit }
183 frees INIT before looking up DESTROY (and creating *DESTROY)
186 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
188 if (CopFILE(PL_curcop)) {
189 file = CopFILE(PL_curcop);
193 filegv = CopFILEGV(PL_curcop);
195 file = GvNAME(filegv)+2;
196 len = GvNAMELEN(filegv)-2;
207 PERL_HASH(hash, file, len);
208 gp->gp_file_hek = share_hek(file, len, hash);
214 /* Assign CvGV(cv) = gv, handling weak references.
215 * See also S_anonymise_cv_maybe */
218 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
220 GV * const oldgv = CvGV(cv);
222 PERL_ARGS_ASSERT_CVGV_SET;
229 SvREFCNT_dec_NN(oldgv);
233 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
236 else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
238 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
239 assert(!CvCVGV_RC(cv));
244 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
245 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
248 SvREFCNT_inc_simple_void_NN(gv);
252 /* Assign CvSTASH(cv) = st, handling weak references. */
255 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
257 HV *oldst = CvSTASH(cv);
258 PERL_ARGS_ASSERT_CVSTASH_SET;
262 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
263 SvANY(cv)->xcv_stash = st;
265 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
269 =for apidoc gv_init_pvn
271 Converts a scalar into a typeglob. This is an incoercible typeglob;
272 assigning a reference to it will assign to one of its slots, instead of
273 overwriting it as happens with typeglobs created by SvSetSV. Converting
274 any scalar that is SvOK() may produce unpredictable results and is reserved
275 for perl's internal use.
277 C<gv> is the scalar to be converted.
279 C<stash> is the parent stash/package, if any.
281 C<name> and C<len> give the name. The name must be unqualified;
282 that is, it must not include the package name. If C<gv> is a
283 stash element, it is the caller's responsibility to ensure that the name
284 passed to this function matches the name of the element. If it does not
285 match, perl's internal bookkeeping will get out of sync.
287 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
288 the return value of SvUTF8(sv). It can also take the
289 GV_ADDMULTI flag, which means to pretend that the GV has been
290 seen before (i.e., suppress "Used once" warnings).
294 The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
295 has no flags parameter. If the C<multi> parameter is set, the
296 GV_ADDMULTI flag will be passed to gv_init_pvn().
298 =for apidoc gv_init_pv
300 Same as gv_init_pvn(), but takes a nul-terminated string for the name
301 instead of separate char * and length parameters.
303 =for apidoc gv_init_sv
305 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
306 char * and length parameters. C<flags> is currently unused.
312 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
316 PERL_ARGS_ASSERT_GV_INIT_SV;
317 namepv = SvPV(namesv, namelen);
320 gv_init_pvn(gv, stash, namepv, namelen, flags);
324 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
326 PERL_ARGS_ASSERT_GV_INIT_PV;
327 gv_init_pvn(gv, stash, name, strlen(name), flags);
331 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
334 const U32 old_type = SvTYPE(gv);
335 const bool doproto = old_type > SVt_NULL;
336 char * const proto = (doproto && SvPOK(gv))
337 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
339 const STRLEN protolen = proto ? SvCUR(gv) : 0;
340 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
341 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
342 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
344 PERL_ARGS_ASSERT_GV_INIT_PVN;
345 assert (!(proto && has_constant));
348 /* The constant has to be a simple scalar type. */
349 switch (SvTYPE(has_constant)) {
354 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
355 sv_reftype(has_constant, 0));
364 if (old_type < SVt_PVGV) {
365 if (old_type >= SVt_PV)
367 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
375 Safefree(SvPVX_mutable(gv));
380 GvGP_set(gv, Perl_newGP(aTHX_ gv));
383 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
384 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
385 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
386 GvMULTI_on(gv); /* _was_ mentioned */
390 /* newCONSTSUB takes ownership of the reference from us. */
391 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
392 /* In case op.c:S_process_special_blocks stole it: */
394 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
395 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
396 /* If this reference was a copy of another, then the subroutine
397 must have been "imported", by a Perl space assignment to a GV
398 from a reference to CV. */
399 if (exported_constant)
400 GvIMPORTED_CV_on(gv);
401 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
406 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
407 SV_HAS_TRAILING_NUL);
408 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
414 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
416 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
428 #ifdef PERL_DONT_CREATE_GVSV
436 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
437 If we just cast GvSVn(gv) to void, it ignores evaluating it for
444 static void core_xsub(pTHX_ CV* cv);
447 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
448 const char * const name, const STRLEN len)
450 const int code = keyword(name, len, 1);
451 static const char file[] = __FILE__;
452 CV *cv, *oldcompcv = NULL;
454 bool ampable = TRUE; /* &{}-able */
455 COP *oldcurcop = NULL;
456 yy_parser *oldparser = NULL;
457 I32 oldsavestack_ix = 0;
462 if (!code) return NULL; /* Not a keyword */
463 switch (code < 0 ? -code : code) {
464 /* no support for \&CORE::infix;
465 no support for funcs that do not parse like funcs */
466 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
467 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
468 case KEY_default : case KEY_DESTROY:
469 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
470 case KEY_END : case KEY_eq : case KEY_eval :
471 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
472 case KEY_given : case KEY_goto : case KEY_grep :
473 case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
474 case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
475 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
476 case KEY_package: case KEY_print: case KEY_printf:
477 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
478 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
479 case KEY_s : case KEY_say : case KEY_sort :
480 case KEY_state: case KEY_sub :
481 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
482 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
483 case KEY_x : case KEY_xor : case KEY_y :
486 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
487 case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
493 case KEY_splice: case KEY_split:
496 case KEY_truncate: case KEY_unlink:
503 gv_init(gv, stash, name, len, TRUE);
508 oldcurcop = PL_curcop;
509 oldparser = PL_parser;
510 lex_start(NULL, NULL, 0);
511 oldcompcv = PL_compcv;
512 PL_compcv = NULL; /* Prevent start_subparse from setting
514 oldsavestack_ix = start_subparse(FALSE,0);
518 /* Avoid calling newXS, as it calls us, and things start to
520 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
524 CvXSUB(cv) = core_xsub;
526 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
528 (void)gv_fetchfile(file);
529 CvFILE(cv) = (char *)file;
530 /* XXX This is inefficient, as doing things this order causes
531 a prototype check in newATTRSUB. But we have to do
532 it this order as we need an op number before calling
534 (void)core_prototype((SV *)cv, name, code, &opnum);
536 (void)hv_store(stash,name,len,(SV *)gv,0);
542 /* newATTRSUB will free the CV and return NULL if we're still
543 compiling after a syntax error */
544 if ((cv = newATTRSUB_x(
545 oldsavestack_ix, (OP *)gv,
550 : newSVpvn(name,len),
555 assert(GvCV(gv) == orig_cv);
556 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
557 && opnum != OP_UNDEF)
558 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
561 PL_parser = oldparser;
562 PL_curcop = oldcurcop;
563 PL_compcv = oldcompcv;
566 SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
568 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
570 SvREFCNT_dec(opnumsv);
577 =for apidoc gv_fetchmeth
579 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
581 =for apidoc gv_fetchmeth_sv
583 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
584 of an SV instead of a string/length pair.
590 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
594 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
595 namepv = SvPV(namesv, namelen);
598 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
602 =for apidoc gv_fetchmeth_pv
604 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
605 instead of a string/length pair.
611 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
613 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
614 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
618 =for apidoc gv_fetchmeth_pvn
620 Returns the glob with the given C<name> and a defined subroutine or
621 C<NULL>. The glob lives in the given C<stash>, or in the stashes
622 accessible via @ISA and UNIVERSAL::.
624 The argument C<level> should be either 0 or -1. If C<level==0>, as a
625 side-effect creates a glob with the given C<name> in the given C<stash>
626 which in the case of success contains an alias for the subroutine, and sets
627 up caching info for this glob.
629 The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
631 GV_SUPER indicates that we want to look up the method in the superclasses
635 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
636 visible to Perl code. So when calling C<call_sv>, you should not use
637 the GV directly; instead, you should use the method's CV, which can be
638 obtained from the GV with the C<GvCV> macro.
643 /* NOTE: No support for tied ISA */
646 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)
953 const char *nsplit = NULL;
956 const char * const origname = name;
957 SV *const error_report = MUTABLE_SV(stash);
958 const U32 autoload = flags & GV_AUTOLOAD;
959 const U32 do_croak = flags & GV_CROAK;
960 const U32 is_utf8 = flags & SVf_UTF8;
962 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
964 if (SvTYPE(stash) < SVt_PVHV)
967 /* The only way stash can become NULL later on is if nsplit is set,
968 which in turn means that there is no need for a SVt_PVHV case
969 the error reporting code. */
972 for (nend = name; *nend || nend != (origname + len); nend++) {
977 else if (*nend == ':' && *(nend + 1) == ':') {
983 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
984 /* ->SUPER::method should really be looked up in original stash */
985 stash = CopSTASH(PL_curcop);
987 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
988 origname, HvENAME_get(stash), name) );
990 else if ((nsplit - origname) >= 7 &&
991 strnEQ(nsplit - 7, "::SUPER", 7)) {
992 /* don't autovifify if ->NoSuchStash::SUPER::method */
993 stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
994 if (stash) flags |= GV_SUPER;
997 /* don't autovifify if ->NoSuchStash::method */
998 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1003 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1005 if (strEQ(name,"import") || strEQ(name,"unimport"))
1006 gv = MUTABLE_GV(&PL_sv_yes);
1008 gv = gv_autoload_pvn(
1009 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1011 if (!gv && do_croak) {
1012 /* Right now this is exclusively for the benefit of S_method_common
1015 /* If we can't find an IO::File method, it might be a call on
1016 * a filehandle. If IO:File has not been loaded, try to
1017 * require it first instead of croaking */
1018 const char *stash_name = HvNAME_get(stash);
1019 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1020 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1021 STR_WITH_LEN("IO/File.pm"), 0,
1022 HV_FETCH_ISEXISTS, NULL, 0)
1024 require_pv("IO/File.pm");
1025 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1030 "Can't locate object method \"%"UTF8f
1031 "\" via package \"%"HEKf"\"",
1032 UTF8fARG(is_utf8, nend - name, name),
1033 HEKfARG(HvNAME_HEK(stash)));
1039 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1040 SVs_TEMP | is_utf8);
1042 packnamesv = error_report;
1046 "Can't locate object method \"%"UTF8f
1047 "\" via package \"%"SVf"\""
1048 " (perhaps you forgot to load \"%"SVf"\"?)",
1049 UTF8fARG(is_utf8, nend - name, name),
1050 SVfARG(packnamesv), SVfARG(packnamesv));
1054 else if (autoload) {
1055 CV* const cv = GvCV(gv);
1056 if (!CvROOT(cv) && !CvXSUB(cv)) {
1060 if (CvANON(cv) || !CvGV(cv))
1064 if (GvCV(stubgv) != cv) /* orphaned import */
1067 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1068 GvNAME(stubgv), GvNAMELEN(stubgv),
1069 GV_AUTOLOAD_ISMETHOD
1070 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1080 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1084 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1085 namepv = SvPV(namesv, namelen);
1088 return gv_autoload_pvn(stash, namepv, namelen, flags);
1092 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1094 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1095 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1099 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1107 SV *packname = NULL;
1108 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1110 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1112 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1115 if (SvTYPE(stash) < SVt_PVHV) {
1116 STRLEN packname_len = 0;
1117 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1118 packname = newSVpvn_flags(packname_ptr, packname_len,
1119 SVs_TEMP | SvUTF8(stash));
1123 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1124 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1126 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1127 is_utf8 | (flags & GV_SUPER))))
1131 if (!(CvROOT(cv) || CvXSUB(cv)))
1135 * Inheriting AUTOLOAD for non-methods works ... for now.
1138 !(flags & GV_AUTOLOAD_ISMETHOD)
1139 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1141 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1142 "Use of inherited AUTOLOAD for non-method %"SVf
1143 "::%"UTF8f"() is deprecated",
1145 UTF8fARG(is_utf8, len, name));
1148 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1149 * and split that value on the last '::', pass along the same data
1150 * via the SvPVX field in the CV, and the stash in CvSTASH.
1152 * Due to an unfortunate accident of history, the SvPVX field
1153 * serves two purposes. It is also used for the subroutine's pro-
1154 * type. Since SvPVX has been documented as returning the sub name
1155 * for a long time, but not as returning the prototype, we have
1156 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1159 * We put the prototype in the same allocated buffer, but after
1160 * the sub name. The SvPOK flag indicates the presence of a proto-
1161 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1162 * If both flags are on, then SvLEN is used to indicate the end of
1163 * the prototype (artificially lower than what is actually allo-
1164 * cated), at the risk of having to reallocate a few bytes unneces-
1165 * sarily--but that should happen very rarely, if ever.
1167 * We use SvUTF8 for both prototypes and sub names, so if one is
1168 * UTF8, the other must be upgraded.
1170 CvSTASH_set(cv, stash);
1171 if (SvPOK(cv)) { /* Ouch! */
1172 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1174 const char *proto = CvPROTO(cv);
1177 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1178 ulen = SvCUR(tmpsv);
1179 SvCUR(tmpsv)++; /* include null in string */
1181 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1183 SvTEMP_on(tmpsv); /* Allow theft */
1184 sv_setsv_nomg((SV *)cv, tmpsv);
1186 SvREFCNT_dec_NN(tmpsv);
1187 SvLEN(cv) = SvCUR(cv) + 1;
1191 sv_setpvn((SV *)cv, name, len);
1195 else SvUTF8_off(cv);
1201 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1202 * The subroutine's original name may not be "AUTOLOAD", so we don't
1203 * use that, but for lack of anything better we will use the sub's
1204 * original package to look up $AUTOLOAD.
1206 varstash = GvSTASH(CvGV(cv));
1207 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1211 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1212 #ifdef PERL_DONT_CREATE_GVSV
1213 GvSV(vargv) = newSV(0);
1217 varsv = GvSVn(vargv);
1218 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1219 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1220 sv_setsv(varsv, packname);
1221 sv_catpvs(varsv, "::");
1222 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1223 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1226 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1234 /* require_tie_mod() internal routine for requiring a module
1235 * that implements the logic of automatic ties like %! and %-
1237 * The "gv" parameter should be the glob.
1238 * "varpv" holds the name of the var, used for error messages.
1239 * "namesv" holds the module name. Its refcount will be decremented.
1240 * "methpv" holds the method name to test for to check that things
1241 * are working reasonably close to as expected.
1242 * "flags": if flag & 1 then save the scalar before loading.
1243 * For the protection of $! to work (it is set by this routine)
1244 * the sv slot must already be magicalized.
1247 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1250 HV* stash = gv_stashsv(namesv, 0);
1252 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1254 if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1255 SV *module = newSVsv(namesv);
1256 char varname = *varpv; /* varpv might be clobbered by load_module,
1257 so save it. For the moment it's always
1259 const char type = varname == '[' ? '$' : '%';
1267 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1268 assert(sp == PL_stack_sp);
1269 stash = gv_stashsv(namesv, 0);
1271 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1272 type, varname, SVfARG(namesv));
1273 else if (!gv_fetchmethod(stash, methpv))
1274 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1275 type, varname, SVfARG(namesv), methpv);
1278 else SvREFCNT_dec_NN(namesv);
1283 =for apidoc gv_stashpv
1285 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1286 determine the length of C<name>, then calls C<gv_stashpvn()>.
1292 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1294 PERL_ARGS_ASSERT_GV_STASHPV;
1295 return gv_stashpvn(name, strlen(name), create);
1299 =for apidoc gv_stashpvn
1301 Returns a pointer to the stash for a specified package. The C<namelen>
1302 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1303 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1304 created if it does not already exist. If the package does not exist and
1305 C<flags> is 0 (or any other setting that does not create packages) then NULL
1308 Flags may be one of:
1317 The most important of which are probably GV_ADD and SVf_UTF8.
1323 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1329 U32 tmplen = namelen + 2;
1331 PERL_ARGS_ASSERT_GV_STASHPVN;
1333 if (tmplen <= sizeof smallbuf)
1336 Newx(tmpbuf, tmplen, char);
1337 Copy(name, tmpbuf, namelen, char);
1338 tmpbuf[namelen] = ':';
1339 tmpbuf[namelen+1] = ':';
1340 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1341 if (tmpbuf != smallbuf)
1345 stash = GvHV(tmpgv);
1346 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1348 if (!HvNAME_get(stash)) {
1349 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1351 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1352 /* If the containing stash has multiple effective
1353 names, see that this one gets them, too. */
1354 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1355 mro_package_moved(stash, NULL, tmpgv, 1);
1361 =for apidoc gv_stashsv
1363 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
1369 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1372 const char * const ptr = SvPV_const(sv,len);
1374 PERL_ARGS_ASSERT_GV_STASHSV;
1376 return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1381 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1382 PERL_ARGS_ASSERT_GV_FETCHPV;
1383 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1387 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1389 const char * const nambeg =
1390 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1391 PERL_ARGS_ASSERT_GV_FETCHSV;
1392 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1395 PERL_STATIC_INLINE void
1396 S_gv_magicalize_isa(pTHX_ GV *gv)
1400 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1404 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1408 /* This function grabs name and tries to split a stash and glob
1409 * from its contents. TODO better description, comments
1411 * If the function returns TRUE and 'name == name_end', then
1412 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1414 PERL_STATIC_INLINE bool
1415 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1416 STRLEN *len, const char *nambeg, STRLEN full_len,
1417 const U32 is_utf8, const I32 add)
1419 const char *name_cursor;
1420 const char *const name_end = nambeg + full_len;
1421 const char *const name_em1 = name_end - 1;
1423 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1425 if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
1426 /* accidental stringify on a GV? */
1430 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1431 if (name_cursor < name_em1 &&
1432 ((*name_cursor == ':' && name_cursor[1] == ':')
1433 || *name_cursor == '\''))
1436 *stash = PL_defstash;
1437 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1440 *len = name_cursor - *name;
1441 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1444 if (*name_cursor == ':') {
1450 Newx(tmpbuf, *len+2, char);
1451 Copy(*name, tmpbuf, *len, char);
1452 tmpbuf[(*len)++] = ':';
1453 tmpbuf[(*len)++] = ':';
1456 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1457 *gv = gvp ? *gvp : NULL;
1458 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1459 if (SvTYPE(*gv) != SVt_PVGV)
1460 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1466 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1469 if (!(*stash = GvHV(*gv))) {
1470 *stash = GvHV(*gv) = newHV();
1471 if (!HvNAME_get(*stash)) {
1472 if (GvSTASH(*gv) == PL_defstash && *len == 6
1473 && strnEQ(*name, "CORE", 4))
1474 hv_name_set(*stash, "CORE", 4, 0);
1477 *stash, nambeg, name_cursor-nambeg, is_utf8
1479 /* If the containing stash has multiple effective
1480 names, see that this one gets them, too. */
1481 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1482 mro_package_moved(*stash, NULL, *gv, 1);
1485 else if (!HvNAME_get(*stash))
1486 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1489 if (*name_cursor == ':')
1491 *name = name_cursor+1;
1492 if (*name == name_end) {
1494 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1499 *len = name_cursor - *name;
1503 /* Checks if an unqualified name is in the main stash */
1504 PERL_STATIC_INLINE bool
1505 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1507 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1509 /* If it's an alphanumeric variable */
1510 if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
1511 /* Some "normal" variables are always in main::,
1512 * like INC or STDOUT.
1520 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1521 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1522 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1526 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1531 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1532 && name[3] == 'I' && name[4] == 'N')
1536 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1537 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1538 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1542 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1543 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1549 /* *{""}, or a special variable like $@ */
1557 /* This function is called if parse_gv_stash_name() failed to
1558 * find a stash, or if GV_NOTQUAL or an empty name was passed
1559 * to gv_fetchpvn_flags.
1561 * It returns FALSE if the default stash can't be found nor created,
1562 * which might happen during global destruction.
1564 PERL_STATIC_INLINE bool
1565 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1566 const U32 is_utf8, const I32 add,
1567 const svtype sv_type)
1569 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1571 /* No stash in name, so see how we can default */
1573 if ( gv_is_in_main(name, len, is_utf8) ) {
1574 *stash = PL_defstash;
1577 if (IN_PERL_COMPILETIME) {
1578 *stash = PL_curstash;
1579 if (add && (PL_hints & HINT_STRICT_VARS) &&
1580 sv_type != SVt_PVCV &&
1581 sv_type != SVt_PVGV &&
1582 sv_type != SVt_PVFM &&
1583 sv_type != SVt_PVIO &&
1584 !(len == 1 && sv_type == SVt_PV &&
1585 (*name == 'a' || *name == 'b')) )
1587 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1588 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1589 SvTYPE(*gvp) != SVt_PVGV)
1593 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1594 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1595 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1597 /* diag_listed_as: Variable "%s" is not imported%s */
1599 aTHX_ packWARN(WARN_MISC),
1600 "Variable \"%c%"UTF8f"\" is not imported",
1601 sv_type == SVt_PVAV ? '@' :
1602 sv_type == SVt_PVHV ? '%' : '$',
1603 UTF8fARG(is_utf8, len, name));
1606 aTHX_ packWARN(WARN_MISC),
1607 "\t(Did you mean &%"UTF8f" instead?)\n",
1608 UTF8fARG(is_utf8, len, name)
1615 /* Use the current op's stash */
1616 *stash = CopSTASH(PL_curcop);
1621 if (add && !PL_in_clean_all) {
1622 SV * const err = Perl_mess(aTHX_
1623 "Global symbol \"%s%"UTF8f
1624 "\" requires explicit package name",
1625 (sv_type == SVt_PV ? "$"
1626 : sv_type == SVt_PVAV ? "@"
1627 : sv_type == SVt_PVHV ? "%"
1628 : ""), UTF8fARG(is_utf8, len, name));
1633 /* To maintain the output of errors after the strict exception
1634 * above, and to keep compat with older releases, rather than
1635 * placing the variables in the pad, we place
1636 * them in the <none>:: stash.
1638 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1640 /* symbol table under destruction */
1649 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1655 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1657 * Note that it does not insert the GV into the stash prior to
1658 * magicalization, which some variables require need in order
1659 * to work (like $[, %+, %-, %!), so callers must take care of
1662 * The return value has a specific meaning for gv_fetchpvn_flags:
1663 * If it returns true, and the gv is empty, it indicates that its
1664 * refcount should be decreased.
1666 PERL_STATIC_INLINE bool
1667 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1668 bool addmg, const svtype sv_type)
1672 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1674 if (stash != PL_defstash) { /* not the main stash */
1675 /* We only have to check for a few names here: a, b, EXPORT, ISA
1676 and VERSION. All the others apply only to the main stash or to
1677 CORE (which is checked right after this). */
1679 const char * const name2 = name + 1;
1682 if (strnEQ(name2, "XPORT", 5))
1686 if (strEQ(name2, "SA"))
1687 gv_magicalize_isa(gv);
1690 if (strEQ(name2, "ERSION"))
1695 if (len == 1 && sv_type == SVt_PV)
1704 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1705 /* Avoid null warning: */
1706 const char * const stashname = HvNAME(stash); assert(stashname);
1707 if (strnEQ(stashname, "CORE", 4))
1708 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1715 /* Nothing else to do.
1716 The compiler will probably turn the switch statement into a
1717 branch table. Make sure we avoid even that small overhead for
1718 the common case of lower case variable names. (On EBCDIC
1719 platforms, we can't just do:
1720 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1721 because cases like '\027' in the switch statement below are
1722 C1 (non-ASCII) controls on those platforms, so the remapping
1723 would make them larger than 'V')
1728 const char * const name2 = name + 1;
1731 if (strEQ(name2, "RGV")) {
1732 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1734 else if (strEQ(name2, "RGVOUT")) {
1739 if (strnEQ(name2, "XPORT", 5))
1743 if (strEQ(name2, "SA")) {
1744 gv_magicalize_isa(gv);
1748 if (strEQ(name2, "IG")) {
1751 if (!PL_psig_name) {
1752 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1753 Newxz(PL_psig_pend, SIG_SIZE, int);
1754 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1756 /* I think that the only way to get here is to re-use an
1757 embedded perl interpreter, where the previous
1758 use didn't clean up fully because
1759 PL_perl_destruct_level was 0. I'm not sure that we
1760 "support" that, in that I suspect in that scenario
1761 there are sufficient other garbage values left in the
1762 interpreter structure that something else will crash
1763 before we get here. I suspect that this is one of
1764 those "doctor, it hurts when I do this" bugs. */
1765 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1766 Zero(PL_psig_pend, SIG_SIZE, int);
1770 hv_magic(hv, NULL, PERL_MAGIC_sig);
1771 for (i = 1; i < SIG_SIZE; i++) {
1772 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1774 sv_setsv(*init, &PL_sv_undef);
1779 if (strEQ(name2, "ERSION"))
1782 case '\003': /* $^CHILD_ERROR_NATIVE */
1783 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1786 case '\005': /* $^ENCODING */
1787 if (strEQ(name2, "NCODING"))
1790 case '\007': /* $^GLOBAL_PHASE */
1791 if (strEQ(name2, "LOBAL_PHASE"))
1794 case '\014': /* $^LAST_FH */
1795 if (strEQ(name2, "AST_FH"))
1798 case '\015': /* $^MATCH */
1799 if (strEQ(name2, "ATCH")) {
1800 paren = RX_BUFF_IDX_CARET_FULLMATCH;
1804 case '\017': /* $^OPEN */
1805 if (strEQ(name2, "PEN"))
1808 case '\020': /* $^PREMATCH $^POSTMATCH */
1809 if (strEQ(name2, "REMATCH")) {
1810 paren = RX_BUFF_IDX_CARET_PREMATCH;
1813 if (strEQ(name2, "OSTMATCH")) {
1814 paren = RX_BUFF_IDX_CARET_POSTMATCH;
1818 case '\024': /* ${^TAINT} */
1819 if (strEQ(name2, "AINT"))
1822 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1823 if (strEQ(name2, "NICODE"))
1825 if (strEQ(name2, "TF8LOCALE"))
1827 if (strEQ(name2, "TF8CACHE"))
1830 case '\027': /* $^WARNING_BITS */
1831 if (strEQ(name2, "ARNING_BITS"))
1844 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1846 /* This snippet is taken from is_gv_magical */
1847 const char *end = name + len;
1848 while (--end > name) {
1852 paren = strtoul(name, NULL, 10);
1858 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1859 be case '\0' in this switch statement (ie a default case) */
1862 paren = RX_BUFF_IDX_FULLMATCH;
1865 paren = RX_BUFF_IDX_PREMATCH;
1868 paren = RX_BUFF_IDX_POSTMATCH;
1870 #ifdef PERL_SAWAMPERSAND
1872 sv_type == SVt_PVAV ||
1873 sv_type == SVt_PVHV ||
1874 sv_type == SVt_PVCV ||
1875 sv_type == SVt_PVFM ||
1877 )) { PL_sawampersand |=
1881 ? SAWAMPERSAND_MIDDLE
1882 : SAWAMPERSAND_RIGHT;
1895 paren = *name - '0';
1898 /* Flag the capture variables with a NULL mg_ptr
1899 Use mg_len for the array index to lookup. */
1900 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
1904 sv_setpv(GvSVn(gv),PL_chopset);
1908 #ifdef COMPLEX_STATUS
1909 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1915 /* If %! has been used, automatically load Errno.pm. */
1917 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1919 /* magicalization must be done before require_tie_mod is called */
1920 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1922 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1929 GvMULTI_on(gv); /* no used once warnings here */
1931 AV* const av = GvAVn(gv);
1932 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1934 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1935 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1937 SvREADONLY_on(GvSVn(gv));
1940 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1942 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1950 if (sv_type == SVt_PV)
1951 /* diag_listed_as: $* is no longer supported */
1952 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1953 "$%c is no longer supported", *name);
1955 case '\010': /* $^H */
1957 HV *const hv = GvHVn(gv);
1958 hv_magic(hv, NULL, PERL_MAGIC_hints);
1962 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1963 && FEATURE_ARYBASE_IS_ENABLED) {
1964 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1967 else goto magicalize;
1969 case '\023': /* $^S */
1971 SvREADONLY_on(GvSVn(gv));
1987 case '\001': /* $^A */
1988 case '\003': /* $^C */
1989 case '\004': /* $^D */
1990 case '\005': /* $^E */
1991 case '\006': /* $^F */
1992 case '\011': /* $^I, NOT \t in EBCDIC */
1993 case '\016': /* $^N */
1994 case '\017': /* $^O */
1995 case '\020': /* $^P */
1996 case '\024': /* $^T */
1997 case '\027': /* $^W */
1999 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2002 case '\014': /* $^L */
2003 sv_setpvs(GvSVn(gv),"\f");
2006 sv_setpvs(GvSVn(gv),"\034");
2010 SV * const sv = GvSV(gv);
2011 if (!sv_derived_from(PL_patchlevel, "version"))
2012 upg_version(PL_patchlevel, TRUE);
2013 GvSV(gv) = vnumify(PL_patchlevel);
2014 SvREADONLY_on(GvSV(gv));
2018 case '\026': /* $^V */
2020 SV * const sv = GvSV(gv);
2021 GvSV(gv) = new_version(PL_patchlevel);
2022 SvREADONLY_on(GvSV(gv));
2028 if (sv_type == SVt_PV)
2036 /* This function is called when the stash already holds the GV of the magic
2037 * variable we're looking for, but we need to check that it has the correct
2038 * kind of magic. For example, if someone first uses $! and then %!, the
2039 * latter would end up here, and we add the Errno tie to the HASH slot of
2042 PERL_STATIC_INLINE void
2043 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2045 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2047 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2049 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2050 else if (*name == '-' || *name == '+')
2051 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2052 } else if (sv_type == SVt_PV) {
2053 if (*name == '*' || *name == '#') {
2054 /* diag_listed_as: $* is no longer supported */
2055 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2057 "$%c is no longer supported", *name);
2060 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2063 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2065 #ifdef PERL_SAWAMPERSAND
2067 PL_sawampersand |= SAWAMPERSAND_LEFT;
2071 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2075 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2084 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2085 const svtype sv_type)
2088 const char *name = nambeg;
2093 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2094 const I32 no_expand = flags & GV_NOEXPAND;
2095 const I32 add = flags & ~GV_NOADD_MASK;
2096 const U32 is_utf8 = flags & SVf_UTF8;
2097 bool addmg = cBOOL(flags & GV_ADDMG);
2098 const char *const name_end = nambeg + full_len;
2101 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2103 /* If we have GV_NOTQUAL, the caller promised that
2104 * there is no stash, so we can skip the check.
2105 * Similarly if full_len is 0, since then we're
2106 * dealing with something like *{""} or ""->foo()
2108 if ((flags & GV_NOTQUAL) || !full_len) {
2111 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2112 if (name == name_end) return gv;
2118 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2122 /* By this point we should have a stash and a name */
2123 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2124 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2125 if (addmg) gv = (GV *)newSV(0);
2128 else gv = *gvp, addmg = 0;
2129 /* From this point on, addmg means gv has not been inserted in the
2132 if (SvTYPE(gv) == SVt_PVGV) {
2133 /* The GV already exists, so return it, but check if we need to do
2134 * anything else with it before that.
2137 /* This is the heuristic that handles if a variable triggers the
2138 * 'used only once' warning. If there's already a GV in the stash
2139 * with this name, then we assume that the variable has been used
2140 * before and turn its MULTI flag on.
2141 * It's a heuristic because it can easily be "tricked", like with
2142 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2143 * not warning about $main::foo being used just once
2146 gv_init_svtype(gv, sv_type);
2147 /* You reach this path once the typeglob has already been created,
2148 either by the same or a different sigil. If this path didn't
2149 exist, then (say) referencing $! first, and %! second would
2150 mean that %! was not handled correctly. */
2151 if (len == 1 && stash == PL_defstash) {
2152 maybe_multimagic_gv(gv, name, sv_type);
2154 else if (len == 3 && sv_type == SVt_PVAV
2155 && strnEQ(name, "ISA", 3)
2156 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2157 gv_magicalize_isa(gv);
2160 } else if (no_init) {
2164 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2165 * don't expand it to a glob. This is an optimization so that things
2166 * copying constants over, like Exporter, don't have to be rewritten
2167 * to take into account that you can store more than just globs in
2170 else if (no_expand && SvROK(gv)) {
2175 /* Adding a new symbol.
2176 Unless of course there was already something non-GV here, in which case
2177 we want to behave as if there was always a GV here, containing some sort
2179 Otherwise we run the risk of creating things like GvIO, which can cause
2180 subtle bugs. eg the one that tripped up SQL::Translator */
2182 faking_it = SvOK(gv);
2184 if (add & GV_ADDWARN)
2185 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2186 "Had to create %"UTF8f" unexpectedly",
2187 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2188 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2190 if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
2193 /* First, store the gv in the symtab if we're adding magic,
2194 * but only for non-empty GVs
2196 #define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
2197 || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
2199 if ( addmg && !GvEMPTY(gv) ) {
2200 (void)hv_store(stash,name,len,(SV *)gv,0);
2203 /* set up magic where warranted */
2204 if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
2207 if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
2208 /* The GV was and still is "empty", except that now
2209 * it has the magic flags turned on, so we want it
2210 * stored in the symtab.
2212 (void)hv_store(stash,name,len,(SV *)gv,0);
2215 /* Most likely the temporary GV created above */
2216 SvREFCNT_dec_NN(gv);
2222 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2227 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2230 const HV * const hv = GvSTASH(gv);
2232 PERL_ARGS_ASSERT_GV_FULLNAME4;
2234 sv_setpv(sv, prefix ? prefix : "");
2236 if (hv && (name = HvNAME(hv))) {
2237 const STRLEN len = HvNAMELEN(hv);
2238 if (keepmain || strnNE(name, "main", len)) {
2239 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2243 else sv_catpvs(sv,"__ANON__::");
2244 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2248 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2250 const GV * const egv = GvEGVx(gv);
2252 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2254 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2258 /* recursively scan a stash and any nested stashes looking for entries
2259 * that need the "only used once" warning raised
2263 Perl_gv_check(pTHX_ HV *stash)
2268 PERL_ARGS_ASSERT_GV_CHECK;
2270 if (!HvARRAY(stash))
2273 assert(SvOOK(stash));
2275 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2277 /* mark stash is being scanned, to avoid recursing */
2278 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2279 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2282 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2283 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2285 if (hv != PL_defstash && hv != stash
2287 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2289 gv_check(hv); /* nested package */
2291 else if ( *HeKEY(entry) != '_'
2292 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2294 gv = MUTABLE_GV(HeVAL(entry));
2295 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2298 CopLINE_set(PL_curcop, GvLINE(gv));
2300 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2302 CopFILEGV(PL_curcop)
2303 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2305 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2306 "Name \"%"HEKf"::%"HEKf
2307 "\" used only once: possible typo",
2308 HEKfARG(HvNAME_HEK(stash)),
2309 HEKfARG(GvNAME_HEK(gv)));
2312 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2317 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2320 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2321 assert(!(flags & ~SVf_UTF8));
2323 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2324 UTF8fARG(flags, strlen(pack), pack),
2329 /* hopefully this is only called on local symbol table entries */
2332 Perl_gp_ref(pTHX_ GP *gp)
2340 /* If the GP they asked for a reference to contains
2341 a method cache entry, clear it first, so that we
2342 don't infect them with our cached entry */
2343 SvREFCNT_dec_NN(gp->gp_cv);
2352 Perl_gp_free(pTHX_ GV *gv)
2358 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2360 if (gp->gp_refcnt == 0) {
2361 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2362 "Attempt to free unreferenced glob pointers"
2363 pTHX__FORMAT pTHX__VALUE);
2366 if (gp->gp_refcnt > 1) {
2368 if (gp->gp_egv == gv)
2376 /* Copy and null out all the glob slots, so destructors do not see
2378 HEK * const file_hek = gp->gp_file_hek;
2379 SV * const sv = gp->gp_sv;
2380 AV * const av = gp->gp_av;
2381 HV * const hv = gp->gp_hv;
2382 IO * const io = gp->gp_io;
2383 CV * const cv = gp->gp_cv;
2384 CV * const form = gp->gp_form;
2386 gp->gp_file_hek = NULL;
2395 unshare_hek(file_hek);
2399 /* FIXME - another reference loop GV -> symtab -> GV ?
2400 Somehow gp->gp_hv can end up pointing at freed garbage. */
2401 if (hv && SvTYPE(hv) == SVt_PVHV) {
2402 const HEK *hvname_hek = HvNAME_HEK(hv);
2403 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2404 if (PL_stashcache && hvname_hek)
2405 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2412 /* Possibly reallocated by a destructor */
2415 if (!gp->gp_file_hek
2421 && !gp->gp_form) break;
2423 if (--attempts == 0) {
2425 "panic: gp_free failed to free glob pointer - "
2426 "something is repeatedly re-creating entries"
2431 /* Possibly incremented by a destructor doing glob assignment */
2432 if (gp->gp_refcnt > 1) goto borrowed;
2438 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2440 AMT * const amtp = (AMT*)mg->mg_ptr;
2441 PERL_UNUSED_ARG(sv);
2443 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2445 if (amtp && AMT_AMAGIC(amtp)) {
2447 for (i = 1; i < NofAMmeth; i++) {
2448 CV * const cv = amtp->table[i];
2450 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2451 amtp->table[i] = NULL;
2458 /* Updates and caches the CV's */
2460 * 1 on success and there is some overload
2461 * 0 if there is no overload
2462 * -1 if some error occurred and it couldn't croak
2466 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2469 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2471 const struct mro_meta* stash_meta = HvMROMETA(stash);
2474 PERL_ARGS_ASSERT_GV_AMUPDATE;
2476 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2478 const AMT * const amtp = (AMT*)mg->mg_ptr;
2479 if (amtp->was_ok_sub == newgen) {
2480 return AMT_AMAGIC(amtp) ? 1 : 0;
2482 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2485 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2488 amt.was_ok_sub = newgen;
2489 amt.fallback = AMGfallNO;
2495 bool deref_seen = 0;
2498 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2500 /* Try to find via inheritance. */
2501 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2502 SV * const sv = gv ? GvSV(gv) : NULL;
2507 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2510 #ifdef PERL_DONT_CREATE_GVSV
2512 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2515 else if (SvTRUE(sv))
2516 /* don't need to set overloading here because fallback => 1
2517 * is the default setting for classes without overloading */
2518 amt.fallback=AMGfallYES;
2519 else if (SvOK(sv)) {
2520 amt.fallback=AMGfallNEVER;
2527 assert(SvOOK(stash));
2528 /* initially assume the worst */
2529 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2531 for (i = 1; i < NofAMmeth; i++) {
2532 const char * const cooky = PL_AMG_names[i];
2533 /* Human-readable form, for debugging: */
2534 const char * const cp = AMG_id2name(i);
2535 const STRLEN l = PL_AMG_namelens[i];
2537 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2538 cp, HvNAME_get(stash)) );
2539 /* don't fill the cache while looking up!
2540 Creation of inheritance stubs in intermediate packages may
2541 conflict with the logic of runtime method substitution.
2542 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2543 then we could have created stubs for "(+0" in A and C too.
2544 But if B overloads "bool", we may want to use it for
2545 numifying instead of C's "+0". */
2546 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2548 if (gv && (cv = GvCV(gv))) {
2549 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2550 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2551 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2552 && strEQ(hvname, "overload")) {
2553 /* This is a hack to support autoloading..., while
2554 knowing *which* methods were declared as overloaded. */
2555 /* GvSV contains the name of the method. */
2557 SV *gvsv = GvSV(gv);
2559 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2560 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2561 (void*)GvSV(gv), cp, HvNAME(stash)) );
2562 if (!gvsv || !SvPOK(gvsv)
2563 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2565 /* Can be an import stub (created by "can"). */
2570 const SV * const name = (gvsv && SvPOK(gvsv))
2572 : newSVpvs_flags("???", SVs_TEMP);
2573 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2574 Perl_croak(aTHX_ "%s method \"%"SVf256
2575 "\" overloading \"%s\" "\
2576 "in package \"%"HEKf256"\"",
2577 (GvCVGEN(gv) ? "Stub found while resolving"
2585 cv = GvCV(gv = ngv);
2588 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2589 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2590 GvNAME(CvGV(cv))) );
2592 } else if (gv) { /* Autoloaded... */
2593 cv = MUTABLE_CV(gv);
2596 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2612 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2613 * NB - aux var invalid here, HvARRAY() could have been
2614 * reallocated since it was assigned to */
2615 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2618 AMT_AMAGIC_on(&amt);
2619 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2620 (char*)&amt, sizeof(AMT));
2624 /* Here we have no table: */
2626 AMT_AMAGIC_off(&amt);
2627 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2628 (char*)&amt, sizeof(AMTS));
2634 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2640 struct mro_meta* stash_meta;
2642 if (!stash || !HvNAME_get(stash))
2645 stash_meta = HvMROMETA(stash);
2646 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2648 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2651 if (Gv_AMupdate(stash, 0) == -1)
2653 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2656 amtp = (AMT*)mg->mg_ptr;
2657 if ( amtp->was_ok_sub != newgen )
2659 if (AMT_AMAGIC(amtp)) {
2660 CV * const ret = amtp->table[id];
2661 if (ret && isGV(ret)) { /* Autoloading stab */
2662 /* Passing it through may have resulted in a warning
2663 "Inherited AUTOLOAD for a non-method deprecated", since
2664 our caller is going through a function call, not a method call.
2665 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2666 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2678 /* Implement tryAMAGICun_MG macro.
2679 Do get magic, then see if the stack arg is overloaded and if so call it.
2681 AMGf_set return the arg using SETs rather than assigning to
2683 AMGf_numeric apply sv_2num to the stack arg.
2687 Perl_try_amagic_un(pTHX_ int method, int flags) {
2691 SV* const arg = TOPs;
2695 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2696 AMGf_noright | AMGf_unary))) {
2697 if (flags & AMGf_set) {
2702 if (SvPADMY(TARG)) {
2703 sv_setsv(TARG, tmpsv);
2713 if ((flags & AMGf_numeric) && SvROK(arg))
2719 /* Implement tryAMAGICbin_MG macro.
2720 Do get magic, then see if the two stack args are overloaded and if so
2723 AMGf_set return the arg using SETs rather than assigning to
2725 AMGf_assign op may be called as mutator (eg +=)
2726 AMGf_numeric apply sv_2num to the stack arg.
2730 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2733 SV* const left = TOPm1s;
2734 SV* const right = TOPs;
2740 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2741 SV * const tmpsv = amagic_call(left, right, method,
2742 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2744 if (flags & AMGf_set) {
2751 if (opASSIGN || SvPADMY(TARG)) {
2752 sv_setsv(TARG, tmpsv);
2762 if(left==right && SvGMAGICAL(left)) {
2763 SV * const left = sv_newmortal();
2765 /* Print the uninitialized warning now, so it includes the vari-
2768 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2769 sv_setsv_flags(left, &PL_sv_no, 0);
2771 else sv_setsv_flags(left, right, 0);
2774 if (flags & AMGf_numeric) {
2776 *(sp-1) = sv_2num(TOPm1s);
2778 *sp = sv_2num(right);
2784 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2788 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2792 /* return quickly if none of the deref ops are overloaded */
2793 stash = SvSTASH(SvRV(ref));
2794 assert(SvOOK(stash));
2795 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
2798 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
2799 AMGf_noright | AMGf_unary))) {
2801 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2802 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2803 /* Bail out if it returns us the same reference. */
2810 return tmpsv ? tmpsv : ref;
2814 Perl_amagic_is_enabled(pTHX_ int method)
2816 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2818 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2820 if ( !lex_mask || !SvOK(lex_mask) )
2821 /* overloading lexically disabled */
2823 else if ( lex_mask && SvPOK(lex_mask) ) {
2824 /* we have an entry in the hints hash, check if method has been
2825 * masked by overloading.pm */
2827 const int offset = method / 8;
2828 const int bit = method % 8;
2829 char *pv = SvPV(lex_mask, len);
2831 /* Bit set, so this overloading operator is disabled */
2832 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2839 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2844 CV **cvp=NULL, **ocvp=NULL;
2845 AMT *amtp=NULL, *oamtp=NULL;
2846 int off = 0, off1, lr = 0, notfound = 0;
2847 int postpr = 0, force_cpy = 0;
2848 int assign = AMGf_assign & flags;
2849 const int assignshift = assign ? 1 : 0;
2850 int use_default_op = 0;
2851 int force_scalar = 0;
2857 PERL_ARGS_ASSERT_AMAGIC_CALL;
2859 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2860 if (!amagic_is_enabled(method)) return NULL;
2863 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2864 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2865 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2866 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2867 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2869 && ((cv = cvp[off=method+assignshift])
2870 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2876 cv = cvp[off=method])))) {
2877 lr = -1; /* Call method for left argument */
2879 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2882 /* look for substituted methods */
2883 /* In all the covered cases we should be called with assign==0. */
2887 if ((cv = cvp[off=add_ass_amg])
2888 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2889 right = &PL_sv_yes; lr = -1; assign = 1;
2894 if ((cv = cvp[off = subtr_ass_amg])
2895 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2896 right = &PL_sv_yes; lr = -1; assign = 1;
2900 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2903 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2906 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2909 (void)((cv = cvp[off=bool__amg])
2910 || (cv = cvp[off=numer_amg])
2911 || (cv = cvp[off=string_amg]));
2918 * SV* ref causes confusion with the interpreter variable of
2921 SV* const tmpRef=SvRV(left);
2922 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2924 * Just to be extra cautious. Maybe in some
2925 * additional cases sv_setsv is safe, too.
2927 SV* const newref = newSVsv(tmpRef);
2928 SvOBJECT_on(newref);
2929 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2930 delegate to the stash. */
2931 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2937 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2938 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2939 SV* const nullsv=sv_2mortal(newSViv(0));
2941 SV* const lessp = amagic_call(left,nullsv,
2942 lt_amg,AMGf_noright);
2943 logic = SvTRUE(lessp);
2945 SV* const lessp = amagic_call(left,nullsv,
2946 ncmp_amg,AMGf_noright);
2947 logic = (SvNV(lessp) < 0);
2950 if (off==subtr_amg) {
2961 if ((cv = cvp[off=subtr_amg])) {
2963 left = sv_2mortal(newSViv(0));
2968 case iter_amg: /* XXXX Eventually should do to_gv. */
2969 case ftest_amg: /* XXXX Eventually should do to_gv. */
2972 return NULL; /* Delegate operation to standard mechanisms. */
2980 return left; /* Delegate operation to standard mechanisms. */
2985 if (!cv) goto not_found;
2986 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2987 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2988 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2989 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2990 ? (amtp = (AMT*)mg->mg_ptr)->table
2992 && (cv = cvp[off=method])) { /* Method for right
2995 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2996 || (ocvp && oamtp->fallback > AMGfallNEVER))
2997 && !(flags & AMGf_unary)) {
2998 /* We look for substitution for
2999 * comparison operations and
3001 if (method==concat_amg || method==concat_ass_amg
3002 || method==repeat_amg || method==repeat_ass_amg) {
3003 return NULL; /* Delegate operation to string conversion */
3025 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3029 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3039 not_found: /* No method found, either report or croak */
3047 return left; /* Delegate operation to standard mechanisms. */
3050 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3051 notfound = 1; lr = -1;
3052 } else if (cvp && (cv=cvp[nomethod_amg])) {
3053 notfound = 1; lr = 1;
3054 } else if ((use_default_op =
3055 (!ocvp || oamtp->fallback >= AMGfallYES)
3056 && (!cvp || amtp->fallback >= AMGfallYES))
3058 /* Skip generating the "no method found" message. */
3062 if (off==-1) off=method;
3063 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3064 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3065 AMG_id2name(method + assignshift),
3066 (flags & AMGf_unary ? " " : "\n\tleft "),
3068 "in overloaded package ":
3069 "has no overloaded magic",
3071 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3074 ",\n\tright argument in overloaded package ":
3077 : ",\n\tright argument has no overloaded magic"),
3079 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3080 SVfARG(&PL_sv_no)));
3081 if (use_default_op) {
3082 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3084 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3088 force_cpy = force_cpy || assign;
3093 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3094 * operation. we need this to return a value, so that it can be assigned
3095 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3096 * increment or decrement was itself called in void context */
3102 if (off == subtr_amg)
3105 /* in these cases, we're calling an assignment variant of an operator
3106 * (+= rather than +, for instance). regardless of whether it's a
3107 * fallback or not, it always has to return a value, which will be
3108 * assigned to the proper variable later */
3125 /* the copy constructor always needs to return a value */
3129 /* because of the way these are implemented (they don't perform the
3130 * dereferencing themselves, they return a reference that perl then
3131 * dereferences later), they always have to be in scalar context */
3139 /* these don't have an op of their own; they're triggered by their parent
3140 * op, so the context there isn't meaningful ('$a and foo()' in void
3141 * context still needs to pass scalar context on to $a's bool overload) */
3151 DEBUG_o(Perl_deb(aTHX_
3152 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3154 method+assignshift==off? "" :
3156 method+assignshift==off? "" :
3157 AMG_id2name(method+assignshift),
3158 method+assignshift==off? "" : "\")",
3159 flags & AMGf_unary? "" :
3160 lr==1 ? " for right argument": " for left argument",
3161 flags & AMGf_unary? " for argument" : "",
3162 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3163 fl? ",\n\tassignment variant used": "") );
3166 /* Since we use shallow copy during assignment, we need
3167 * to dublicate the contents, probably calling user-supplied
3168 * version of copy operator
3170 /* We need to copy in following cases:
3171 * a) Assignment form was called.
3172 * assignshift==1, assign==T, method + 1 == off
3173 * b) Increment or decrement, called directly.
3174 * assignshift==0, assign==0, method + 0 == off
3175 * c) Increment or decrement, translated to assignment add/subtr.
3176 * assignshift==0, assign==T,
3178 * d) Increment or decrement, translated to nomethod.
3179 * assignshift==0, assign==0,
3181 * e) Assignment form translated to nomethod.
3182 * assignshift==1, assign==T, method + 1 != off
3185 /* off is method, method+assignshift, or a result of opcode substitution.
3186 * In the latter case assignshift==0, so only notfound case is important.
3188 if ( (lr == -1) && ( ( (method + assignshift == off)
3189 && (assign || (method == inc_amg) || (method == dec_amg)))
3192 /* newSVsv does not behave as advertised, so we copy missing
3193 * information by hand */
3194 SV *tmpRef = SvRV(left);
3196 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3197 SvRV_set(left, rv_copy);
3199 SvREFCNT_dec_NN(tmpRef);
3207 const bool oldcatch = CATCH_GET;
3209 int gimme = force_scalar ? G_SCALAR : GIMME_V;
3212 Zero(&myop, 1, BINOP);
3213 myop.op_last = (OP *) &myop;
3214 myop.op_next = NULL;
3215 myop.op_flags = OPf_STACKED;
3219 myop.op_flags |= OPf_WANT_VOID;
3222 if (flags & AMGf_want_list) {
3223 myop.op_flags |= OPf_WANT_LIST;
3228 myop.op_flags |= OPf_WANT_SCALAR;
3232 PUSHSTACKi(PERLSI_OVERLOAD);
3235 PL_op = (OP *) &myop;
3236 if (PERLDB_SUB && PL_curstash != PL_debstash)
3237 PL_op->op_private |= OPpENTERSUB_DB;
3238 Perl_pp_pushmark(aTHX);
3240 EXTEND(SP, notfound + 5);
3241 PUSHs(lr>0? right: left);
3242 PUSHs(lr>0? left: right);
3243 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3245 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3246 AMG_id2namelen(method + assignshift), SVs_TEMP));
3248 PUSHs(MUTABLE_SV(cv));
3252 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3256 nret = SP - (PL_stack_base + oldmark);
3260 /* returning NULL has another meaning, and we check the context
3261 * at the call site too, so this can be differentiated from the
3264 SP = PL_stack_base + oldmark;
3267 if (flags & AMGf_want_list) {
3268 res = sv_2mortal((SV *)newAV());
3269 av_extend((AV *)res, nret);
3271 av_store((AV *)res, nret, POPs);
3283 CATCH_SET(oldcatch);
3290 ans=SvIV(res)<=0; break;
3293 ans=SvIV(res)<0; break;
3296 ans=SvIV(res)>=0; break;
3299 ans=SvIV(res)>0; break;
3302 ans=SvIV(res)==0; break;
3305 ans=SvIV(res)!=0; break;
3308 SvSetSV(left,res); return left;
3310 ans=!SvTRUE(res); break;
3315 } else if (method==copy_amg) {
3317 Perl_croak(aTHX_ "Copy method did not return a reference");
3319 return SvREFCNT_inc(SvRV(res));
3327 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3332 PERL_ARGS_ASSERT_GV_NAME_SET;
3335 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3337 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3338 unshare_hek(GvNAME_HEK(gv));
3341 PERL_HASH(hash, name, len);
3342 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3346 =for apidoc gv_try_downgrade
3348 If the typeglob C<gv> can be expressed more succinctly, by having
3349 something other than a real GV in its place in the stash, replace it
3350 with the optimised form. Basic requirements for this are that C<gv>
3351 is a real typeglob, is sufficiently ordinary, and is only referenced
3352 from its package. This function is meant to be used when a GV has been
3353 looked up in part to see what was there, causing upgrading, but based
3354 on what was found it turns out that the real GV isn't required after all.
3356 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3358 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3359 sub, the typeglob is replaced with a scalar-reference placeholder that
3360 more compactly represents the same thing.
3366 Perl_gv_try_downgrade(pTHX_ GV *gv)
3372 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3374 /* XXX Why and where does this leave dangling pointers during global
3376 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3378 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3379 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3380 isGV_with_GP(gv) && GvGP(gv) &&
3381 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3382 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3383 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3385 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3387 if (SvMAGICAL(gv)) {
3389 /* only backref magic is allowed */
3390 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3392 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3393 if (mg->mg_type != PERL_MAGIC_backref)
3399 HEK *gvnhek = GvNAME_HEK(gv);
3400 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3401 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3402 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3403 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3404 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3405 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3406 (namehek = GvNAME_HEK(gv)) &&
3407 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3409 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3410 const bool imported = !!GvIMPORTED_CV(gv);
3414 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3415 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3416 STRUCT_OFFSET(XPVIV, xiv_iv));
3417 SvRV_set(gv, value);
3422 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3424 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3426 PERL_ARGS_ASSERT_GV_OVERRIDE;
3427 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3428 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3429 gv = gvp ? *gvp : NULL;
3430 if (gv && !isGV(gv)) {
3431 if (!SvPCS_IMPORTED(gv)) return NULL;
3432 gv_init(gv, PL_globalstash, name, len, 0);
3435 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3441 core_xsub(pTHX_ CV* cv)
3444 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3450 * c-indentation-style: bsd
3452 * indent-tabs-mode: nil
3455 * ex: set ts=8 sts=4 sw=4 et: