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.
37 #include "overload.inc"
41 static const char S_autoload[] = "AUTOLOAD";
42 #define S_autolen (sizeof("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_OR_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 && SvTYPE(SvRV(gv)) != SVt_PVCV ? 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 = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
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))) {
241 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
242 assert(!CvCVGV_RC(cv));
247 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
248 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
251 SvREFCNT_inc_simple_void_NN(gv);
255 /* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
256 GV, but for efficiency that GV may not in fact exist. This function,
257 called by CvGV, reifies it. */
260 Perl_cvgv_from_hek(pTHX_ CV *cv)
264 PERL_ARGS_ASSERT_CVGV_FROM_HEK;
265 assert(SvTYPE(cv) == SVt_PVCV);
266 if (!CvSTASH(cv)) return NULL;
267 ASSUME(CvNAME_HEK(cv));
268 svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
269 gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
271 gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
272 HEK_LEN(CvNAME_HEK(cv)),
273 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
274 if (!CvNAMED(cv)) { /* gv_init took care of it */
275 assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
278 unshare_hek(CvNAME_HEK(cv));
280 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
281 if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
286 /* Assign CvSTASH(cv) = st, handling weak references. */
289 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
291 HV *oldst = CvSTASH(cv);
292 PERL_ARGS_ASSERT_CVSTASH_SET;
296 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
297 SvANY(cv)->xcv_stash = st;
299 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
303 =for apidoc gv_init_pvn
305 Converts a scalar into a typeglob. This is an incoercible typeglob;
306 assigning a reference to it will assign to one of its slots, instead of
307 overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
308 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
309 for perl's internal use.
311 C<gv> is the scalar to be converted.
313 C<stash> is the parent stash/package, if any.
315 C<name> and C<len> give the name. The name must be unqualified;
316 that is, it must not include the package name. If C<gv> is a
317 stash element, it is the caller's responsibility to ensure that the name
318 passed to this function matches the name of the element. If it does not
319 match, perl's internal bookkeeping will get out of sync.
321 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
322 the return value of SvUTF8(sv). It can also take the
323 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
324 seen before (i.e., suppress "Used once" warnings).
328 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
329 has no flags parameter. If the C<multi> parameter is set, the
330 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
332 =for apidoc gv_init_pv
334 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
335 instead of separate char * and length parameters.
337 =for apidoc gv_init_sv
339 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
340 char * and length parameters. C<flags> is currently unused.
346 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
350 PERL_ARGS_ASSERT_GV_INIT_SV;
351 namepv = SvPV(namesv, namelen);
354 gv_init_pvn(gv, stash, namepv, namelen, flags);
358 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
360 PERL_ARGS_ASSERT_GV_INIT_PV;
361 gv_init_pvn(gv, stash, name, strlen(name), flags);
365 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
367 const U32 old_type = SvTYPE(gv);
368 const bool doproto = old_type > SVt_NULL;
369 char * const proto = (doproto && SvPOK(gv))
370 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
372 const STRLEN protolen = proto ? SvCUR(gv) : 0;
373 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
374 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
375 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
377 PERL_ARGS_ASSERT_GV_INIT_PVN;
378 assert (!(proto && has_constant));
381 /* The constant has to be a scalar, array or subroutine. */
382 switch (SvTYPE(has_constant)) {
386 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
387 sv_reftype(has_constant, 0));
397 if (old_type < SVt_PVGV) {
398 if (old_type >= SVt_PV)
400 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
408 Safefree(SvPVX_mutable(gv));
413 GvGP_set(gv, Perl_newGP(aTHX_ gv));
416 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
417 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
418 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
419 GvMULTI_on(gv); /* _was_ mentioned */
420 if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
421 /* Not actually a constant. Just a regular sub. */
422 CV * const cv = (CV *)has_constant;
424 if (CvSTASH(cv) == stash && (
425 CvNAME_HEK(cv) == GvNAME_HEK(gv)
426 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
427 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
428 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
429 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
437 /* newCONSTSUB takes ownership of the reference from us. */
438 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
439 /* In case op.c:S_process_special_blocks stole it: */
441 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
442 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
443 /* If this reference was a copy of another, then the subroutine
444 must have been "imported", by a Perl space assignment to a GV
445 from a reference to CV. */
446 if (exported_constant)
447 GvIMPORTED_CV_on(gv);
448 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
453 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
454 SV_HAS_TRAILING_NUL);
455 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
461 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
463 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
475 #ifdef PERL_DONT_CREATE_GVSV
483 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
484 If we just cast GvSVn(gv) to void, it ignores evaluating it for
491 static void core_xsub(pTHX_ CV* cv);
494 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
495 const char * const name, const STRLEN len)
497 const int code = keyword(name, len, 1);
498 static const char file[] = __FILE__;
499 CV *cv, *oldcompcv = NULL;
501 bool ampable = TRUE; /* &{}-able */
502 COP *oldcurcop = NULL;
503 yy_parser *oldparser = NULL;
504 I32 oldsavestack_ix = 0;
509 if (!code) return NULL; /* Not a keyword */
510 switch (code < 0 ? -code : code) {
511 /* no support for \&CORE::infix;
512 no support for funcs that do not parse like funcs */
513 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
514 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
515 case KEY_default : case KEY_DESTROY:
516 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
517 case KEY_END : case KEY_eq : case KEY_eval :
518 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
519 case KEY_given : case KEY_goto : case KEY_grep :
520 case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
521 case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
522 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
523 case KEY_package: case KEY_print: case KEY_printf:
524 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
525 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
526 case KEY_s : case KEY_say : case KEY_sort :
527 case KEY_state: case KEY_sub :
528 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
529 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
530 case KEY_x : case KEY_xor : case KEY_y :
533 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
534 case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
540 case KEY_splice: case KEY_split:
543 case KEY_truncate: case KEY_unlink:
550 gv_init(gv, stash, name, len, TRUE);
555 oldcurcop = PL_curcop;
556 oldparser = PL_parser;
557 lex_start(NULL, NULL, 0);
558 oldcompcv = PL_compcv;
559 PL_compcv = NULL; /* Prevent start_subparse from setting
561 oldsavestack_ix = start_subparse(FALSE,0);
565 /* Avoid calling newXS, as it calls us, and things start to
567 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
571 CvXSUB(cv) = core_xsub;
574 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
576 /* XSUBs can't be perl lang/perl5db.pl debugged
577 if (PERLDB_LINE_OR_SAVESRC)
578 (void)gv_fetchfile(file); */
579 CvFILE(cv) = (char *)file;
580 /* XXX This is inefficient, as doing things this order causes
581 a prototype check in newATTRSUB. But we have to do
582 it this order as we need an op number before calling
584 (void)core_prototype((SV *)cv, name, code, &opnum);
586 (void)hv_store(stash,name,len,(SV *)gv,0);
592 /* newATTRSUB will free the CV and return NULL if we're still
593 compiling after a syntax error */
594 if ((cv = newATTRSUB_x(
595 oldsavestack_ix, (OP *)gv,
600 : newSVpvn(name,len),
605 assert(GvCV(gv) == orig_cv);
606 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
607 && opnum != OP_UNDEF)
608 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
611 PL_parser = oldparser;
612 PL_curcop = oldcurcop;
613 PL_compcv = oldcompcv;
616 SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
618 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
620 SvREFCNT_dec(opnumsv);
627 =for apidoc gv_fetchmeth
629 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
631 =for apidoc gv_fetchmeth_sv
633 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
634 of an SV instead of a string/length pair.
640 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
644 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
645 if (LIKELY(SvPOK_nog(namesv))) /* common case */
646 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
647 namepv = SvPV(namesv, namelen);
648 if (SvUTF8(namesv)) flags |= SVf_UTF8;
649 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
653 =for apidoc gv_fetchmeth_pv
655 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
656 instead of a string/length pair.
662 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
664 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
665 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
669 =for apidoc gv_fetchmeth_pvn
671 Returns the glob with the given C<name> and a defined subroutine or
672 C<NULL>. The glob lives in the given C<stash>, or in the stashes
673 accessible via C<@ISA> and C<UNIVERSAL::>.
675 The argument C<level> should be either 0 or -1. If C<level==0>, as a
676 side-effect creates a glob with the given C<name> in the given C<stash>
677 which in the case of success contains an alias for the subroutine, and sets
678 up caching info for this glob.
680 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
682 C<GV_SUPER> indicates that we want to look up the method in the superclasses
686 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
687 visible to Perl code. So when calling C<call_sv>, you should not use
688 the GV directly; instead, you should use the method's CV, which can be
689 obtained from the GV with the C<GvCV> macro.
694 /* NOTE: No support for tied ISA */
696 PERL_STATIC_INLINE GV*
697 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
704 HV* cstash, *cachestash;
705 GV* candidate = NULL;
709 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
712 U32 is_utf8 = flags & SVf_UTF8;
714 /* UNIVERSAL methods should be callable without a stash */
716 create = 0; /* probably appropriate */
717 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
723 hvname = HvNAME_get(stash);
725 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
728 assert(name || meth);
730 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
731 flags & GV_SUPER ? "SUPER " : "",
732 name ? name : SvPV_nolen(meth), hvname) );
734 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
736 if (flags & GV_SUPER) {
737 if (!HvAUX(stash)->xhv_mro_meta->super)
738 HvAUX(stash)->xhv_mro_meta->super = newHV();
739 cachestash = HvAUX(stash)->xhv_mro_meta->super;
741 else cachestash = stash;
743 /* check locally for a real method or a cache entry */
745 cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0
747 if (he) gvp = (GV**)&HeVAL(he);
754 if (SvTYPE(topgv) != SVt_PVGV)
757 name = SvPV_nomg(meth, len);
758 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
760 if ((cand_cv = GvCV(topgv))) {
761 /* If genuine method or valid cache entry, use it */
762 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
766 /* stale cache entry, junk it and move on */
767 SvREFCNT_dec_NN(cand_cv);
768 GvCV_set(topgv, NULL);
773 else if (GvCVGEN(topgv) == topgen_cmp) {
774 /* cache indicates no such method definitively */
777 else if (stash == cachestash
778 && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
779 && strnEQ(hvname, "CORE", 4)
780 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
784 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
785 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
786 items = AvFILLp(linear_av); /* no +1, to skip over self */
788 linear_sv = *linear_svp++;
790 cstash = gv_stashsv(linear_sv, 0);
793 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
794 "Can't locate package %"SVf" for @%"HEKf"::ISA",
796 HEKfARG(HvNAME_HEK(stash)));
802 gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
804 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
805 const char *hvname = HvNAME(cstash); assert(hvname);
806 if (strnEQ(hvname, "CORE", 4)
808 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
814 else candidate = *gvp;
817 if (SvTYPE(candidate) != SVt_PVGV)
818 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
819 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
821 * Found real method, cache method in topgv if:
822 * 1. topgv has no synonyms (else inheritance crosses wires)
823 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
825 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
826 CV *old_cv = GvCV(topgv);
827 SvREFCNT_dec(old_cv);
828 SvREFCNT_inc_simple_void_NN(cand_cv);
829 GvCV_set(topgv, cand_cv);
830 GvCVGEN(topgv) = topgen_cmp;
836 /* Check UNIVERSAL without caching */
837 if(level == 0 || level == -1) {
838 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
841 cand_cv = GvCV(candidate);
842 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
843 CV *old_cv = GvCV(topgv);
844 SvREFCNT_dec(old_cv);
845 SvREFCNT_inc_simple_void_NN(cand_cv);
846 GvCV_set(topgv, cand_cv);
847 GvCVGEN(topgv) = topgen_cmp;
853 if (topgv && GvREFCNT(topgv) == 1) {
854 /* cache the fact that the method is not defined */
855 GvCVGEN(topgv) = topgen_cmp;
862 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
864 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
865 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
869 =for apidoc gv_fetchmeth_autoload
871 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
874 =for apidoc gv_fetchmeth_sv_autoload
876 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
877 of an SV instead of a string/length pair.
883 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
887 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
888 namepv = SvPV(namesv, namelen);
891 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
895 =for apidoc gv_fetchmeth_pv_autoload
897 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
898 instead of a string/length pair.
904 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
906 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
907 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
911 =for apidoc gv_fetchmeth_pvn_autoload
913 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
914 Returns a glob for the subroutine.
916 For an autoloaded subroutine without a GV, will create a GV even
917 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
918 of the result may be zero.
920 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
926 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
928 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
930 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
937 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
938 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
940 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
943 if (!(CvROOT(cv) || CvXSUB(cv)))
945 /* Have an autoload */
946 if (level < 0) /* Cannot do without a stub */
947 gv_fetchmeth_pvn(stash, name, len, 0, flags);
948 gvp = (GV**)hv_fetch(stash, name,
949 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
958 =for apidoc gv_fetchmethod_autoload
960 Returns the glob which contains the subroutine to call to invoke the method
961 on the C<stash>. In fact in the presence of autoloading this may be the
962 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
965 The third parameter of C<gv_fetchmethod_autoload> determines whether
966 AUTOLOAD lookup is performed if the given method is not present: non-zero
967 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
968 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
969 with a non-zero C<autoload> parameter.
971 These functions grant C<"SUPER"> token
972 as a prefix of the method name. Note
973 that if you want to keep the returned glob for a long time, you need to
974 check for it being "AUTOLOAD", since at the later time the call may load a
975 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
976 created as a side effect to do this.
978 These functions have the same side-effects as C<gv_fetchmeth> with
979 C<level==0>. The warning against passing the GV returned by
980 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
986 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
988 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
990 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
994 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
998 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
999 namepv = SvPV(namesv, namelen);
1002 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1006 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1008 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1009 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1012 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
1015 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1018 const char *nsplit = NULL;
1021 const char * const origname = name;
1022 SV *const error_report = MUTABLE_SV(stash);
1023 const U32 autoload = flags & GV_AUTOLOAD;
1024 const U32 do_croak = flags & GV_CROAK;
1025 const U32 is_utf8 = flags & SVf_UTF8;
1027 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1029 if (SvTYPE(stash) < SVt_PVHV)
1032 /* The only way stash can become NULL later on is if nsplit is set,
1033 which in turn means that there is no need for a SVt_PVHV case
1034 the error reporting code. */
1037 for (nend = name; *nend || nend != (origname + len); nend++) {
1038 if (*nend == '\'') {
1042 else if (*nend == ':' && *(nend + 1) == ':') {
1048 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
1049 /* ->SUPER::method should really be looked up in original stash */
1050 stash = CopSTASH(PL_curcop);
1052 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1053 origname, HvENAME_get(stash), name) );
1055 else if ((nsplit - origname) >= 7 &&
1056 strnEQ(nsplit - 7, "::SUPER", 7)) {
1057 /* don't autovifify if ->NoSuchStash::SUPER::method */
1058 stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
1059 if (stash) flags |= GV_SUPER;
1062 /* don't autovifify if ->NoSuchStash::method */
1063 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1068 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1070 if (strEQ(name,"import") || strEQ(name,"unimport"))
1071 gv = MUTABLE_GV(&PL_sv_yes);
1073 gv = gv_autoload_pvn(
1074 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1076 if (!gv && do_croak) {
1077 /* Right now this is exclusively for the benefit of S_method_common
1080 /* If we can't find an IO::File method, it might be a call on
1081 * a filehandle. If IO:File has not been loaded, try to
1082 * require it first instead of croaking */
1083 const char *stash_name = HvNAME_get(stash);
1084 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1085 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1086 STR_WITH_LEN("IO/File.pm"), 0,
1087 HV_FETCH_ISEXISTS, NULL, 0)
1089 require_pv("IO/File.pm");
1090 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1095 "Can't locate object method \"%"UTF8f
1096 "\" via package \"%"HEKf"\"",
1097 UTF8fARG(is_utf8, nend - name, name),
1098 HEKfARG(HvNAME_HEK(stash)));
1104 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1105 SVs_TEMP | is_utf8);
1107 packnamesv = error_report;
1111 "Can't locate object method \"%"UTF8f
1112 "\" via package \"%"SVf"\""
1113 " (perhaps you forgot to load \"%"SVf"\"?)",
1114 UTF8fARG(is_utf8, nend - name, name),
1115 SVfARG(packnamesv), SVfARG(packnamesv));
1119 else if (autoload) {
1120 CV* const cv = GvCV(gv);
1121 if (!CvROOT(cv) && !CvXSUB(cv)) {
1125 if (CvANON(cv) || CvLEXICAL(cv))
1129 if (GvCV(stubgv) != cv) /* orphaned import */
1132 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1133 GvNAME(stubgv), GvNAMELEN(stubgv),
1134 GV_AUTOLOAD_ISMETHOD
1135 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1145 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1149 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1150 namepv = SvPV(namesv, namelen);
1153 return gv_autoload_pvn(stash, namepv, namelen, flags);
1157 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1159 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1160 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1164 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1171 SV *packname = NULL;
1172 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1174 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1176 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1179 if (SvTYPE(stash) < SVt_PVHV) {
1180 STRLEN packname_len = 0;
1181 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1182 packname = newSVpvn_flags(packname_ptr, packname_len,
1183 SVs_TEMP | SvUTF8(stash));
1187 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1188 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1190 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1191 is_utf8 | (flags & GV_SUPER))))
1195 if (!(CvROOT(cv) || CvXSUB(cv)))
1199 * Inheriting AUTOLOAD for non-methods works ... for now.
1202 !(flags & GV_AUTOLOAD_ISMETHOD)
1203 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1205 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1206 "Use of inherited AUTOLOAD for non-method %"SVf
1207 "::%"UTF8f"() is deprecated",
1209 UTF8fARG(is_utf8, len, name));
1212 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1213 * and split that value on the last '::', pass along the same data
1214 * via the SvPVX field in the CV, and the stash in CvSTASH.
1216 * Due to an unfortunate accident of history, the SvPVX field
1217 * serves two purposes. It is also used for the subroutine's pro-
1218 * type. Since SvPVX has been documented as returning the sub name
1219 * for a long time, but not as returning the prototype, we have
1220 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1223 * We put the prototype in the same allocated buffer, but after
1224 * the sub name. The SvPOK flag indicates the presence of a proto-
1225 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1226 * If both flags are on, then SvLEN is used to indicate the end of
1227 * the prototype (artificially lower than what is actually allo-
1228 * cated), at the risk of having to reallocate a few bytes unneces-
1229 * sarily--but that should happen very rarely, if ever.
1231 * We use SvUTF8 for both prototypes and sub names, so if one is
1232 * UTF8, the other must be upgraded.
1234 CvSTASH_set(cv, stash);
1235 if (SvPOK(cv)) { /* Ouch! */
1236 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1238 const char *proto = CvPROTO(cv);
1241 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1242 ulen = SvCUR(tmpsv);
1243 SvCUR(tmpsv)++; /* include null in string */
1245 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1247 SvTEMP_on(tmpsv); /* Allow theft */
1248 sv_setsv_nomg((SV *)cv, tmpsv);
1250 SvREFCNT_dec_NN(tmpsv);
1251 SvLEN(cv) = SvCUR(cv) + 1;
1255 sv_setpvn((SV *)cv, name, len);
1259 else SvUTF8_off(cv);
1265 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1266 * The subroutine's original name may not be "AUTOLOAD", so we don't
1267 * use that, but for lack of anything better we will use the sub's
1268 * original package to look up $AUTOLOAD.
1270 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1271 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1275 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1276 #ifdef PERL_DONT_CREATE_GVSV
1277 GvSV(vargv) = newSV(0);
1281 varsv = GvSVn(vargv);
1282 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1283 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1284 sv_setsv(varsv, packname);
1285 sv_catpvs(varsv, "::");
1286 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1287 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1290 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1298 /* require_tie_mod() internal routine for requiring a module
1299 * that implements the logic of automatic ties like %! and %-
1301 * The "gv" parameter should be the glob.
1302 * "varpv" holds the name of the var, used for error messages.
1303 * "namesv" holds the module name. Its refcount will be decremented.
1304 * "methpv" holds the method name to test for to check that things
1305 * are working reasonably close to as expected.
1306 * "flags": if flag & 1 then save the scalar before loading.
1307 * For the protection of $! to work (it is set by this routine)
1308 * the sv slot must already be magicalized.
1311 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1313 HV* stash = gv_stashsv(namesv, 0);
1315 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1317 if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1318 SV *module = newSVsv(namesv);
1319 char varname = *varpv; /* varpv might be clobbered by load_module,
1320 so save it. For the moment it's always
1322 const char type = varname == '[' ? '$' : '%';
1330 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1331 assert(sp == PL_stack_sp);
1332 stash = gv_stashsv(namesv, 0);
1334 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1335 type, varname, SVfARG(namesv));
1336 else if (!gv_fetchmethod(stash, methpv))
1337 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1338 type, varname, SVfARG(namesv), methpv);
1341 else SvREFCNT_dec_NN(namesv);
1346 =for apidoc gv_stashpv
1348 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1349 determine the length of C<name>, then calls C<gv_stashpvn()>.
1355 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1357 PERL_ARGS_ASSERT_GV_STASHPV;
1358 return gv_stashpvn(name, strlen(name), create);
1362 =for apidoc gv_stashpvn
1364 Returns a pointer to the stash for a specified package. The C<namelen>
1365 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1366 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1367 created if it does not already exist. If the package does not exist and
1368 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1371 Flags may be one of:
1380 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1382 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1383 recommended for performance reasons.
1389 gv_stashpvn_internal
1391 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1392 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1396 PERL_STATIC_INLINE HV*
1397 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1403 U32 tmplen = namelen + 2;
1405 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1407 if (tmplen <= sizeof smallbuf)
1410 Newx(tmpbuf, tmplen, char);
1411 Copy(name, tmpbuf, namelen, char);
1412 tmpbuf[namelen] = ':';
1413 tmpbuf[namelen+1] = ':';
1414 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1415 if (tmpbuf != smallbuf)
1417 if (!tmpgv || !isGV_with_GP(tmpgv))
1419 stash = GvHV(tmpgv);
1420 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1422 if (!HvNAME_get(stash)) {
1423 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1425 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1426 /* If the containing stash has multiple effective
1427 names, see that this one gets them, too. */
1428 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1429 mro_package_moved(stash, NULL, tmpgv, 1);
1435 gv_stashsvpvn_cached
1437 Returns a pointer to the stash for a specified package, possibly
1438 cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
1440 Requires one of either namesv or namepv to be non-null.
1442 See C<L</gv_stashpvn>> for details on "flags".
1444 Note the sv interface is strongly preferred for performance reasons.
1448 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1449 assert(namesv || name)
1451 PERL_STATIC_INLINE HV*
1452 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1457 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1459 he = (HE *)hv_common(
1460 PL_stashcache, namesv, name, namelen,
1461 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1464 if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
1465 else if (flags & GV_CACHE_ONLY) return NULL;
1468 if (SvOK(namesv)) { /* prevent double uninit warning */
1470 name = SvPV_const(namesv, len);
1472 flags |= SvUTF8(namesv);
1474 name = ""; namelen = 0;
1477 stash = gv_stashpvn_internal(name, namelen, flags);
1479 if (stash && namelen) {
1480 SV* const ref = newSViv(PTR2IV(stash));
1481 (void)hv_store(PL_stashcache, name,
1482 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1489 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1491 PERL_ARGS_ASSERT_GV_STASHPVN;
1492 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1496 =for apidoc gv_stashsv
1498 Returns a pointer to the stash for a specified package. See
1501 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1508 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1510 PERL_ARGS_ASSERT_GV_STASHSV;
1511 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1516 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1517 PERL_ARGS_ASSERT_GV_FETCHPV;
1518 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1522 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1524 const char * const nambeg =
1525 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1526 PERL_ARGS_ASSERT_GV_FETCHSV;
1527 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1530 PERL_STATIC_INLINE void
1531 S_gv_magicalize_isa(pTHX_ GV *gv)
1535 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1539 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1543 /* This function grabs name and tries to split a stash and glob
1544 * from its contents. TODO better description, comments
1546 * If the function returns TRUE and 'name == name_end', then
1547 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1549 PERL_STATIC_INLINE bool
1550 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1551 STRLEN *len, const char *nambeg, STRLEN full_len,
1552 const U32 is_utf8, const I32 add)
1554 const char *name_cursor;
1555 const char *const name_end = nambeg + full_len;
1556 const char *const name_em1 = name_end - 1;
1558 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1560 if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
1561 /* accidental stringify on a GV? */
1565 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1566 if (name_cursor < name_em1 &&
1567 ((*name_cursor == ':' && name_cursor[1] == ':')
1568 || *name_cursor == '\''))
1571 *stash = PL_defstash;
1572 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1575 *len = name_cursor - *name;
1576 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1579 if (*name_cursor == ':') {
1585 Newx(tmpbuf, *len+2, char);
1586 Copy(*name, tmpbuf, *len, char);
1587 tmpbuf[(*len)++] = ':';
1588 tmpbuf[(*len)++] = ':';
1591 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1592 *gv = gvp ? *gvp : NULL;
1593 if (*gv && *gv != (const GV *)&PL_sv_undef) {
1594 if (SvTYPE(*gv) != SVt_PVGV)
1595 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1601 if (!*gv || *gv == (const GV *)&PL_sv_undef)
1604 if (!(*stash = GvHV(*gv))) {
1605 *stash = GvHV(*gv) = newHV();
1606 if (!HvNAME_get(*stash)) {
1607 if (GvSTASH(*gv) == PL_defstash && *len == 6
1608 && strnEQ(*name, "CORE", 4))
1609 hv_name_set(*stash, "CORE", 4, 0);
1612 *stash, nambeg, name_cursor-nambeg, is_utf8
1614 /* If the containing stash has multiple effective
1615 names, see that this one gets them, too. */
1616 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1617 mro_package_moved(*stash, NULL, *gv, 1);
1620 else if (!HvNAME_get(*stash))
1621 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1624 if (*name_cursor == ':')
1626 *name = name_cursor+1;
1627 if (*name == name_end) {
1629 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1634 *len = name_cursor - *name;
1638 /* Checks if an unqualified name is in the main stash */
1639 PERL_STATIC_INLINE bool
1640 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1642 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1644 /* If it's an alphanumeric variable */
1645 if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
1646 /* Some "normal" variables are always in main::,
1647 * like INC or STDOUT.
1655 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1656 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1657 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1661 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1666 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1667 && name[3] == 'I' && name[4] == 'N')
1671 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1672 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1673 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1677 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1678 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1684 /* *{""}, or a special variable like $@ */
1692 /* This function is called if parse_gv_stash_name() failed to
1693 * find a stash, or if GV_NOTQUAL or an empty name was passed
1694 * to gv_fetchpvn_flags.
1696 * It returns FALSE if the default stash can't be found nor created,
1697 * which might happen during global destruction.
1699 PERL_STATIC_INLINE bool
1700 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1701 const U32 is_utf8, const I32 add,
1702 const svtype sv_type)
1704 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1706 /* No stash in name, so see how we can default */
1708 if ( gv_is_in_main(name, len, is_utf8) ) {
1709 *stash = PL_defstash;
1712 if (IN_PERL_COMPILETIME) {
1713 *stash = PL_curstash;
1714 if (add && (PL_hints & HINT_STRICT_VARS) &&
1715 sv_type != SVt_PVCV &&
1716 sv_type != SVt_PVGV &&
1717 sv_type != SVt_PVFM &&
1718 sv_type != SVt_PVIO &&
1719 !(len == 1 && sv_type == SVt_PV &&
1720 (*name == 'a' || *name == 'b')) )
1722 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1723 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1724 SvTYPE(*gvp) != SVt_PVGV)
1728 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1729 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1730 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1732 /* diag_listed_as: Variable "%s" is not imported%s */
1734 aTHX_ packWARN(WARN_MISC),
1735 "Variable \"%c%"UTF8f"\" is not imported",
1736 sv_type == SVt_PVAV ? '@' :
1737 sv_type == SVt_PVHV ? '%' : '$',
1738 UTF8fARG(is_utf8, len, name));
1741 aTHX_ packWARN(WARN_MISC),
1742 "\t(Did you mean &%"UTF8f" instead?)\n",
1743 UTF8fARG(is_utf8, len, name)
1750 /* Use the current op's stash */
1751 *stash = CopSTASH(PL_curcop);
1756 if (add && !PL_in_clean_all) {
1758 qerror(Perl_mess(aTHX_
1759 "Global symbol \"%s%"UTF8f
1760 "\" requires explicit package name (did you forget to "
1761 "declare \"my %s%"UTF8f"\"?)",
1762 (sv_type == SVt_PV ? "$"
1763 : sv_type == SVt_PVAV ? "@"
1764 : sv_type == SVt_PVHV ? "%"
1765 : ""), UTF8fARG(is_utf8, len, name),
1766 (sv_type == SVt_PV ? "$"
1767 : sv_type == SVt_PVAV ? "@"
1768 : sv_type == SVt_PVHV ? "%"
1769 : ""), UTF8fARG(is_utf8, len, name)));
1770 /* To maintain the output of errors after the strict exception
1771 * above, and to keep compat with older releases, rather than
1772 * placing the variables in the pad, we place
1773 * them in the <none>:: stash.
1775 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1777 /* symbol table under destruction */
1786 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1792 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
1793 redefine SvREADONLY_on for that purpose. We don’t use it later on in
1795 #undef SvREADONLY_on
1796 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1798 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1800 * Note that it does not insert the GV into the stash prior to
1801 * magicalization, which some variables require need in order
1802 * to work (like $[, %+, %-, %!), so callers must take care of
1805 * The return value has a specific meaning for gv_fetchpvn_flags:
1806 * If it returns true, and the gv is empty, it indicates that its
1807 * refcount should be decreased.
1809 PERL_STATIC_INLINE bool
1810 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1811 bool addmg, const svtype sv_type)
1815 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1817 if (stash != PL_defstash) { /* not the main stash */
1818 /* We only have to check for a few names here: a, b, EXPORT, ISA
1819 and VERSION. All the others apply only to the main stash or to
1820 CORE (which is checked right after this). */
1822 const char * const name2 = name + 1;
1825 if (strnEQ(name2, "XPORT", 5))
1829 if (strEQ(name2, "SA"))
1830 gv_magicalize_isa(gv);
1833 if (strEQ(name2, "ERSION"))
1838 if (len == 1 && sv_type == SVt_PV)
1847 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1848 /* Avoid null warning: */
1849 const char * const stashname = HvNAME(stash); assert(stashname);
1850 if (strnEQ(stashname, "CORE", 4))
1851 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1858 /* Nothing else to do.
1859 The compiler will probably turn the switch statement into a
1860 branch table. Make sure we avoid even that small overhead for
1861 the common case of lower case variable names. (On EBCDIC
1862 platforms, we can't just do:
1863 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1864 because cases like '\027' in the switch statement below are
1865 C1 (non-ASCII) controls on those platforms, so the remapping
1866 would make them larger than 'V')
1871 const char * name2 = name + 1;
1874 if (strEQ(name2, "RGV")) {
1875 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1877 else if (strEQ(name2, "RGVOUT")) {
1882 if (strnEQ(name2, "XPORT", 5))
1886 if (strEQ(name2, "SA")) {
1887 gv_magicalize_isa(gv);
1891 if (strEQ(name2, "IG")) {
1894 if (!PL_psig_name) {
1895 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1896 Newxz(PL_psig_pend, SIG_SIZE, int);
1897 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1899 /* I think that the only way to get here is to re-use an
1900 embedded perl interpreter, where the previous
1901 use didn't clean up fully because
1902 PL_perl_destruct_level was 0. I'm not sure that we
1903 "support" that, in that I suspect in that scenario
1904 there are sufficient other garbage values left in the
1905 interpreter structure that something else will crash
1906 before we get here. I suspect that this is one of
1907 those "doctor, it hurts when I do this" bugs. */
1908 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1909 Zero(PL_psig_pend, SIG_SIZE, int);
1913 hv_magic(hv, NULL, PERL_MAGIC_sig);
1914 for (i = 1; i < SIG_SIZE; i++) {
1915 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1917 sv_setsv(*init, &PL_sv_undef);
1922 if (strEQ(name2, "ERSION"))
1925 case '\003': /* $^CHILD_ERROR_NATIVE */
1926 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1929 case '\005': /* $^ENCODING */
1930 if (*name2 == '_') {
1933 if (strEQ(name2, "NCODING"))
1936 case '\007': /* $^GLOBAL_PHASE */
1937 if (strEQ(name2, "LOBAL_PHASE"))
1940 case '\014': /* $^LAST_FH */
1941 if (strEQ(name2, "AST_FH"))
1944 case '\015': /* $^MATCH */
1945 if (strEQ(name2, "ATCH")) {
1946 paren = RX_BUFF_IDX_CARET_FULLMATCH;
1950 case '\017': /* $^OPEN */
1951 if (strEQ(name2, "PEN"))
1954 case '\020': /* $^PREMATCH $^POSTMATCH */
1955 if (strEQ(name2, "REMATCH")) {
1956 paren = RX_BUFF_IDX_CARET_PREMATCH;
1959 if (strEQ(name2, "OSTMATCH")) {
1960 paren = RX_BUFF_IDX_CARET_POSTMATCH;
1964 case '\024': /* ${^TAINT} */
1965 if (strEQ(name2, "AINT"))
1968 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1969 if (strEQ(name2, "NICODE"))
1971 if (strEQ(name2, "TF8LOCALE"))
1973 if (strEQ(name2, "TF8CACHE"))
1976 case '\027': /* $^WARNING_BITS */
1977 if (strEQ(name2, "ARNING_BITS"))
1980 else if (strEQ(name2, "IN32_SLOPPY_STAT"))
1994 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1997 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
1999 /* XXX why are we using a SSize_t? */
2000 paren = (SSize_t)(I32)uv;
2006 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2007 be case '\0' in this switch statement (ie a default case) */
2010 paren = RX_BUFF_IDX_FULLMATCH;
2013 paren = RX_BUFF_IDX_PREMATCH;
2016 paren = RX_BUFF_IDX_POSTMATCH;
2018 #ifdef PERL_SAWAMPERSAND
2020 sv_type == SVt_PVAV ||
2021 sv_type == SVt_PVHV ||
2022 sv_type == SVt_PVCV ||
2023 sv_type == SVt_PVFM ||
2025 )) { PL_sawampersand |=
2029 ? SAWAMPERSAND_MIDDLE
2030 : SAWAMPERSAND_RIGHT;
2043 paren = *name - '0';
2046 /* Flag the capture variables with a NULL mg_ptr
2047 Use mg_len for the array index to lookup. */
2048 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2052 sv_setpv(GvSVn(gv),PL_chopset);
2056 #ifdef COMPLEX_STATUS
2057 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2063 /* If %! has been used, automatically load Errno.pm. */
2065 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2067 /* magicalization must be done before require_tie_mod is called */
2068 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2070 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2077 GvMULTI_on(gv); /* no used once warnings here */
2079 AV* const av = GvAVn(gv);
2080 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
2082 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
2083 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2085 SvREADONLY_on(GvSVn(gv));
2088 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2090 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2098 if (sv_type == SVt_PV)
2099 /* diag_listed_as: $* is no longer supported */
2100 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
2101 "$%c is no longer supported", *name);
2103 case '\010': /* $^H */
2105 HV *const hv = GvHVn(gv);
2106 hv_magic(hv, NULL, PERL_MAGIC_hints);
2110 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
2111 && FEATURE_ARYBASE_IS_ENABLED) {
2112 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2115 else goto magicalize;
2117 case '\023': /* $^S */
2119 SvREADONLY_on(GvSVn(gv));
2135 case '\001': /* $^A */
2136 case '\003': /* $^C */
2137 case '\004': /* $^D */
2138 case '\005': /* $^E */
2139 case '\006': /* $^F */
2140 case '\011': /* $^I, NOT \t in EBCDIC */
2141 case '\016': /* $^N */
2142 case '\017': /* $^O */
2143 case '\020': /* $^P */
2144 case '\024': /* $^T */
2145 case '\027': /* $^W */
2147 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2150 case '\014': /* $^L */
2151 sv_setpvs(GvSVn(gv),"\f");
2154 sv_setpvs(GvSVn(gv),"\034");
2158 SV * const sv = GvSV(gv);
2159 if (!sv_derived_from(PL_patchlevel, "version"))
2160 upg_version(PL_patchlevel, TRUE);
2161 GvSV(gv) = vnumify(PL_patchlevel);
2162 SvREADONLY_on(GvSV(gv));
2166 case '\026': /* $^V */
2168 SV * const sv = GvSV(gv);
2169 GvSV(gv) = new_version(PL_patchlevel);
2170 SvREADONLY_on(GvSV(gv));
2176 if (sv_type == SVt_PV)
2184 /* If we do ever start using this later on in the file, we need to make
2185 sure we don’t accidentally use the wrong definition. */
2186 #undef SvREADONLY_on
2188 /* This function is called when the stash already holds the GV of the magic
2189 * variable we're looking for, but we need to check that it has the correct
2190 * kind of magic. For example, if someone first uses $! and then %!, the
2191 * latter would end up here, and we add the Errno tie to the HASH slot of
2194 PERL_STATIC_INLINE void
2195 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2197 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2199 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2201 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
2202 else if (*name == '-' || *name == '+')
2203 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
2204 } else if (sv_type == SVt_PV) {
2205 if (*name == '*' || *name == '#') {
2206 /* diag_listed_as: $* is no longer supported */
2207 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
2209 "$%c is no longer supported", *name);
2212 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2215 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
2217 #ifdef PERL_SAWAMPERSAND
2219 PL_sawampersand |= SAWAMPERSAND_LEFT;
2223 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2227 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2236 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2237 const svtype sv_type)
2239 const char *name = nambeg;
2244 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2245 const I32 no_expand = flags & GV_NOEXPAND;
2246 const I32 add = flags & ~GV_NOADD_MASK;
2247 const U32 is_utf8 = flags & SVf_UTF8;
2248 bool addmg = cBOOL(flags & GV_ADDMG);
2249 const char *const name_end = nambeg + full_len;
2252 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2254 /* If we have GV_NOTQUAL, the caller promised that
2255 * there is no stash, so we can skip the check.
2256 * Similarly if full_len is 0, since then we're
2257 * dealing with something like *{""} or ""->foo()
2259 if ((flags & GV_NOTQUAL) || !full_len) {
2262 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2263 if (name == name_end) return gv;
2269 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2273 /* By this point we should have a stash and a name */
2274 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2275 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2276 if (addmg) gv = (GV *)newSV(0);
2279 else gv = *gvp, addmg = 0;
2280 /* From this point on, addmg means gv has not been inserted in the
2283 if (SvTYPE(gv) == SVt_PVGV) {
2284 /* The GV already exists, so return it, but check if we need to do
2285 * anything else with it before that.
2288 /* This is the heuristic that handles if a variable triggers the
2289 * 'used only once' warning. If there's already a GV in the stash
2290 * with this name, then we assume that the variable has been used
2291 * before and turn its MULTI flag on.
2292 * It's a heuristic because it can easily be "tricked", like with
2293 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2294 * not warning about $main::foo being used just once
2297 gv_init_svtype(gv, sv_type);
2298 /* You reach this path once the typeglob has already been created,
2299 either by the same or a different sigil. If this path didn't
2300 exist, then (say) referencing $! first, and %! second would
2301 mean that %! was not handled correctly. */
2302 if (len == 1 && stash == PL_defstash) {
2303 maybe_multimagic_gv(gv, name, sv_type);
2305 else if (len == 3 && sv_type == SVt_PVAV
2306 && strnEQ(name, "ISA", 3)
2307 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2308 gv_magicalize_isa(gv);
2311 } else if (no_init) {
2315 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2316 * don't expand it to a glob. This is an optimization so that things
2317 * copying constants over, like Exporter, don't have to be rewritten
2318 * to take into account that you can store more than just globs in
2321 else if (no_expand && SvROK(gv)) {
2326 /* Adding a new symbol.
2327 Unless of course there was already something non-GV here, in which case
2328 we want to behave as if there was always a GV here, containing some sort
2330 Otherwise we run the risk of creating things like GvIO, which can cause
2331 subtle bugs. eg the one that tripped up SQL::Translator */
2333 faking_it = SvOK(gv);
2335 if (add & GV_ADDWARN)
2336 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2337 "Had to create %"UTF8f" unexpectedly",
2338 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2339 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2341 if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
2344 /* First, store the gv in the symtab if we're adding magic,
2345 * but only for non-empty GVs
2347 #define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
2348 || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
2350 if ( addmg && !GvEMPTY(gv) ) {
2351 (void)hv_store(stash,name,len,(SV *)gv,0);
2354 /* set up magic where warranted */
2355 if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
2358 if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
2359 /* The GV was and still is "empty", except that now
2360 * it has the magic flags turned on, so we want it
2361 * stored in the symtab.
2363 (void)hv_store(stash,name,len,(SV *)gv,0);
2366 /* Most likely the temporary GV created above */
2367 SvREFCNT_dec_NN(gv);
2373 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2378 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2381 const HV * const hv = GvSTASH(gv);
2383 PERL_ARGS_ASSERT_GV_FULLNAME4;
2385 sv_setpv(sv, prefix ? prefix : "");
2387 if (hv && (name = HvNAME(hv))) {
2388 const STRLEN len = HvNAMELEN(hv);
2389 if (keepmain || strnNE(name, "main", len)) {
2390 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2394 else sv_catpvs(sv,"__ANON__::");
2395 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2399 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2401 const GV * const egv = GvEGVx(gv);
2403 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2405 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2409 /* recursively scan a stash and any nested stashes looking for entries
2410 * that need the "only used once" warning raised
2414 Perl_gv_check(pTHX_ HV *stash)
2418 PERL_ARGS_ASSERT_GV_CHECK;
2420 if (!HvARRAY(stash))
2423 assert(SvOOK(stash));
2425 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2427 /* mark stash is being scanned, to avoid recursing */
2428 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2429 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2432 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2433 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2435 if (hv != PL_defstash && hv != stash
2437 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2439 gv_check(hv); /* nested package */
2441 else if ( *HeKEY(entry) != '_'
2442 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2444 gv = MUTABLE_GV(HeVAL(entry));
2445 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2448 CopLINE_set(PL_curcop, GvLINE(gv));
2450 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2452 CopFILEGV(PL_curcop)
2453 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2455 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2456 "Name \"%"HEKf"::%"HEKf
2457 "\" used only once: possible typo",
2458 HEKfARG(HvNAME_HEK(stash)),
2459 HEKfARG(GvNAME_HEK(gv)));
2462 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2467 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2469 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2470 assert(!(flags & ~SVf_UTF8));
2472 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2473 UTF8fARG(flags, strlen(pack), pack),
2478 /* hopefully this is only called on local symbol table entries */
2481 Perl_gp_ref(pTHX_ GP *gp)
2488 /* If the GP they asked for a reference to contains
2489 a method cache entry, clear it first, so that we
2490 don't infect them with our cached entry */
2491 SvREFCNT_dec_NN(gp->gp_cv);
2500 Perl_gp_free(pTHX_ GV *gv)
2505 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2507 if (gp->gp_refcnt == 0) {
2508 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2509 "Attempt to free unreferenced glob pointers"
2510 pTHX__FORMAT pTHX__VALUE);
2513 if (gp->gp_refcnt > 1) {
2515 if (gp->gp_egv == gv)
2523 /* Copy and null out all the glob slots, so destructors do not see
2525 HEK * const file_hek = gp->gp_file_hek;
2526 SV * const sv = gp->gp_sv;
2527 AV * const av = gp->gp_av;
2528 HV * const hv = gp->gp_hv;
2529 IO * const io = gp->gp_io;
2530 CV * const cv = gp->gp_cv;
2531 CV * const form = gp->gp_form;
2533 gp->gp_file_hek = NULL;
2542 unshare_hek(file_hek);
2546 /* FIXME - another reference loop GV -> symtab -> GV ?
2547 Somehow gp->gp_hv can end up pointing at freed garbage. */
2548 if (hv && SvTYPE(hv) == SVt_PVHV) {
2549 const HEK *hvname_hek = HvNAME_HEK(hv);
2550 if (PL_stashcache && hvname_hek) {
2551 DEBUG_o(Perl_deb(aTHX_
2552 "gp_free clearing PL_stashcache for '%"HEKf"'\n",
2553 HEKfARG(hvname_hek)));
2554 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2558 if (io && SvREFCNT(io) == 1 && IoIFP(io)
2559 && (IoTYPE(io) == IoTYPE_WRONLY ||
2560 IoTYPE(io) == IoTYPE_RDWR ||
2561 IoTYPE(io) == IoTYPE_APPEND)
2562 && ckWARN_d(WARN_IO)
2563 && IoIFP(io) != PerlIO_stdin()
2564 && IoIFP(io) != PerlIO_stdout()
2565 && IoIFP(io) != PerlIO_stderr()
2566 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2567 io_close(io, gv, FALSE, TRUE);
2572 /* Possibly reallocated by a destructor */
2575 if (!gp->gp_file_hek
2581 && !gp->gp_form) break;
2583 if (--attempts == 0) {
2585 "panic: gp_free failed to free glob pointer - "
2586 "something is repeatedly re-creating entries"
2591 /* Possibly incremented by a destructor doing glob assignment */
2592 if (gp->gp_refcnt > 1) goto borrowed;
2598 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2600 AMT * const amtp = (AMT*)mg->mg_ptr;
2601 PERL_UNUSED_ARG(sv);
2603 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2605 if (amtp && AMT_AMAGIC(amtp)) {
2607 for (i = 1; i < NofAMmeth; i++) {
2608 CV * const cv = amtp->table[i];
2610 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2611 amtp->table[i] = NULL;
2618 /* Updates and caches the CV's */
2620 * 1 on success and there is some overload
2621 * 0 if there is no overload
2622 * -1 if some error occurred and it couldn't croak
2626 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2628 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2630 const struct mro_meta* stash_meta = HvMROMETA(stash);
2633 PERL_ARGS_ASSERT_GV_AMUPDATE;
2635 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2637 const AMT * const amtp = (AMT*)mg->mg_ptr;
2638 if (amtp->was_ok_sub == newgen) {
2639 return AMT_AMAGIC(amtp) ? 1 : 0;
2641 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2644 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2647 amt.was_ok_sub = newgen;
2648 amt.fallback = AMGfallNO;
2654 bool deref_seen = 0;
2657 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2659 /* Try to find via inheritance. */
2660 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2661 SV * const sv = gv ? GvSV(gv) : NULL;
2666 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2669 #ifdef PERL_DONT_CREATE_GVSV
2671 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2674 else if (SvTRUE(sv))
2675 /* don't need to set overloading here because fallback => 1
2676 * is the default setting for classes without overloading */
2677 amt.fallback=AMGfallYES;
2678 else if (SvOK(sv)) {
2679 amt.fallback=AMGfallNEVER;
2686 assert(SvOOK(stash));
2687 /* initially assume the worst */
2688 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2690 for (i = 1; i < NofAMmeth; i++) {
2691 const char * const cooky = PL_AMG_names[i];
2692 /* Human-readable form, for debugging: */
2693 const char * const cp = AMG_id2name(i);
2694 const STRLEN l = PL_AMG_namelens[i];
2696 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2697 cp, HvNAME_get(stash)) );
2698 /* don't fill the cache while looking up!
2699 Creation of inheritance stubs in intermediate packages may
2700 conflict with the logic of runtime method substitution.
2701 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2702 then we could have created stubs for "(+0" in A and C too.
2703 But if B overloads "bool", we may want to use it for
2704 numifying instead of C's "+0". */
2705 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2707 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2708 const HEK * const gvhek =
2709 CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
2710 const HEK * const stashek =
2711 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2712 if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
2713 && stashek && HEK_LEN(stashek) == 8
2714 && strEQ(HEK_KEY(stashek), "overload")) {
2715 /* This is a hack to support autoloading..., while
2716 knowing *which* methods were declared as overloaded. */
2717 /* GvSV contains the name of the method. */
2719 SV *gvsv = GvSV(gv);
2721 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2722 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2723 (void*)GvSV(gv), cp, HvNAME(stash)) );
2724 if (!gvsv || !SvPOK(gvsv)
2725 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2727 /* Can be an import stub (created by "can"). */
2732 const SV * const name = (gvsv && SvPOK(gvsv))
2734 : newSVpvs_flags("???", SVs_TEMP);
2735 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2736 Perl_croak(aTHX_ "%s method \"%"SVf256
2737 "\" overloading \"%s\" "\
2738 "in package \"%"HEKf256"\"",
2739 (GvCVGEN(gv) ? "Stub found while resolving"
2747 cv = GvCV(gv = ngv);
2749 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2750 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2751 GvNAME(CvGV(cv))) );
2753 } else if (gv) { /* Autoloaded... */
2754 cv = MUTABLE_CV(gv);
2757 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2773 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2774 * NB - aux var invalid here, HvARRAY() could have been
2775 * reallocated since it was assigned to */
2776 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2779 AMT_AMAGIC_on(&amt);
2780 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2781 (char*)&amt, sizeof(AMT));
2785 /* Here we have no table: */
2787 AMT_AMAGIC_off(&amt);
2788 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2789 (char*)&amt, sizeof(AMTS));
2795 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2800 struct mro_meta* stash_meta;
2802 if (!stash || !HvNAME_get(stash))
2805 stash_meta = HvMROMETA(stash);
2806 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2808 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2811 if (Gv_AMupdate(stash, 0) == -1)
2813 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2816 amtp = (AMT*)mg->mg_ptr;
2817 if ( amtp->was_ok_sub != newgen )
2819 if (AMT_AMAGIC(amtp)) {
2820 CV * const ret = amtp->table[id];
2821 if (ret && isGV(ret)) { /* Autoloading stab */
2822 /* Passing it through may have resulted in a warning
2823 "Inherited AUTOLOAD for a non-method deprecated", since
2824 our caller is going through a function call, not a method call.
2825 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2826 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2838 /* Implement tryAMAGICun_MG macro.
2839 Do get magic, then see if the stack arg is overloaded and if so call it.
2841 AMGf_set return the arg using SETs rather than assigning to
2843 AMGf_numeric apply sv_2num to the stack arg.
2847 Perl_try_amagic_un(pTHX_ int method, int flags) {
2850 SV* const arg = TOPs;
2854 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2855 AMGf_noright | AMGf_unary
2856 | (flags & AMGf_numarg))))
2858 if (flags & AMGf_set) {
2863 if (SvPADMY(TARG)) {
2864 sv_setsv(TARG, tmpsv);
2874 if ((flags & AMGf_numeric) && SvROK(arg))
2880 /* Implement tryAMAGICbin_MG macro.
2881 Do get magic, then see if the two stack args are overloaded and if so
2884 AMGf_set return the arg using SETs rather than assigning to
2886 AMGf_assign op may be called as mutator (eg +=)
2887 AMGf_numeric apply sv_2num to the stack arg.
2891 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2893 SV* const left = TOPm1s;
2894 SV* const right = TOPs;
2900 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2901 SV * const tmpsv = amagic_call(left, right, method,
2902 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
2903 | (flags & AMGf_numarg));
2905 if (flags & AMGf_set) {
2912 if (opASSIGN || SvPADMY(TARG)) {
2913 sv_setsv(TARG, tmpsv);
2923 if(left==right && SvGMAGICAL(left)) {
2924 SV * const left = sv_newmortal();
2926 /* Print the uninitialized warning now, so it includes the vari-
2929 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2930 sv_setsv_flags(left, &PL_sv_no, 0);
2932 else sv_setsv_flags(left, right, 0);
2935 if (flags & AMGf_numeric) {
2937 *(sp-1) = sv_2num(TOPm1s);
2939 *sp = sv_2num(right);
2945 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2949 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2953 /* return quickly if none of the deref ops are overloaded */
2954 stash = SvSTASH(SvRV(ref));
2955 assert(SvOOK(stash));
2956 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
2959 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
2960 AMGf_noright | AMGf_unary))) {
2962 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2963 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2964 /* Bail out if it returns us the same reference. */
2971 return tmpsv ? tmpsv : ref;
2975 Perl_amagic_is_enabled(pTHX_ int method)
2977 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2979 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2981 if ( !lex_mask || !SvOK(lex_mask) )
2982 /* overloading lexically disabled */
2984 else if ( lex_mask && SvPOK(lex_mask) ) {
2985 /* we have an entry in the hints hash, check if method has been
2986 * masked by overloading.pm */
2988 const int offset = method / 8;
2989 const int bit = method % 8;
2990 char *pv = SvPV(lex_mask, len);
2992 /* Bit set, so this overloading operator is disabled */
2993 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3000 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3005 CV **cvp=NULL, **ocvp=NULL;
3006 AMT *amtp=NULL, *oamtp=NULL;
3007 int off = 0, off1, lr = 0, notfound = 0;
3008 int postpr = 0, force_cpy = 0;
3009 int assign = AMGf_assign & flags;
3010 const int assignshift = assign ? 1 : 0;
3011 int use_default_op = 0;
3012 int force_scalar = 0;
3018 PERL_ARGS_ASSERT_AMAGIC_CALL;
3020 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3021 if (!amagic_is_enabled(method)) return NULL;
3024 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3025 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3026 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3027 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3028 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3030 && ((cv = cvp[off=method+assignshift])
3031 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3037 cv = cvp[off=method])))) {
3038 lr = -1; /* Call method for left argument */
3040 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3043 /* look for substituted methods */
3044 /* In all the covered cases we should be called with assign==0. */
3048 if ((cv = cvp[off=add_ass_amg])
3049 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3050 right = &PL_sv_yes; lr = -1; assign = 1;
3055 if ((cv = cvp[off = subtr_ass_amg])
3056 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3057 right = &PL_sv_yes; lr = -1; assign = 1;
3061 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3064 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3067 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3070 (void)((cv = cvp[off=bool__amg])
3071 || (cv = cvp[off=numer_amg])
3072 || (cv = cvp[off=string_amg]));
3079 * SV* ref causes confusion with the interpreter variable of
3082 SV* const tmpRef=SvRV(left);
3083 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3085 * Just to be extra cautious. Maybe in some
3086 * additional cases sv_setsv is safe, too.
3088 SV* const newref = newSVsv(tmpRef);
3089 SvOBJECT_on(newref);
3090 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3091 delegate to the stash. */
3092 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3098 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3099 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3100 SV* const nullsv=sv_2mortal(newSViv(0));
3102 SV* const lessp = amagic_call(left,nullsv,
3103 lt_amg,AMGf_noright);
3104 logic = SvTRUE(lessp);
3106 SV* const lessp = amagic_call(left,nullsv,
3107 ncmp_amg,AMGf_noright);
3108 logic = (SvNV(lessp) < 0);
3111 if (off==subtr_amg) {
3122 if ((cv = cvp[off=subtr_amg])) {
3124 left = sv_2mortal(newSViv(0));
3129 case iter_amg: /* XXXX Eventually should do to_gv. */
3130 case ftest_amg: /* XXXX Eventually should do to_gv. */
3133 return NULL; /* Delegate operation to standard mechanisms. */
3141 return left; /* Delegate operation to standard mechanisms. */
3146 if (!cv) goto not_found;
3147 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3148 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3149 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3150 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3151 ? (amtp = (AMT*)mg->mg_ptr)->table
3153 && (cv = cvp[off=method])) { /* Method for right
3156 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3157 || (ocvp && oamtp->fallback > AMGfallNEVER))
3158 && !(flags & AMGf_unary)) {
3159 /* We look for substitution for
3160 * comparison operations and
3162 if (method==concat_amg || method==concat_ass_amg
3163 || method==repeat_amg || method==repeat_ass_amg) {
3164 return NULL; /* Delegate operation to string conversion */
3186 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3190 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3200 not_found: /* No method found, either report or croak */
3208 return left; /* Delegate operation to standard mechanisms. */
3210 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3211 notfound = 1; lr = -1;
3212 } else if (cvp && (cv=cvp[nomethod_amg])) {
3213 notfound = 1; lr = 1;
3214 } else if ((use_default_op =
3215 (!ocvp || oamtp->fallback >= AMGfallYES)
3216 && (!cvp || amtp->fallback >= AMGfallYES))
3218 /* Skip generating the "no method found" message. */
3222 if (off==-1) off=method;
3223 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3224 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
3225 AMG_id2name(method + assignshift),
3226 (flags & AMGf_unary ? " " : "\n\tleft "),
3228 "in overloaded package ":
3229 "has no overloaded magic",
3231 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3234 ",\n\tright argument in overloaded package ":
3237 : ",\n\tright argument has no overloaded magic"),
3239 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3240 SVfARG(&PL_sv_no)));
3241 if (use_default_op) {
3242 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
3244 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
3248 force_cpy = force_cpy || assign;
3253 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3254 * operation. we need this to return a value, so that it can be assigned
3255 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3256 * increment or decrement was itself called in void context */
3262 if (off == subtr_amg)
3265 /* in these cases, we're calling an assignment variant of an operator
3266 * (+= rather than +, for instance). regardless of whether it's a
3267 * fallback or not, it always has to return a value, which will be
3268 * assigned to the proper variable later */
3288 /* the copy constructor always needs to return a value */
3292 /* because of the way these are implemented (they don't perform the
3293 * dereferencing themselves, they return a reference that perl then
3294 * dereferences later), they always have to be in scalar context */
3302 /* these don't have an op of their own; they're triggered by their parent
3303 * op, so the context there isn't meaningful ('$a and foo()' in void
3304 * context still needs to pass scalar context on to $a's bool overload) */
3314 DEBUG_o(Perl_deb(aTHX_
3315 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
3317 method+assignshift==off? "" :
3319 method+assignshift==off? "" :
3320 AMG_id2name(method+assignshift),
3321 method+assignshift==off? "" : "\")",
3322 flags & AMGf_unary? "" :
3323 lr==1 ? " for right argument": " for left argument",
3324 flags & AMGf_unary? " for argument" : "",
3325 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3326 fl? ",\n\tassignment variant used": "") );
3329 /* Since we use shallow copy during assignment, we need
3330 * to dublicate the contents, probably calling user-supplied
3331 * version of copy operator
3333 /* We need to copy in following cases:
3334 * a) Assignment form was called.
3335 * assignshift==1, assign==T, method + 1 == off
3336 * b) Increment or decrement, called directly.
3337 * assignshift==0, assign==0, method + 0 == off
3338 * c) Increment or decrement, translated to assignment add/subtr.
3339 * assignshift==0, assign==T,
3341 * d) Increment or decrement, translated to nomethod.
3342 * assignshift==0, assign==0,
3344 * e) Assignment form translated to nomethod.
3345 * assignshift==1, assign==T, method + 1 != off
3348 /* off is method, method+assignshift, or a result of opcode substitution.
3349 * In the latter case assignshift==0, so only notfound case is important.
3351 if ( (lr == -1) && ( ( (method + assignshift == off)
3352 && (assign || (method == inc_amg) || (method == dec_amg)))
3355 /* newSVsv does not behave as advertised, so we copy missing
3356 * information by hand */
3357 SV *tmpRef = SvRV(left);
3359 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3360 SvRV_set(left, rv_copy);
3362 SvREFCNT_dec_NN(tmpRef);
3370 const bool oldcatch = CATCH_GET;
3372 U8 gimme = force_scalar ? G_SCALAR : GIMME_V;
3375 Zero(&myop, 1, BINOP);
3376 myop.op_last = (OP *) &myop;
3377 myop.op_next = NULL;
3378 myop.op_flags = OPf_STACKED;
3382 myop.op_flags |= OPf_WANT_VOID;
3385 if (flags & AMGf_want_list) {
3386 myop.op_flags |= OPf_WANT_LIST;
3391 myop.op_flags |= OPf_WANT_SCALAR;
3395 PUSHSTACKi(PERLSI_OVERLOAD);
3398 PL_op = (OP *) &myop;
3399 if (PERLDB_SUB && PL_curstash != PL_debstash)
3400 PL_op->op_private |= OPpENTERSUB_DB;
3401 Perl_pp_pushmark(aTHX);
3403 EXTEND(SP, notfound + 5);
3404 PUSHs(lr>0? right: left);
3405 PUSHs(lr>0? left: right);
3406 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3408 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3409 AMG_id2namelen(method + assignshift), SVs_TEMP));
3411 else if (flags & AMGf_numarg)
3412 PUSHs(&PL_sv_undef);
3413 if (flags & AMGf_numarg)
3415 PUSHs(MUTABLE_SV(cv));
3419 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3423 nret = SP - (PL_stack_base + oldmark);
3427 /* returning NULL has another meaning, and we check the context
3428 * at the call site too, so this can be differentiated from the
3431 SP = PL_stack_base + oldmark;
3434 if (flags & AMGf_want_list) {
3435 res = sv_2mortal((SV *)newAV());
3436 av_extend((AV *)res, nret);
3438 av_store((AV *)res, nret, POPs);
3450 CATCH_SET(oldcatch);
3457 ans=SvIV(res)<=0; break;
3460 ans=SvIV(res)<0; break;
3463 ans=SvIV(res)>=0; break;
3466 ans=SvIV(res)>0; break;
3469 ans=SvIV(res)==0; break;
3472 ans=SvIV(res)!=0; break;
3475 SvSetSV(left,res); return left;
3477 ans=!SvTRUE(res); break;
3482 } else if (method==copy_amg) {
3484 Perl_croak(aTHX_ "Copy method did not return a reference");
3486 return SvREFCNT_inc(SvRV(res));
3494 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3499 PERL_ARGS_ASSERT_GV_NAME_SET;
3502 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3504 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3505 unshare_hek(GvNAME_HEK(gv));
3508 PERL_HASH(hash, name, len);
3509 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3513 =for apidoc gv_try_downgrade
3515 If the typeglob C<gv> can be expressed more succinctly, by having
3516 something other than a real GV in its place in the stash, replace it
3517 with the optimised form. Basic requirements for this are that C<gv>
3518 is a real typeglob, is sufficiently ordinary, and is only referenced
3519 from its package. This function is meant to be used when a GV has been
3520 looked up in part to see what was there, causing upgrading, but based
3521 on what was found it turns out that the real GV isn't required after all.
3523 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3525 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3526 sub, the typeglob is replaced with a scalar-reference placeholder that
3527 more compactly represents the same thing.
3533 Perl_gv_try_downgrade(pTHX_ GV *gv)
3539 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3541 /* XXX Why and where does this leave dangling pointers during global
3543 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3545 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3546 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3547 isGV_with_GP(gv) && GvGP(gv) &&
3548 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3549 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3550 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3552 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3554 if (SvMAGICAL(gv)) {
3556 /* only backref magic is allowed */
3557 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3559 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3560 if (mg->mg_type != PERL_MAGIC_backref)
3566 HEK *gvnhek = GvNAME_HEK(gv);
3567 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3568 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3569 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3570 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3571 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3572 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3573 (namehek = GvNAME_HEK(gv)) &&
3574 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3576 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3577 const bool imported = !!GvIMPORTED_CV(gv);
3581 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3583 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3584 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3585 STRUCT_OFFSET(XPVIV, xiv_iv));
3586 SvRV_set(gv, value);
3591 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3593 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3595 PERL_ARGS_ASSERT_GV_OVERRIDE;
3596 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3597 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3598 gv = gvp ? *gvp : NULL;
3599 if (gv && !isGV(gv)) {
3600 if (!SvPCS_IMPORTED(gv)) return NULL;
3601 gv_init(gv, PL_globalstash, name, len, 0);
3604 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3610 core_xsub(pTHX_ CV* cv)
3613 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3618 * ex: set ts=8 sts=4 sw=4 et: