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.
39 #include "overload.inc"
43 static const char S_autoload[] = "AUTOLOAD";
44 #define S_autolen (sizeof("AUTOLOAD")-1)
47 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
54 SvTYPE((const SV *)gv) != SVt_PVGV
55 && SvTYPE((const SV *)gv) != SVt_PVLV
59 if (type == SVt_PVIO) {
61 * if it walks like a dirhandle, then let's assume that
62 * this is a dirhandle.
64 what = OP_IS_DIRHOP(PL_op->op_type) ?
65 "dirhandle" : "filehandle";
66 } else if (type == SVt_PVHV) {
69 what = type == SVt_PVAV ? "array" : "scalar";
71 /* diag_listed_as: Bad symbol for filehandle */
72 Perl_croak(aTHX_ "Bad symbol for %s", what);
75 if (type == SVt_PVHV) {
76 where = (SV **)&GvHV(gv);
77 } else if (type == SVt_PVAV) {
78 where = (SV **)&GvAV(gv);
79 } else if (type == SVt_PVIO) {
80 where = (SV **)&GvIOp(gv);
87 *where = newSV_type(type);
89 && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
90 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
96 Perl_gv_fetchfile(pTHX_ const char *name)
98 PERL_ARGS_ASSERT_GV_FETCHFILE;
99 return gv_fetchfile_flags(name, strlen(name), 0);
103 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_OR_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;
158 if (SvTYPE(gv) == SVt_PVGV)
159 return cv_const_sv(GvCVu(gv));
160 return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
164 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 = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
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))) {
242 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
243 assert(!CvCVGV_RC(cv));
248 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
249 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
252 SvREFCNT_inc_simple_void_NN(gv);
256 /* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
257 GV, but for efficiency that GV may not in fact exist. This function,
258 called by CvGV, reifies it. */
261 Perl_cvgv_from_hek(pTHX_ CV *cv)
265 PERL_ARGS_ASSERT_CVGV_FROM_HEK;
266 assert(SvTYPE(cv) == SVt_PVCV);
267 if (!CvSTASH(cv)) return NULL;
268 ASSUME(CvNAME_HEK(cv));
269 svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
270 gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
272 gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
273 HEK_LEN(CvNAME_HEK(cv)),
274 SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
275 if (!CvNAMED(cv)) { /* gv_init took care of it */
276 assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
279 unshare_hek(CvNAME_HEK(cv));
281 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
282 if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
287 /* Assign CvSTASH(cv) = st, handling weak references. */
290 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
292 HV *oldst = CvSTASH(cv);
293 PERL_ARGS_ASSERT_CVSTASH_SET;
297 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
298 SvANY(cv)->xcv_stash = st;
300 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
304 =for apidoc gv_init_pvn
306 Converts a scalar into a typeglob. This is an incoercible typeglob;
307 assigning a reference to it will assign to one of its slots, instead of
308 overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
309 any scalar that is C<SvOK()> may produce unpredictable results and is reserved
310 for perl's internal use.
312 C<gv> is the scalar to be converted.
314 C<stash> is the parent stash/package, if any.
316 C<name> and C<len> give the name. The name must be unqualified;
317 that is, it must not include the package name. If C<gv> is a
318 stash element, it is the caller's responsibility to ensure that the name
319 passed to this function matches the name of the element. If it does not
320 match, perl's internal bookkeeping will get out of sync.
322 C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
323 the return value of SvUTF8(sv). It can also take the
324 C<GV_ADDMULTI> flag, which means to pretend that the GV has been
325 seen before (i.e., suppress "Used once" warnings).
327 =for apidoc Amnh||GV_ADDMULTI
331 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
332 has no flags parameter. If the C<multi> parameter is set, the
333 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
335 =for apidoc gv_init_pv
337 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
338 instead of separate char * and length parameters.
340 =for apidoc gv_init_sv
342 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
343 char * and length parameters. C<flags> is currently unused.
349 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
353 PERL_ARGS_ASSERT_GV_INIT_SV;
354 namepv = SvPV(namesv, namelen);
357 gv_init_pvn(gv, stash, namepv, namelen, flags);
361 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
363 PERL_ARGS_ASSERT_GV_INIT_PV;
364 gv_init_pvn(gv, stash, name, strlen(name), flags);
368 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
370 const U32 old_type = SvTYPE(gv);
371 const bool doproto = old_type > SVt_NULL;
372 char * const proto = (doproto && SvPOK(gv))
373 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
375 const STRLEN protolen = proto ? SvCUR(gv) : 0;
376 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
377 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
378 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
379 const bool really_sub =
380 has_constant && SvTYPE(has_constant) == SVt_PVCV;
381 COP * const old = PL_curcop;
383 PERL_ARGS_ASSERT_GV_INIT_PVN;
384 assert (!(proto && has_constant));
387 /* The constant has to be a scalar, array or subroutine. */
388 switch (SvTYPE(has_constant)) {
392 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
393 sv_reftype(has_constant, 0));
394 NOT_REACHED; /* NOTREACHED */
404 if (old_type < SVt_PVGV) {
405 if (old_type >= SVt_PV)
407 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
415 Safefree(SvPVX_mutable(gv));
420 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
421 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
422 || CvSTART(has_constant)->op_type == OP_DBSTATE))
423 PL_curcop = (COP *)CvSTART(has_constant);
424 GvGP_set(gv, Perl_newGP(aTHX_ gv));
428 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
429 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
430 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
431 GvMULTI_on(gv); /* _was_ mentioned */
433 /* Not actually a constant. Just a regular sub. */
434 CV * const cv = (CV *)has_constant;
436 if (CvNAMED(cv) && CvSTASH(cv) == stash && (
437 CvNAME_HEK(cv) == GvNAME_HEK(gv)
438 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
439 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
440 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
441 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
449 /* newCONSTSUB takes ownership of the reference from us. */
450 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
451 /* In case op.c:S_process_special_blocks stole it: */
453 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
454 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
455 /* If this reference was a copy of another, then the subroutine
456 must have been "imported", by a Perl space assignment to a GV
457 from a reference to CV. */
458 if (exported_constant)
459 GvIMPORTED_CV_on(gv);
460 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
465 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
466 SV_HAS_TRAILING_NUL);
467 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
473 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
475 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
487 #ifdef PERL_DONT_CREATE_GVSV
495 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
496 If we just cast GvSVn(gv) to void, it ignores evaluating it for
503 static void core_xsub(pTHX_ CV* cv);
506 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
507 const char * const name, const STRLEN len)
509 const int code = keyword(name, len, 1);
510 static const char file[] = __FILE__;
511 CV *cv, *oldcompcv = NULL;
513 bool ampable = TRUE; /* &{}-able */
514 COP *oldcurcop = NULL;
515 yy_parser *oldparser = NULL;
516 I32 oldsavestack_ix = 0;
521 if (!code) return NULL; /* Not a keyword */
522 switch (code < 0 ? -code : code) {
523 /* no support for \&CORE::infix;
524 no support for funcs that do not parse like funcs */
525 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
526 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
527 case KEY_default : case KEY_DESTROY:
528 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
529 case KEY_END : case KEY_eq : case KEY_eval :
530 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
531 case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt :
532 case KEY_if : case KEY_isa : case KEY_INIT : case KEY_last :
533 case KEY_le : case KEY_local : case KEY_lt : case KEY_m :
534 case KEY_map : case KEY_my:
535 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
536 case KEY_package: case KEY_print: case KEY_printf:
537 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
538 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
539 case KEY_s : case KEY_say : case KEY_sort :
540 case KEY_state: case KEY_sub :
541 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
542 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
543 case KEY_x : case KEY_xor : case KEY_y :
546 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
547 case KEY_eof : case KEY_exec: case KEY_exists :
552 case KEY_truncate: case KEY_unlink:
557 gv_init(gv, stash, name, len, TRUE);
562 oldcurcop = PL_curcop;
563 oldparser = PL_parser;
564 lex_start(NULL, NULL, 0);
565 oldcompcv = PL_compcv;
566 PL_compcv = NULL; /* Prevent start_subparse from setting
568 oldsavestack_ix = start_subparse(FALSE,0);
572 /* Avoid calling newXS, as it calls us, and things start to
574 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
578 CvXSUB(cv) = core_xsub;
581 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
583 /* XSUBs can't be perl lang/perl5db.pl debugged
584 if (PERLDB_LINE_OR_SAVESRC)
585 (void)gv_fetchfile(file); */
586 CvFILE(cv) = (char *)file;
587 /* XXX This is inefficient, as doing things this order causes
588 a prototype check in newATTRSUB. But we have to do
589 it this order as we need an op number before calling
591 (void)core_prototype((SV *)cv, name, code, &opnum);
593 (void)hv_store(stash,name,len,(SV *)gv,0);
599 /* newATTRSUB will free the CV and return NULL if we're still
600 compiling after a syntax error */
601 if ((cv = newATTRSUB_x(
602 oldsavestack_ix, (OP *)gv,
607 : newSVpvn(name,len),
612 assert(GvCV(gv) == orig_cv);
613 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
614 && opnum != OP_UNDEF && opnum != OP_KEYS)
615 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
618 PL_parser = oldparser;
619 PL_curcop = oldcurcop;
620 PL_compcv = oldcompcv;
623 SV *opnumsv = newSViv(
624 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
625 (OP_ENTEREVAL | (1<<16))
626 : opnum ? opnum : (((I32)name[2]) << 16));
627 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
628 SvREFCNT_dec_NN(opnumsv);
635 =for apidoc gv_fetchmeth
637 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
639 =for apidoc gv_fetchmeth_sv
641 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
642 of an SV instead of a string/length pair.
648 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
652 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
653 if (LIKELY(SvPOK_nog(namesv))) /* common case */
654 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
655 flags | SvUTF8(namesv));
656 namepv = SvPV(namesv, namelen);
657 if (SvUTF8(namesv)) flags |= SVf_UTF8;
658 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
662 =for apidoc gv_fetchmeth_pv
664 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
665 instead of a string/length pair.
671 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
673 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
674 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
678 =for apidoc gv_fetchmeth_pvn
680 Returns the glob with the given C<name> and a defined subroutine or
681 C<NULL>. The glob lives in the given C<stash>, or in the stashes
682 accessible via C<@ISA> and C<UNIVERSAL::>.
684 The argument C<level> should be either 0 or -1. If C<level==0>, as a
685 side-effect creates a glob with the given C<name> in the given C<stash>
686 which in the case of success contains an alias for the subroutine, and sets
687 up caching info for this glob.
689 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
691 C<GV_SUPER> indicates that we want to look up the method in the superclasses
695 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
696 visible to Perl code. So when calling C<call_sv>, you should not use
697 the GV directly; instead, you should use the method's CV, which can be
698 obtained from the GV with the C<GvCV> macro.
700 =for apidoc Amnh||GV_SUPER
705 /* NOTE: No support for tied ISA */
707 PERL_STATIC_INLINE GV*
708 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
715 HV* cstash, *cachestash;
716 GV* candidate = NULL;
721 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
724 U32 is_utf8 = flags & SVf_UTF8;
726 /* UNIVERSAL methods should be callable without a stash */
728 create = 0; /* probably appropriate */
729 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
735 hvname = HvNAME_get(stash);
736 hvnamelen = HvNAMELEN_get(stash);
738 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
741 assert(name || meth);
743 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
744 flags & GV_SUPER ? "SUPER " : "",
745 name ? name : SvPV_nolen(meth), hvname) );
747 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
749 if (flags & GV_SUPER) {
750 if (!HvAUX(stash)->xhv_mro_meta->super)
751 HvAUX(stash)->xhv_mro_meta->super = newHV();
752 cachestash = HvAUX(stash)->xhv_mro_meta->super;
754 else cachestash = stash;
756 /* check locally for a real method or a cache entry */
758 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
760 if (he) gvp = (GV**)&HeVAL(he);
767 if (SvTYPE(topgv) != SVt_PVGV)
770 name = SvPV_nomg(meth, len);
771 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
773 if ((cand_cv = GvCV(topgv))) {
774 /* If genuine method or valid cache entry, use it */
775 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
779 /* stale cache entry, junk it and move on */
780 SvREFCNT_dec_NN(cand_cv);
781 GvCV_set(topgv, NULL);
786 else if (GvCVGEN(topgv) == topgen_cmp) {
787 /* cache indicates no such method definitively */
790 else if (stash == cachestash
791 && len > 1 /* shortest is uc */
792 && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
793 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
797 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
798 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
799 items = AvFILLp(linear_av); /* no +1, to skip over self */
801 linear_sv = *linear_svp++;
803 cstash = gv_stashsv(linear_sv, 0);
806 if ( ckWARN(WARN_SYNTAX)) {
807 if( /* these are loaded from Perl_Gv_AMupdate() one way or another */
808 ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */
809 || ( memEQs( name, len, "DESTROY") )
811 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
812 "Can't locate package %" SVf " for @%" HEKf "::ISA",
814 HEKfARG(HvNAME_HEK(stash)));
816 } else if( memEQs( name, len, "AUTOLOAD") ) {
817 /* gobble this warning */
819 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
820 "While trying to resolve method call %.*s->%.*s()"
821 " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA"
822 " (perhaps you forgot to load \"%" SVf "\"?)",
823 (int) hvnamelen, hvname,
826 (int) hvnamelen, hvname,
835 gvp = (GV**)hv_common(
836 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
839 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
840 const char *hvname = HvNAME(cstash); assert(hvname);
841 if (strBEGINs(hvname, "CORE")
843 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
849 else candidate = *gvp;
852 if (SvTYPE(candidate) != SVt_PVGV)
853 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
854 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
856 * Found real method, cache method in topgv if:
857 * 1. topgv has no synonyms (else inheritance crosses wires)
858 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
860 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
861 CV *old_cv = GvCV(topgv);
862 SvREFCNT_dec(old_cv);
863 SvREFCNT_inc_simple_void_NN(cand_cv);
864 GvCV_set(topgv, cand_cv);
865 GvCVGEN(topgv) = topgen_cmp;
871 /* Check UNIVERSAL without caching */
872 if(level == 0 || level == -1) {
873 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
876 cand_cv = GvCV(candidate);
877 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
878 CV *old_cv = GvCV(topgv);
879 SvREFCNT_dec(old_cv);
880 SvREFCNT_inc_simple_void_NN(cand_cv);
881 GvCV_set(topgv, cand_cv);
882 GvCVGEN(topgv) = topgen_cmp;
888 if (topgv && GvREFCNT(topgv) == 1) {
889 /* cache the fact that the method is not defined */
890 GvCVGEN(topgv) = topgen_cmp;
897 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
899 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
900 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
904 =for apidoc gv_fetchmeth_autoload
906 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
909 =for apidoc gv_fetchmeth_sv_autoload
911 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
912 of an SV instead of a string/length pair.
918 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
922 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
923 namepv = SvPV(namesv, namelen);
926 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
930 =for apidoc gv_fetchmeth_pv_autoload
932 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
933 instead of a string/length pair.
939 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
941 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
942 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
946 =for apidoc gv_fetchmeth_pvn_autoload
948 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
949 Returns a glob for the subroutine.
951 For an autoloaded subroutine without a GV, will create a GV even
952 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
953 of the result may be zero.
955 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
961 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
963 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
965 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
972 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
973 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
975 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
978 if (!(CvROOT(cv) || CvXSUB(cv)))
980 /* Have an autoload */
981 if (level < 0) /* Cannot do without a stub */
982 gv_fetchmeth_pvn(stash, name, len, 0, flags);
983 gvp = (GV**)hv_fetch(stash, name,
984 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
993 =for apidoc gv_fetchmethod_autoload
995 Returns the glob which contains the subroutine to call to invoke the method
996 on the C<stash>. In fact in the presence of autoloading this may be the
997 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
1000 The third parameter of C<gv_fetchmethod_autoload> determines whether
1001 AUTOLOAD lookup is performed if the given method is not present: non-zero
1002 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1003 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1004 with a non-zero C<autoload> parameter.
1006 These functions grant C<"SUPER"> token
1007 as a prefix of the method name. Note
1008 that if you want to keep the returned glob for a long time, you need to
1009 check for it being "AUTOLOAD", since at the later time the call may load a
1010 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
1011 created as a side effect to do this.
1013 These functions have the same side-effects as C<gv_fetchmeth> with
1014 C<level==0>. The warning against passing the GV returned by
1015 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1021 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1023 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1025 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1029 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1033 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1034 namepv = SvPV(namesv, namelen);
1037 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1041 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1043 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1044 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1048 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1050 const char * const origname = name;
1051 const char * const name_end = name + len;
1052 const char *last_separator = NULL;
1055 SV *const error_report = MUTABLE_SV(stash);
1056 const U32 autoload = flags & GV_AUTOLOAD;
1057 const U32 do_croak = flags & GV_CROAK;
1058 const U32 is_utf8 = flags & SVf_UTF8;
1060 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1062 if (SvTYPE(stash) < SVt_PVHV)
1065 /* The only way stash can become NULL later on is if last_separator is set,
1066 which in turn means that there is no need for a SVt_PVHV case
1067 the error reporting code. */
1071 /* check if the method name is fully qualified or
1072 * not, and separate the package name from the actual
1075 * leaves last_separator pointing to the beginning of the
1076 * last package separator (either ' or ::) or 0
1077 * if none was found.
1079 * leaves name pointing at the beginning of the
1082 const char *name_cursor = name;
1083 const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1084 for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1085 if (*name_cursor == '\'') {
1086 last_separator = name_cursor;
1087 name = name_cursor + 1;
1089 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1090 last_separator = name_cursor++;
1091 name = name_cursor + 1;
1096 /* did we find a separator? */
1097 if (last_separator) {
1098 STRLEN sep_len= last_separator - origname;
1099 if ( memEQs(origname, sep_len, "SUPER")) {
1100 /* ->SUPER::method should really be looked up in original stash */
1101 stash = CopSTASH(PL_curcop);
1103 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1104 origname, HvENAME_get(stash), name) );
1106 else if ( sep_len >= 7 &&
1107 strBEGINs(last_separator - 7, "::SUPER")) {
1108 /* don't autovifify if ->NoSuchStash::SUPER::method */
1109 stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1110 if (stash) flags |= GV_SUPER;
1113 /* don't autovifify if ->NoSuchStash::method */
1114 stash = gv_stashpvn(origname, sep_len, is_utf8);
1119 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1121 /* This is the special case that exempts Foo->import and
1122 Foo->unimport from being an error even if there's no
1123 import/unimport subroutine */
1124 if (strEQ(name,"import") || strEQ(name,"unimport")) {
1125 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1127 } else if (autoload)
1128 gv = gv_autoload_pvn(
1129 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1131 if (!gv && do_croak) {
1132 /* Right now this is exclusively for the benefit of S_method_common
1135 /* If we can't find an IO::File method, it might be a call on
1136 * a filehandle. If IO:File has not been loaded, try to
1137 * require it first instead of croaking */
1138 const char *stash_name = HvNAME_get(stash);
1139 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1140 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1141 STR_WITH_LEN("IO/File.pm"), 0,
1142 HV_FETCH_ISEXISTS, NULL, 0)
1144 require_pv("IO/File.pm");
1145 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1150 "Can't locate object method \"%" UTF8f
1151 "\" via package \"%" HEKf "\"",
1152 UTF8fARG(is_utf8, name_end - name, name),
1153 HEKfARG(HvNAME_HEK(stash)));
1158 if (last_separator) {
1159 packnamesv = newSVpvn_flags(origname, last_separator - origname,
1160 SVs_TEMP | is_utf8);
1162 packnamesv = error_report;
1166 "Can't locate object method \"%" UTF8f
1167 "\" via package \"%" SVf "\""
1168 " (perhaps you forgot to load \"%" SVf "\"?)",
1169 UTF8fARG(is_utf8, name_end - name, name),
1170 SVfARG(packnamesv), SVfARG(packnamesv));
1174 else if (autoload) {
1175 CV* const cv = GvCV(gv);
1176 if (!CvROOT(cv) && !CvXSUB(cv)) {
1180 if (CvANON(cv) || CvLEXICAL(cv))
1184 if (GvCV(stubgv) != cv) /* orphaned import */
1187 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1188 GvNAME(stubgv), GvNAMELEN(stubgv),
1189 GV_AUTOLOAD_ISMETHOD
1190 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1200 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1204 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1205 namepv = SvPV(namesv, namelen);
1208 return gv_autoload_pvn(stash, namepv, namelen, flags);
1212 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1214 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1215 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1219 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1226 SV *packname = NULL;
1227 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1229 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1231 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1234 if (SvTYPE(stash) < SVt_PVHV) {
1235 STRLEN packname_len = 0;
1236 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1237 packname = newSVpvn_flags(packname_ptr, packname_len,
1238 SVs_TEMP | SvUTF8(stash));
1242 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1243 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1245 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1246 is_utf8 | (flags & GV_SUPER))))
1250 if (!(CvROOT(cv) || CvXSUB(cv)))
1254 * Inheriting AUTOLOAD for non-methods no longer works
1257 !(flags & GV_AUTOLOAD_ISMETHOD)
1258 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1260 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1261 "::%" UTF8f "() is no longer allowed",
1263 UTF8fARG(is_utf8, len, name));
1266 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1267 * and split that value on the last '::', pass along the same data
1268 * via the SvPVX field in the CV, and the stash in CvSTASH.
1270 * Due to an unfortunate accident of history, the SvPVX field
1271 * serves two purposes. It is also used for the subroutine's pro-
1272 * type. Since SvPVX has been documented as returning the sub name
1273 * for a long time, but not as returning the prototype, we have
1274 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1277 * We put the prototype in the same allocated buffer, but after
1278 * the sub name. The SvPOK flag indicates the presence of a proto-
1279 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1280 * If both flags are on, then SvLEN is used to indicate the end of
1281 * the prototype (artificially lower than what is actually allo-
1282 * cated), at the risk of having to reallocate a few bytes unneces-
1283 * sarily--but that should happen very rarely, if ever.
1285 * We use SvUTF8 for both prototypes and sub names, so if one is
1286 * UTF8, the other must be upgraded.
1288 CvSTASH_set(cv, stash);
1289 if (SvPOK(cv)) { /* Ouch! */
1290 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1292 const char *proto = CvPROTO(cv);
1295 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1296 ulen = SvCUR(tmpsv);
1297 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1299 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1301 SvTEMP_on(tmpsv); /* Allow theft */
1302 sv_setsv_nomg((SV *)cv, tmpsv);
1304 SvREFCNT_dec_NN(tmpsv);
1305 SvLEN_set(cv, SvCUR(cv) + 1);
1306 SvCUR_set(cv, ulen);
1309 sv_setpvn((SV *)cv, name, len);
1313 else SvUTF8_off(cv);
1319 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1320 * The subroutine's original name may not be "AUTOLOAD", so we don't
1321 * use that, but for lack of anything better we will use the sub's
1322 * original package to look up $AUTOLOAD.
1324 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1325 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1329 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1330 #ifdef PERL_DONT_CREATE_GVSV
1331 GvSV(vargv) = newSV(0);
1335 varsv = GvSVn(vargv);
1336 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1337 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1338 sv_setsv(varsv, packname);
1339 sv_catpvs(varsv, "::");
1340 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1341 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1344 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1352 /* require_tie_mod() internal routine for requiring a module
1353 * that implements the logic of automatic ties like %! and %-
1354 * It loads the module and then calls the _tie_it subroutine
1355 * with the passed gv as an argument.
1357 * The "gv" parameter should be the glob.
1358 * "varname" holds the 1-char name of the var, used for error messages.
1359 * "namesv" holds the module name. Its refcount will be decremented.
1360 * "flags": if flag & 1 then save the scalar before loading.
1361 * For the protection of $! to work (it is set by this routine)
1362 * the sv slot must already be magicalized.
1365 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1366 STRLEN len, const U32 flags)
1368 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1370 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1372 /* If it is not tied */
1373 if (!target || !SvRMAGICAL(target)
1375 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1381 PUSHSTACKi(PERLSI_MAGIC);
1384 #define GET_HV_FETCH_TIE_FUNC \
1385 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
1387 && ( (isGV(*gvp) && GvCV(*gvp)) \
1388 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
1391 /* Load the module if it is not loaded. */
1392 if (!(stash = gv_stashpvn(name, len, 0))
1393 || ! GET_HV_FETCH_TIE_FUNC)
1395 SV * const module = newSVpvn(name, len);
1396 const char type = varname == '[' ? '$' : '%';
1399 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1400 assert(sp == PL_stack_sp);
1401 stash = gv_stashpvn(name, len, 0);
1403 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1404 type, varname, name);
1405 else if (! GET_HV_FETCH_TIE_FUNC)
1406 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1407 type, varname, name);
1409 /* Now call the tie function. It should be in *gvp. */
1410 assert(gvp); assert(*gvp);
1414 call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1420 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1421 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1422 * a true string WITHOUT a len.
1424 #define require_tie_mod_s(gv, varname, name, flags) \
1425 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1428 =for apidoc gv_stashpv
1430 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1431 determine the length of C<name>, then calls C<gv_stashpvn()>.
1437 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1439 PERL_ARGS_ASSERT_GV_STASHPV;
1440 return gv_stashpvn(name, strlen(name), create);
1444 =for apidoc gv_stashpvn
1446 Returns a pointer to the stash for a specified package. The C<namelen>
1447 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1448 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1449 created if it does not already exist. If the package does not exist and
1450 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1453 Flags may be one of:
1462 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1464 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1465 recommended for performance reasons.
1467 =for apidoc Amnh||GV_ADD
1468 =for apidoc Amnh||GV_NOADD_NOINIT
1469 =for apidoc Amnh||GV_NOINIT
1470 =for apidoc Amnh||GV_NOEXPAND
1471 =for apidoc Amnh||GV_ADDMG
1472 =for apidoc Amnh||SVf_UTF8
1478 gv_stashpvn_internal
1480 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1481 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1485 PERL_STATIC_INLINE HV*
1486 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1492 U32 tmplen = namelen + 2;
1494 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1496 if (tmplen <= sizeof smallbuf)
1499 Newx(tmpbuf, tmplen, char);
1500 Copy(name, tmpbuf, namelen, char);
1501 tmpbuf[namelen] = ':';
1502 tmpbuf[namelen+1] = ':';
1503 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1504 if (tmpbuf != smallbuf)
1506 if (!tmpgv || !isGV_with_GP(tmpgv))
1508 stash = GvHV(tmpgv);
1509 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1511 if (!HvNAME_get(stash)) {
1512 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1514 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1515 /* If the containing stash has multiple effective
1516 names, see that this one gets them, too. */
1517 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1518 mro_package_moved(stash, NULL, tmpgv, 1);
1524 gv_stashsvpvn_cached
1526 Returns a pointer to the stash for a specified package, possibly
1527 cached. Implements both C<L</gv_stashpvn>> and C<L</gv_stashsv>>.
1529 Requires one of either C<namesv> or C<namepv> to be non-null.
1531 See C<L</gv_stashpvn>> for details on C<flags>.
1533 Note the sv interface is strongly preferred for performance reasons.
1537 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1538 assert(namesv || name)
1541 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1546 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1548 he = (HE *)hv_common(
1549 PL_stashcache, namesv, name, namelen,
1550 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1557 hv = INT2PTR(HV*, SvIVX(sv));
1558 assert(SvTYPE(hv) == SVt_PVHV);
1561 else if (flags & GV_CACHE_ONLY) return NULL;
1564 if (SvOK(namesv)) { /* prevent double uninit warning */
1566 name = SvPV_const(namesv, len);
1568 flags |= SvUTF8(namesv);
1570 name = ""; namelen = 0;
1573 stash = gv_stashpvn_internal(name, namelen, flags);
1575 if (stash && namelen) {
1576 SV* const ref = newSViv(PTR2IV(stash));
1577 (void)hv_store(PL_stashcache, name,
1578 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1585 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1587 PERL_ARGS_ASSERT_GV_STASHPVN;
1588 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1592 =for apidoc gv_stashsv
1594 Returns a pointer to the stash for a specified package. See
1597 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1604 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1606 PERL_ARGS_ASSERT_GV_STASHSV;
1607 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1610 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) {
1611 PERL_ARGS_ASSERT_GV_FETCHPV;
1612 return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type);
1616 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1618 const char * const nambeg =
1619 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1620 PERL_ARGS_ASSERT_GV_FETCHSV;
1621 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1624 PERL_STATIC_INLINE void
1625 S_gv_magicalize_isa(pTHX_ GV *gv)
1629 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1633 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1637 /* This function grabs name and tries to split a stash and glob
1638 * from its contents. TODO better description, comments
1640 * If the function returns TRUE and 'name == name_end', then
1641 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1643 PERL_STATIC_INLINE bool
1644 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1645 STRLEN *len, const char *nambeg, STRLEN full_len,
1646 const U32 is_utf8, const I32 add)
1648 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1649 const char *name_cursor;
1650 const char *const name_end = nambeg + full_len;
1651 const char *const name_em1 = name_end - 1;
1652 char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1654 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1658 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1660 /* accidental stringify on a GV? */
1664 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1665 if (name_cursor < name_em1 &&
1666 ((*name_cursor == ':' && name_cursor[1] == ':')
1667 || *name_cursor == '\''))
1670 *stash = PL_defstash;
1671 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1674 *len = name_cursor - *name;
1675 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1678 if (*name_cursor == ':') {
1682 else { /* using ' for package separator */
1683 /* use our pre-allocated buffer when possible to save a malloc */
1685 if ( *len+2 <= sizeof smallbuf)
1688 /* only malloc once if needed */
1689 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1690 Newx(tmpfullbuf, full_len+2, char);
1691 tmpbuf = tmpfullbuf;
1693 Copy(*name, tmpbuf, *len, char);
1694 tmpbuf[(*len)++] = ':';
1695 tmpbuf[(*len)++] = ':';
1698 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1699 *gv = gvp ? *gvp : NULL;
1700 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1703 /* here we know that *gv && *gv != &PL_sv_undef */
1704 if (SvTYPE(*gv) != SVt_PVGV)
1705 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1709 if (!(*stash = GvHV(*gv))) {
1710 *stash = GvHV(*gv) = newHV();
1711 if (!HvNAME_get(*stash)) {
1712 if (GvSTASH(*gv) == PL_defstash && *len == 6
1713 && strBEGINs(*name, "CORE"))
1714 hv_name_sets(*stash, "CORE", 0);
1717 *stash, nambeg, name_cursor-nambeg, is_utf8
1719 /* If the containing stash has multiple effective
1720 names, see that this one gets them, too. */
1721 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1722 mro_package_moved(*stash, NULL, *gv, 1);
1725 else if (!HvNAME_get(*stash))
1726 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1729 if (*name_cursor == ':')
1731 *name = name_cursor+1;
1732 if (*name == name_end) {
1734 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1735 if (SvTYPE(*gv) != SVt_PVGV) {
1736 gv_init_pvn(*gv, PL_defstash, "main::", 6,
1739 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1746 *len = name_cursor - *name;
1748 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1751 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1756 /* Checks if an unqualified name is in the main stash */
1757 PERL_STATIC_INLINE bool
1758 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1760 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1762 /* If it's an alphanumeric variable */
1763 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1764 /* Some "normal" variables are always in main::,
1765 * like INC or STDOUT.
1773 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1774 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1775 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1779 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1784 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1785 && name[3] == 'I' && name[4] == 'N')
1789 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1790 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1791 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1795 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1796 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1802 /* *{""}, or a special variable like $@ */
1810 /* This function is called if parse_gv_stash_name() failed to
1811 * find a stash, or if GV_NOTQUAL or an empty name was passed
1812 * to gv_fetchpvn_flags.
1814 * It returns FALSE if the default stash can't be found nor created,
1815 * which might happen during global destruction.
1817 PERL_STATIC_INLINE bool
1818 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1819 const U32 is_utf8, const I32 add,
1820 const svtype sv_type)
1822 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1824 /* No stash in name, so see how we can default */
1826 if ( gv_is_in_main(name, len, is_utf8) ) {
1827 *stash = PL_defstash;
1830 if (IN_PERL_COMPILETIME) {
1831 *stash = PL_curstash;
1832 if (add && (PL_hints & HINT_STRICT_VARS) &&
1833 sv_type != SVt_PVCV &&
1834 sv_type != SVt_PVGV &&
1835 sv_type != SVt_PVFM &&
1836 sv_type != SVt_PVIO &&
1837 !(len == 1 && sv_type == SVt_PV &&
1838 (*name == 'a' || *name == 'b')) )
1840 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1841 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1842 SvTYPE(*gvp) != SVt_PVGV)
1846 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1847 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1848 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1850 /* diag_listed_as: Variable "%s" is not imported%s */
1852 aTHX_ packWARN(WARN_MISC),
1853 "Variable \"%c%" UTF8f "\" is not imported",
1854 sv_type == SVt_PVAV ? '@' :
1855 sv_type == SVt_PVHV ? '%' : '$',
1856 UTF8fARG(is_utf8, len, name));
1859 aTHX_ packWARN(WARN_MISC),
1860 "\t(Did you mean &%" UTF8f " instead?)\n",
1861 UTF8fARG(is_utf8, len, name)
1868 /* Use the current op's stash */
1869 *stash = CopSTASH(PL_curcop);
1874 if (add && !PL_in_clean_all) {
1876 qerror(Perl_mess(aTHX_
1877 "Global symbol \"%s%" UTF8f
1878 "\" requires explicit package name (did you forget to "
1879 "declare \"my %s%" UTF8f "\"?)",
1880 (sv_type == SVt_PV ? "$"
1881 : sv_type == SVt_PVAV ? "@"
1882 : sv_type == SVt_PVHV ? "%"
1883 : ""), UTF8fARG(is_utf8, len, name),
1884 (sv_type == SVt_PV ? "$"
1885 : sv_type == SVt_PVAV ? "@"
1886 : sv_type == SVt_PVHV ? "%"
1887 : ""), UTF8fARG(is_utf8, len, name)));
1888 /* To maintain the output of errors after the strict exception
1889 * above, and to keep compat with older releases, rather than
1890 * placing the variables in the pad, we place
1891 * them in the <none>:: stash.
1893 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1895 /* symbol table under destruction */
1904 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1910 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
1911 redefine SvREADONLY_on for that purpose. We don’t use it later on in
1913 #undef SvREADONLY_on
1914 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1916 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1918 * Note that it does not insert the GV into the stash prior to
1919 * magicalization, which some variables require need in order
1920 * to work (like %+, %-, %!), so callers must take care of
1923 * It returns true if the gv did turn out to be magical one; i.e.,
1924 * if gv_magicalize actually did something.
1926 PERL_STATIC_INLINE bool
1927 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1928 const svtype sv_type)
1932 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1934 if (stash != PL_defstash) { /* not the main stash */
1935 /* We only have to check for a few names here: a, b, EXPORT, ISA
1936 and VERSION. All the others apply only to the main stash or to
1937 CORE (which is checked right after this). */
1942 len >= 6 && name[1] == 'X' &&
1943 (memEQs(name, len, "EXPORT")
1944 ||memEQs(name, len, "EXPORT_OK")
1945 ||memEQs(name, len, "EXPORT_FAIL")
1946 ||memEQs(name, len, "EXPORT_TAGS"))
1951 if (memEQs(name, len, "ISA"))
1952 gv_magicalize_isa(gv);
1955 if (memEQs(name, len, "VERSION"))
1959 if (stash == PL_debstash && memEQs(name, len, "args")) {
1960 GvMULTI_on(gv_AVadd(gv));
1965 if (len == 1 && sv_type == SVt_PV)
1974 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1975 /* Avoid null warning: */
1976 const char * const stashname = HvNAME(stash); assert(stashname);
1977 if (strBEGINs(stashname, "CORE"))
1978 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1985 /* Nothing else to do.
1986 The compiler will probably turn the switch statement into a
1987 branch table. Make sure we avoid even that small overhead for
1988 the common case of lower case variable names. (On EBCDIC
1989 platforms, we can't just do:
1990 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1991 because cases like '\027' in the switch statement below are
1992 C1 (non-ASCII) controls on those platforms, so the remapping
1993 would make them larger than 'V')
2000 if (memEQs(name, len, "ARGV")) {
2001 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
2003 else if (memEQs(name, len, "ARGVOUT")) {
2009 len >= 6 && name[1] == 'X' &&
2010 (memEQs(name, len, "EXPORT")
2011 ||memEQs(name, len, "EXPORT_OK")
2012 ||memEQs(name, len, "EXPORT_FAIL")
2013 ||memEQs(name, len, "EXPORT_TAGS"))
2018 if (memEQs(name, len, "ISA")) {
2019 gv_magicalize_isa(gv);
2023 if (memEQs(name, len, "SIG")) {
2026 if (!PL_psig_name) {
2027 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2028 Newxz(PL_psig_pend, SIG_SIZE, int);
2029 PL_psig_ptr = PL_psig_name + SIG_SIZE;
2031 /* I think that the only way to get here is to re-use an
2032 embedded perl interpreter, where the previous
2033 use didn't clean up fully because
2034 PL_perl_destruct_level was 0. I'm not sure that we
2035 "support" that, in that I suspect in that scenario
2036 there are sufficient other garbage values left in the
2037 interpreter structure that something else will crash
2038 before we get here. I suspect that this is one of
2039 those "doctor, it hurts when I do this" bugs. */
2040 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2041 Zero(PL_psig_pend, SIG_SIZE, int);
2045 hv_magic(hv, NULL, PERL_MAGIC_sig);
2046 for (i = 1; i < SIG_SIZE; i++) {
2047 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2049 sv_setsv(*init, &PL_sv_undef);
2054 if (memEQs(name, len, "VERSION"))
2057 case '\003': /* $^CHILD_ERROR_NATIVE */
2058 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2060 /* @{^CAPTURE} %{^CAPTURE} */
2061 if (memEQs(name, len, "\003APTURE")) {
2062 AV* const av = GvAVn(gv);
2063 const Size_t n = *name;
2065 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2068 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2070 } else /* %{^CAPTURE_ALL} */
2071 if (memEQs(name, len, "\003APTURE_ALL")) {
2072 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2075 case '\005': /* $^ENCODING */
2076 if (memEQs(name, len, "\005NCODING"))
2079 case '\007': /* $^GLOBAL_PHASE */
2080 if (memEQs(name, len, "\007LOBAL_PHASE"))
2083 case '\014': /* $^LAST_FH */
2084 if (memEQs(name, len, "\014AST_FH"))
2087 case '\015': /* $^MATCH */
2088 if (memEQs(name, len, "\015ATCH")) {
2089 paren = RX_BUFF_IDX_CARET_FULLMATCH;
2093 case '\017': /* $^OPEN */
2094 if (memEQs(name, len, "\017PEN"))
2097 case '\020': /* $^PREMATCH $^POSTMATCH */
2098 if (memEQs(name, len, "\020REMATCH")) {
2099 paren = RX_BUFF_IDX_CARET_PREMATCH;
2102 if (memEQs(name, len, "\020OSTMATCH")) {
2103 paren = RX_BUFF_IDX_CARET_POSTMATCH;
2108 if (memEQs(name, len, "\023AFE_LOCALES"))
2111 case '\024': /* ${^TAINT} */
2112 if (memEQs(name, len, "\024AINT"))
2115 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
2116 if (memEQs(name, len, "\025NICODE"))
2118 if (memEQs(name, len, "\025TF8LOCALE"))
2120 if (memEQs(name, len, "\025TF8CACHE"))
2123 case '\027': /* $^WARNING_BITS */
2124 if (memEQs(name, len, "\027ARNING_BITS"))
2127 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2141 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2144 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2146 /* XXX why are we using a SSize_t? */
2147 paren = (SSize_t)(I32)uv;
2153 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2154 be case '\0' in this switch statement (ie a default case) */
2157 paren = RX_BUFF_IDX_FULLMATCH;
2160 paren = RX_BUFF_IDX_PREMATCH;
2163 paren = RX_BUFF_IDX_POSTMATCH;
2165 #ifdef PERL_SAWAMPERSAND
2167 sv_type == SVt_PVAV ||
2168 sv_type == SVt_PVHV ||
2169 sv_type == SVt_PVCV ||
2170 sv_type == SVt_PVFM ||
2172 )) { PL_sawampersand |=
2176 ? SAWAMPERSAND_MIDDLE
2177 : SAWAMPERSAND_RIGHT;
2190 paren = *name - '0';
2193 /* Flag the capture variables with a NULL mg_ptr
2194 Use mg_len for the array index to lookup. */
2195 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2199 sv_setpv(GvSVn(gv),PL_chopset);
2203 #ifdef COMPLEX_STATUS
2204 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2210 /* If %! has been used, automatically load Errno.pm. */
2212 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2214 /* magicalization must be done before require_tie_mod_s is called */
2215 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2216 require_tie_mod_s(gv, '!', "Errno", 1);
2219 case '-': /* $-, %-, @- */
2220 case '+': /* $+, %+, @+ */
2221 GvMULTI_on(gv); /* no used once warnings here */
2223 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2225 SvREADONLY_on(GvSVn(gv));
2228 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2229 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2232 AV* const av = GvAVn(gv);
2233 const Size_t n = *name;
2235 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2241 if (sv_type == SVt_PV)
2242 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2243 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2245 case '\010': /* $^H */
2247 HV *const hv = GvHVn(gv);
2248 hv_magic(hv, NULL, PERL_MAGIC_hints);
2251 case '\023': /* $^S */
2253 SvREADONLY_on(GvSVn(gv));
2270 case '\001': /* $^A */
2271 case '\003': /* $^C */
2272 case '\004': /* $^D */
2273 case '\005': /* $^E */
2274 case '\006': /* $^F */
2275 case '\011': /* $^I, NOT \t in EBCDIC */
2276 case '\016': /* $^N */
2277 case '\017': /* $^O */
2278 case '\020': /* $^P */
2279 case '\024': /* $^T */
2280 case '\027': /* $^W */
2282 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2285 case '\014': /* $^L */
2286 sv_setpvs(GvSVn(gv),"\f");
2289 sv_setpvs(GvSVn(gv),"\034");
2293 SV * const sv = GvSV(gv);
2294 if (!sv_derived_from(PL_patchlevel, "version"))
2295 upg_version(PL_patchlevel, TRUE);
2296 GvSV(gv) = vnumify(PL_patchlevel);
2297 SvREADONLY_on(GvSV(gv));
2301 case '\026': /* $^V */
2303 SV * const sv = GvSV(gv);
2304 GvSV(gv) = new_version(PL_patchlevel);
2305 SvREADONLY_on(GvSV(gv));
2311 if (sv_type == SVt_PV)
2317 /* Return true if we actually did something. */
2318 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2320 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2325 /* If we do ever start using this later on in the file, we need to make
2326 sure we don’t accidentally use the wrong definition. */
2327 #undef SvREADONLY_on
2329 /* This function is called when the stash already holds the GV of the magic
2330 * variable we're looking for, but we need to check that it has the correct
2331 * kind of magic. For example, if someone first uses $! and then %!, the
2332 * latter would end up here, and we add the Errno tie to the HASH slot of
2335 PERL_STATIC_INLINE void
2336 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2338 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2340 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2342 require_tie_mod_s(gv, '!', "Errno", 1);
2343 else if (*name == '-' || *name == '+')
2344 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2345 } else if (sv_type == SVt_PV) {
2346 if (*name == '*' || *name == '#') {
2347 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2348 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2351 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2353 #ifdef PERL_SAWAMPERSAND
2355 PL_sawampersand |= SAWAMPERSAND_LEFT;
2359 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2363 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2372 =for apidoc gv_fetchpv
2373 =for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type
2374 =for apidoc_item ||gv_fetchpvn_flags
2375 =for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type
2376 =for apidoc_item ||gv_fetchsv
2377 =for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type
2379 These all return the GV of type C<sv_type> whose name is given by the inputs,
2380 or NULL if no GV of that name and type could be found. See L<perlguts/Stashes
2383 The only differences are how the input name is specified, and if 'get' magic is
2384 normally used in getting that name.
2386 Don't be fooled by the fact that only one form has C<flags> in its name. They
2387 all have a C<flags> parameter in fact, and all the flag bits have the same
2390 If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or
2391 C<GV_NOINIT> is set, a GV is created if none already exists for the input name
2392 and type. However, C<GV_ADDMG> will only do the creation for magical GV's.
2393 For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after
2394 the addition. C<GV_ADDWARN> is used when the caller expects that adding won't
2395 be necessary because the symbol should already exist; but if not, add it
2396 anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI>
2397 flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used
2400 The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the
2401 GV existed but isn't PVGV.
2403 If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8;
2404 otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms,
2405 and the UTF-8ness of the underlying SVs will be used in the C<sv> forms.
2407 If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a
2408 plain symbol name, not qualified with a package, otherwise the name is checked
2409 for being a qualified one.
2411 In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate
2414 In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in
2417 C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is
2418 a Perl string whose byte length is given by C<full_len>, and may contain
2421 In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of
2422 the input C<name> SV. The only difference between these two forms is that
2423 'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped
2424 with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter
2425 to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>.
2427 =for apidoc Amnh||GV_ADD
2428 =for apidoc Amnh||GV_ADDMG
2429 =for apidoc Amnh||GV_ADDMULTI
2430 =for apidoc Amnh||GV_ADDWARN
2431 =for apidoc Amnh||GV_NOADD_NOINIT
2432 =for apidoc Amnh||GV_NOINIT
2433 =for apidoc Amnh||GV_NOTQUAL
2434 =for apidoc Amnh||GV_NO_SVGMAGIC
2435 =for apidoc Amnh||SVf_UTF8
2441 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2442 const svtype sv_type)
2444 const char *name = nambeg;
2449 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2450 const I32 no_expand = flags & GV_NOEXPAND;
2451 const I32 add = flags & ~GV_NOADD_MASK;
2452 const U32 is_utf8 = flags & SVf_UTF8;
2453 bool addmg = cBOOL(flags & GV_ADDMG);
2454 const char *const name_end = nambeg + full_len;
2457 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2459 /* If we have GV_NOTQUAL, the caller promised that
2460 * there is no stash, so we can skip the check.
2461 * Similarly if full_len is 0, since then we're
2462 * dealing with something like *{""} or ""->foo()
2464 if ((flags & GV_NOTQUAL) || !full_len) {
2467 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2468 if (name == name_end) return gv;
2474 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2478 /* By this point we should have a stash and a name */
2479 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2480 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2481 if (addmg) gv = (GV *)newSV(0); /* tentatively */
2484 else gv = *gvp, addmg = 0;
2485 /* From this point on, addmg means gv has not been inserted in the
2488 if (SvTYPE(gv) == SVt_PVGV) {
2489 /* The GV already exists, so return it, but check if we need to do
2490 * anything else with it before that.
2493 /* This is the heuristic that handles if a variable triggers the
2494 * 'used only once' warning. If there's already a GV in the stash
2495 * with this name, then we assume that the variable has been used
2496 * before and turn its MULTI flag on.
2497 * It's a heuristic because it can easily be "tricked", like with
2498 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2499 * not warning about $main::foo being used just once
2502 gv_init_svtype(gv, sv_type);
2503 /* You reach this path once the typeglob has already been created,
2504 either by the same or a different sigil. If this path didn't
2505 exist, then (say) referencing $! first, and %! second would
2506 mean that %! was not handled correctly. */
2507 if (len == 1 && stash == PL_defstash) {
2508 maybe_multimagic_gv(gv, name, sv_type);
2510 else if (sv_type == SVt_PVAV
2511 && memEQs(name, len, "ISA")
2512 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2513 gv_magicalize_isa(gv);
2516 } else if (no_init) {
2520 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2521 * don't expand it to a glob. This is an optimization so that things
2522 * copying constants over, like Exporter, don't have to be rewritten
2523 * to take into account that you can store more than just globs in
2526 else if (no_expand && SvROK(gv)) {
2531 /* Adding a new symbol.
2532 Unless of course there was already something non-GV here, in which case
2533 we want to behave as if there was always a GV here, containing some sort
2535 Otherwise we run the risk of creating things like GvIO, which can cause
2536 subtle bugs. eg the one that tripped up SQL::Translator */
2538 faking_it = SvOK(gv);
2540 if (add & GV_ADDWARN)
2541 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2542 "Had to create %" UTF8f " unexpectedly",
2543 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2544 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2547 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2548 && !ckWARN(WARN_ONCE) )
2553 /* set up magic where warranted */
2554 if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2557 /* gv_magicalize magicalised this gv, so we want it
2558 * stored in the symtab.
2559 * Effectively the caller is asking, ‘Does this gv exist?’
2560 * And we respond, ‘Er, *now* it does!’
2562 (void)hv_store(stash,name,len,(SV *)gv,0);
2566 /* The temporary GV created above */
2567 SvREFCNT_dec_NN(gv);
2571 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2576 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2579 const HV * const hv = GvSTASH(gv);
2581 PERL_ARGS_ASSERT_GV_FULLNAME4;
2583 sv_setpv(sv, prefix ? prefix : "");
2585 if (hv && (name = HvNAME(hv))) {
2586 const STRLEN len = HvNAMELEN(hv);
2587 if (keepmain || ! memBEGINs(name, len, "main")) {
2588 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2592 else sv_catpvs(sv,"__ANON__::");
2593 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2597 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2599 const GV * const egv = GvEGVx(gv);
2601 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2603 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2607 /* recursively scan a stash and any nested stashes looking for entries
2608 * that need the "only used once" warning raised
2612 Perl_gv_check(pTHX_ HV *stash)
2616 PERL_ARGS_ASSERT_GV_CHECK;
2621 assert(HvARRAY(stash));
2623 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2625 /* mark stash is being scanned, to avoid recursing */
2626 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2627 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2630 STRLEN keylen = HeKLEN(entry);
2631 const char * const key = HeKEY(entry);
2633 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
2634 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2636 if (hv != PL_defstash && hv != stash
2638 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2640 gv_check(hv); /* nested package */
2642 else if ( HeKLEN(entry) != 0
2643 && *HeKEY(entry) != '_'
2644 && isIDFIRST_lazy_if_safe(HeKEY(entry),
2645 HeKEY(entry) + HeKLEN(entry),
2649 gv = MUTABLE_GV(HeVAL(entry));
2650 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2653 CopLINE_set(PL_curcop, GvLINE(gv));
2655 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2657 CopFILEGV(PL_curcop)
2658 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2660 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2661 "Name \"%" HEKf "::%" HEKf
2662 "\" used only once: possible typo",
2663 HEKfARG(HvNAME_HEK(stash)),
2664 HEKfARG(GvNAME_HEK(gv)));
2667 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2672 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2674 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2675 assert(!(flags & ~SVf_UTF8));
2677 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2678 UTF8fARG(flags, strlen(pack), pack),
2683 /* hopefully this is only called on local symbol table entries */
2686 Perl_gp_ref(pTHX_ GP *gp)
2693 /* If the GP they asked for a reference to contains
2694 a method cache entry, clear it first, so that we
2695 don't infect them with our cached entry */
2696 SvREFCNT_dec_NN(gp->gp_cv);
2705 Perl_gp_free(pTHX_ GV *gv)
2710 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2712 if (gp->gp_refcnt == 0) {
2713 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2714 "Attempt to free unreferenced glob pointers"
2715 pTHX__FORMAT pTHX__VALUE);
2718 if (gp->gp_refcnt > 1) {
2720 if (gp->gp_egv == gv)
2728 /* Copy and null out all the glob slots, so destructors do not see
2730 HEK * const file_hek = gp->gp_file_hek;
2731 SV * const sv = gp->gp_sv;
2732 AV * const av = gp->gp_av;
2733 HV * const hv = gp->gp_hv;
2734 IO * const io = gp->gp_io;
2735 CV * const cv = gp->gp_cv;
2736 CV * const form = gp->gp_form;
2738 gp->gp_file_hek = NULL;
2747 unshare_hek(file_hek);
2751 /* FIXME - another reference loop GV -> symtab -> GV ?
2752 Somehow gp->gp_hv can end up pointing at freed garbage. */
2753 if (hv && SvTYPE(hv) == SVt_PVHV) {
2754 const HEK *hvname_hek = HvNAME_HEK(hv);
2755 if (PL_stashcache && hvname_hek) {
2756 DEBUG_o(Perl_deb(aTHX_
2757 "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2758 HEKfARG(hvname_hek)));
2759 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2763 if (io && SvREFCNT(io) == 1 && IoIFP(io)
2764 && (IoTYPE(io) == IoTYPE_WRONLY ||
2765 IoTYPE(io) == IoTYPE_RDWR ||
2766 IoTYPE(io) == IoTYPE_APPEND)
2767 && ckWARN_d(WARN_IO)
2768 && IoIFP(io) != PerlIO_stdin()
2769 && IoIFP(io) != PerlIO_stdout()
2770 && IoIFP(io) != PerlIO_stderr()
2771 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2772 io_close(io, gv, FALSE, TRUE);
2777 /* Possibly reallocated by a destructor */
2780 if (!gp->gp_file_hek
2786 && !gp->gp_form) break;
2788 if (--attempts == 0) {
2790 "panic: gp_free failed to free glob pointer - "
2791 "something is repeatedly re-creating entries"
2796 /* Possibly incremented by a destructor doing glob assignment */
2797 if (gp->gp_refcnt > 1) goto borrowed;
2803 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2805 AMT * const amtp = (AMT*)mg->mg_ptr;
2806 PERL_UNUSED_ARG(sv);
2808 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2810 if (amtp && AMT_AMAGIC(amtp)) {
2812 for (i = 1; i < NofAMmeth; i++) {
2813 CV * const cv = amtp->table[i];
2815 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2816 amtp->table[i] = NULL;
2823 /* Updates and caches the CV's */
2825 * 1 on success and there is some overload
2826 * 0 if there is no overload
2827 * -1 if some error occurred and it couldn't croak
2831 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2833 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2835 const struct mro_meta* stash_meta = HvMROMETA(stash);
2838 PERL_ARGS_ASSERT_GV_AMUPDATE;
2840 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2842 const AMT * const amtp = (AMT*)mg->mg_ptr;
2843 if (amtp->was_ok_sub == newgen) {
2844 return AMT_AMAGIC(amtp) ? 1 : 0;
2846 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2849 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2852 amt.was_ok_sub = newgen;
2853 amt.fallback = AMGfallNO;
2859 bool deref_seen = 0;
2862 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2864 /* Try to find via inheritance. */
2865 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2866 SV * const sv = gv ? GvSV(gv) : NULL;
2871 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2874 #ifdef PERL_DONT_CREATE_GVSV
2876 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2879 else if (SvTRUE(sv))
2880 /* don't need to set overloading here because fallback => 1
2881 * is the default setting for classes without overloading */
2882 amt.fallback=AMGfallYES;
2883 else if (SvOK(sv)) {
2884 amt.fallback=AMGfallNEVER;
2891 assert(SvOOK(stash));
2892 /* initially assume the worst */
2893 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2895 for (i = 1; i < NofAMmeth; i++) {
2896 const char * const cooky = PL_AMG_names[i];
2897 /* Human-readable form, for debugging: */
2898 const char * const cp = AMG_id2name(i);
2899 const STRLEN l = PL_AMG_namelens[i];
2901 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2902 cp, HvNAME_get(stash)) );
2903 /* don't fill the cache while looking up!
2904 Creation of inheritance stubs in intermediate packages may
2905 conflict with the logic of runtime method substitution.
2906 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2907 then we could have created stubs for "(+0" in A and C too.
2908 But if B overloads "bool", we may want to use it for
2909 numifying instead of C's "+0". */
2910 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2912 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2913 const HEK * const gvhek = CvGvNAME_HEK(cv);
2914 const HEK * const stashek =
2915 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2916 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
2918 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
2919 /* This is a hack to support autoloading..., while
2920 knowing *which* methods were declared as overloaded. */
2921 /* GvSV contains the name of the method. */
2923 SV *gvsv = GvSV(gv);
2925 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
2926 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2927 (void*)GvSV(gv), cp, HvNAME(stash)) );
2928 if (!gvsv || !SvPOK(gvsv)
2929 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2931 /* Can be an import stub (created by "can"). */
2936 const SV * const name = (gvsv && SvPOK(gvsv))
2938 : newSVpvs_flags("???", SVs_TEMP);
2939 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2940 Perl_croak(aTHX_ "%s method \"%" SVf256
2941 "\" overloading \"%s\" "\
2942 "in package \"%" HEKf256 "\"",
2943 (GvCVGEN(gv) ? "Stub found while resolving"
2951 cv = GvCV(gv = ngv);
2953 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2954 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2955 GvNAME(CvGV(cv))) );
2957 } else if (gv) { /* Autoloaded... */
2958 cv = MUTABLE_CV(gv);
2961 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2977 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2978 * NB - aux var invalid here, HvARRAY() could have been
2979 * reallocated since it was assigned to */
2980 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2983 AMT_AMAGIC_on(&amt);
2984 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2985 (char*)&amt, sizeof(AMT));
2989 /* Here we have no table: */
2991 AMT_AMAGIC_off(&amt);
2992 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2993 (char*)&amt, sizeof(AMTS));
2999 Perl_gv_handler(pTHX_ HV *stash, I32 id)
3004 struct mro_meta* stash_meta;
3006 if (!stash || !HvNAME_get(stash))
3009 stash_meta = HvMROMETA(stash);
3010 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
3012 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3015 if (Gv_AMupdate(stash, 0) == -1)
3017 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
3020 amtp = (AMT*)mg->mg_ptr;
3021 if ( amtp->was_ok_sub != newgen )
3023 if (AMT_AMAGIC(amtp)) {
3024 CV * const ret = amtp->table[id];
3025 if (ret && isGV(ret)) { /* Autoloading stab */
3026 /* Passing it through may have resulted in a warning
3027 "Inherited AUTOLOAD for a non-method deprecated", since
3028 our caller is going through a function call, not a method call.
3029 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
3030 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
3042 /* Implement tryAMAGICun_MG macro.
3043 Do get magic, then see if the stack arg is overloaded and if so call it.
3045 AMGf_numeric apply sv_2num to the stack arg.
3049 Perl_try_amagic_un(pTHX_ int method, int flags) {
3052 SV* const arg = TOPs;
3056 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
3057 AMGf_noright | AMGf_unary
3058 | (flags & AMGf_numarg))))
3060 /* where the op is of the form:
3061 * $lex = $x op $y (where the assign is optimised away)
3062 * then assign the returned value to targ and return that;
3063 * otherwise return the value directly
3065 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3066 && (PL_op->op_private & OPpTARGET_MY))
3069 sv_setsv(TARG, tmpsv);
3079 if ((flags & AMGf_numeric) && SvROK(arg))
3085 /* Implement tryAMAGICbin_MG macro.
3086 Do get magic, then see if the two stack args are overloaded and if so
3089 AMGf_assign op may be called as mutator (eg +=)
3090 AMGf_numeric apply sv_2num to the stack arg.
3094 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3096 SV* const left = TOPm1s;
3097 SV* const right = TOPs;
3103 if (SvAMAGIC(left) || SvAMAGIC(right)) {
3105 /* STACKED implies mutator variant, e.g. $x += 1 */
3106 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3108 tmpsv = amagic_call(left, right, method,
3109 (mutator ? AMGf_assign: 0)
3110 | (flags & AMGf_numarg));
3113 /* where the op is one of the two forms:
3115 * $lex = $x op $y (where the assign is optimised away)
3116 * then assign the returned value to targ and return that;
3117 * otherwise return the value directly
3120 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3121 && (PL_op->op_private & OPpTARGET_MY)))
3124 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3125 sv_setsv(TARG, tmpsv);
3136 if(left==right && SvGMAGICAL(left)) {
3137 SV * const left = sv_newmortal();
3139 /* Print the uninitialized warning now, so it includes the vari-
3142 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3143 sv_setsv_flags(left, &PL_sv_no, 0);
3145 else sv_setsv_flags(left, right, 0);
3148 if (flags & AMGf_numeric) {
3150 *(sp-1) = sv_2num(TOPm1s);
3152 *sp = sv_2num(right);
3158 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3162 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3166 /* return quickly if none of the deref ops are overloaded */
3167 stash = SvSTASH(SvRV(ref));
3168 assert(SvOOK(stash));
3169 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3172 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3173 AMGf_noright | AMGf_unary))) {
3175 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3176 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3177 /* Bail out if it returns us the same reference. */
3184 return tmpsv ? tmpsv : ref;
3188 Perl_amagic_is_enabled(pTHX_ int method)
3190 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3192 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3194 if ( !lex_mask || !SvOK(lex_mask) )
3195 /* overloading lexically disabled */
3197 else if ( lex_mask && SvPOK(lex_mask) ) {
3198 /* we have an entry in the hints hash, check if method has been
3199 * masked by overloading.pm */
3201 const int offset = method / 8;
3202 const int bit = method % 8;
3203 char *pv = SvPV(lex_mask, len);
3205 /* Bit set, so this overloading operator is disabled */
3206 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3213 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3217 CV **cvp=NULL, **ocvp=NULL;
3218 AMT *amtp=NULL, *oamtp=NULL;
3219 int off = 0, off1, lr = 0, notfound = 0;
3220 int postpr = 0, force_cpy = 0;
3221 int assign = AMGf_assign & flags;
3222 const int assignshift = assign ? 1 : 0;
3223 int use_default_op = 0;
3224 int force_scalar = 0;
3230 PERL_ARGS_ASSERT_AMAGIC_CALL;
3232 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3233 if (!amagic_is_enabled(method)) return NULL;
3236 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3237 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3238 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3239 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3240 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3242 && ((cv = cvp[off=method+assignshift])
3243 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3249 cv = cvp[off=method])))) {
3250 lr = -1; /* Call method for left argument */
3252 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3255 /* look for substituted methods */
3256 /* In all the covered cases we should be called with assign==0. */
3260 if ((cv = cvp[off=add_ass_amg])
3261 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3262 right = &PL_sv_yes; lr = -1; assign = 1;
3267 if ((cv = cvp[off = subtr_ass_amg])
3268 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3269 right = &PL_sv_yes; lr = -1; assign = 1;
3273 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3276 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3279 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3282 (void)((cv = cvp[off=bool__amg])
3283 || (cv = cvp[off=numer_amg])
3284 || (cv = cvp[off=string_amg]));
3291 * SV* ref causes confusion with the interpreter variable of
3294 SV* const tmpRef=SvRV(left);
3295 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3297 * Just to be extra cautious. Maybe in some
3298 * additional cases sv_setsv is safe, too.
3300 SV* const newref = newSVsv(tmpRef);
3301 SvOBJECT_on(newref);
3302 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3303 delegate to the stash. */
3304 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3310 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3311 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3312 SV* const nullsv=&PL_sv_zero;
3314 SV* const lessp = amagic_call(left,nullsv,
3315 lt_amg,AMGf_noright);
3316 logic = SvTRUE_NN(lessp);
3318 SV* const lessp = amagic_call(left,nullsv,
3319 ncmp_amg,AMGf_noright);
3320 logic = (SvNV(lessp) < 0);
3323 if (off==subtr_amg) {
3334 if ((cv = cvp[off=subtr_amg])) {
3341 case iter_amg: /* XXXX Eventually should do to_gv. */
3342 case ftest_amg: /* XXXX Eventually should do to_gv. */
3345 return NULL; /* Delegate operation to standard mechanisms. */
3353 return left; /* Delegate operation to standard mechanisms. */
3358 if (!cv) goto not_found;
3359 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3360 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3361 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3362 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3363 ? (amtp = (AMT*)mg->mg_ptr)->table
3365 && (cv = cvp[off=method])) { /* Method for right
3368 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3369 || (ocvp && oamtp->fallback > AMGfallNEVER))
3370 && !(flags & AMGf_unary)) {
3371 /* We look for substitution for
3372 * comparison operations and
3374 if (method==concat_amg || method==concat_ass_amg
3375 || method==repeat_amg || method==repeat_ass_amg) {
3376 return NULL; /* Delegate operation to string conversion */
3398 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3402 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3412 not_found: /* No method found, either report or croak */
3420 return left; /* Delegate operation to standard mechanisms. */
3422 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3423 notfound = 1; lr = -1;
3424 } else if (cvp && (cv=cvp[nomethod_amg])) {
3425 notfound = 1; lr = 1;
3426 } else if ((use_default_op =
3427 (!ocvp || oamtp->fallback >= AMGfallYES)
3428 && (!cvp || amtp->fallback >= AMGfallYES))
3430 /* Skip generating the "no method found" message. */
3434 if (off==-1) off=method;
3435 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3436 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3437 AMG_id2name(method + assignshift),
3438 (flags & AMGf_unary ? " " : "\n\tleft "),
3440 "in overloaded package ":
3441 "has no overloaded magic",
3443 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3446 ",\n\tright argument in overloaded package ":
3449 : ",\n\tright argument has no overloaded magic"),
3451 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3452 SVfARG(&PL_sv_no)));
3453 if (use_default_op) {
3454 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3456 Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3460 force_cpy = force_cpy || assign;
3465 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3466 * operation. we need this to return a value, so that it can be assigned
3467 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3468 * increment or decrement was itself called in void context */
3474 if (off == subtr_amg)
3477 /* in these cases, we're calling an assignment variant of an operator
3478 * (+= rather than +, for instance). regardless of whether it's a
3479 * fallback or not, it always has to return a value, which will be
3480 * assigned to the proper variable later */
3500 /* the copy constructor always needs to return a value */
3504 /* because of the way these are implemented (they don't perform the
3505 * dereferencing themselves, they return a reference that perl then
3506 * dereferences later), they always have to be in scalar context */
3514 /* these don't have an op of their own; they're triggered by their parent
3515 * op, so the context there isn't meaningful ('$a and foo()' in void
3516 * context still needs to pass scalar context on to $a's bool overload) */
3526 DEBUG_o(Perl_deb(aTHX_
3527 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3529 method+assignshift==off? "" :
3531 method+assignshift==off? "" :
3532 AMG_id2name(method+assignshift),
3533 method+assignshift==off? "" : "\")",
3534 flags & AMGf_unary? "" :
3535 lr==1 ? " for right argument": " for left argument",
3536 flags & AMGf_unary? " for argument" : "",
3537 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3538 fl? ",\n\tassignment variant used": "") );
3541 /* Since we use shallow copy during assignment, we need
3542 * to dublicate the contents, probably calling user-supplied
3543 * version of copy operator
3545 /* We need to copy in following cases:
3546 * a) Assignment form was called.
3547 * assignshift==1, assign==T, method + 1 == off
3548 * b) Increment or decrement, called directly.
3549 * assignshift==0, assign==0, method + 0 == off
3550 * c) Increment or decrement, translated to assignment add/subtr.
3551 * assignshift==0, assign==T,
3553 * d) Increment or decrement, translated to nomethod.
3554 * assignshift==0, assign==0,
3556 * e) Assignment form translated to nomethod.
3557 * assignshift==1, assign==T, method + 1 != off
3560 /* off is method, method+assignshift, or a result of opcode substitution.
3561 * In the latter case assignshift==0, so only notfound case is important.
3563 if ( (lr == -1) && ( ( (method + assignshift == off)
3564 && (assign || (method == inc_amg) || (method == dec_amg)))
3567 /* newSVsv does not behave as advertised, so we copy missing
3568 * information by hand */
3569 SV *tmpRef = SvRV(left);
3571 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3572 SvRV_set(left, rv_copy);
3574 SvREFCNT_dec_NN(tmpRef);
3582 const bool oldcatch = CATCH_GET;
3584 /* for multiconcat, we may call overload several times,
3585 * with the context of individual concats being scalar,
3586 * regardless of the overall context of the multiconcat op
3588 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3589 ? G_SCALAR : GIMME_V;
3592 Zero(&myop, 1, BINOP);
3593 myop.op_last = (OP *) &myop;
3594 myop.op_next = NULL;
3595 myop.op_flags = OPf_STACKED;
3599 myop.op_flags |= OPf_WANT_VOID;
3602 if (flags & AMGf_want_list) {
3603 myop.op_flags |= OPf_WANT_LIST;
3608 myop.op_flags |= OPf_WANT_SCALAR;
3612 PUSHSTACKi(PERLSI_OVERLOAD);
3615 PL_op = (OP *) &myop;
3616 if (PERLDB_SUB && PL_curstash != PL_debstash)
3617 PL_op->op_private |= OPpENTERSUB_DB;
3618 Perl_pp_pushmark(aTHX);
3620 EXTEND(SP, notfound + 5);
3621 PUSHs(lr>0? right: left);
3622 PUSHs(lr>0? left: right);
3623 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3625 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3626 AMG_id2namelen(method + assignshift), SVs_TEMP));
3628 else if (flags & AMGf_numarg)
3629 PUSHs(&PL_sv_undef);
3630 if (flags & AMGf_numarg)
3632 PUSHs(MUTABLE_SV(cv));
3636 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3640 nret = SP - (PL_stack_base + oldmark);
3644 /* returning NULL has another meaning, and we check the context
3645 * at the call site too, so this can be differentiated from the
3648 SP = PL_stack_base + oldmark;
3651 if (flags & AMGf_want_list) {
3652 res = sv_2mortal((SV *)newAV());
3653 av_extend((AV *)res, nret);
3655 av_store((AV *)res, nret, POPs);
3666 CATCH_SET(oldcatch);
3673 ans=SvIV(res)<=0; break;
3676 ans=SvIV(res)<0; break;
3679 ans=SvIV(res)>=0; break;
3682 ans=SvIV(res)>0; break;
3685 ans=SvIV(res)==0; break;
3688 ans=SvIV(res)!=0; break;
3691 SvSetSV(left,res); return left;
3693 ans=!SvTRUE_NN(res); break;
3698 } else if (method==copy_amg) {
3700 Perl_croak(aTHX_ "Copy method did not return a reference");
3702 return SvREFCNT_inc(SvRV(res));
3710 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3714 PERL_ARGS_ASSERT_GV_NAME_SET;
3717 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3719 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3720 unshare_hek(GvNAME_HEK(gv));
3723 PERL_HASH(hash, name, len);
3724 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3728 =for apidoc gv_try_downgrade
3730 If the typeglob C<gv> can be expressed more succinctly, by having
3731 something other than a real GV in its place in the stash, replace it
3732 with the optimised form. Basic requirements for this are that C<gv>
3733 is a real typeglob, is sufficiently ordinary, and is only referenced
3734 from its package. This function is meant to be used when a GV has been
3735 looked up in part to see what was there, causing upgrading, but based
3736 on what was found it turns out that the real GV isn't required after all.
3738 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3740 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3741 sub, the typeglob is replaced with a scalar-reference placeholder that
3742 more compactly represents the same thing.
3748 Perl_gv_try_downgrade(pTHX_ GV *gv)
3754 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3756 /* XXX Why and where does this leave dangling pointers during global
3758 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3760 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3761 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3762 isGV_with_GP(gv) && GvGP(gv) &&
3763 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3764 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3765 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3767 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3769 if (SvMAGICAL(gv)) {
3771 /* only backref magic is allowed */
3772 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3774 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3775 if (mg->mg_type != PERL_MAGIC_backref)
3781 HEK *gvnhek = GvNAME_HEK(gv);
3782 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3783 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3784 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3785 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3786 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3787 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3788 (namehek = GvNAME_HEK(gv)) &&
3789 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3791 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3792 const bool imported = !!GvIMPORTED_CV(gv);
3796 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3798 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3799 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3800 STRUCT_OFFSET(XPVIV, xiv_iv));
3801 SvRV_set(gv, value);
3806 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3808 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3810 PERL_ARGS_ASSERT_GV_OVERRIDE;
3811 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3812 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3813 gv = gvp ? *gvp : NULL;
3814 if (gv && !isGV(gv)) {
3815 if (!SvPCS_IMPORTED(gv)) return NULL;
3816 gv_init(gv, PL_globalstash, name, len, 0);
3819 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3825 core_xsub(pTHX_ CV* cv)
3828 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3833 * ex: set ts=8 sts=4 sw=4 et: