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);
87 && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
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).
326 =for apidoc Amnh||GV_ADDMULTI
330 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
331 has no flags parameter. If the C<multi> parameter is set, the
332 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
334 =for apidoc gv_init_pv
336 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
337 instead of separate char * and length parameters.
339 =for apidoc gv_init_sv
341 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
342 char * and length parameters. C<flags> is currently unused.
348 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
352 PERL_ARGS_ASSERT_GV_INIT_SV;
353 namepv = SvPV(namesv, namelen);
356 gv_init_pvn(gv, stash, namepv, namelen, flags);
360 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
362 PERL_ARGS_ASSERT_GV_INIT_PV;
363 gv_init_pvn(gv, stash, name, strlen(name), flags);
367 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
369 const U32 old_type = SvTYPE(gv);
370 const bool doproto = old_type > SVt_NULL;
371 char * const proto = (doproto && SvPOK(gv))
372 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
374 const STRLEN protolen = proto ? SvCUR(gv) : 0;
375 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
376 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
377 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
378 const bool really_sub =
379 has_constant && SvTYPE(has_constant) == SVt_PVCV;
380 COP * const old = PL_curcop;
382 PERL_ARGS_ASSERT_GV_INIT_PVN;
383 assert (!(proto && has_constant));
386 /* The constant has to be a scalar, array or subroutine. */
387 switch (SvTYPE(has_constant)) {
391 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
392 sv_reftype(has_constant, 0));
393 NOT_REACHED; /* NOTREACHED */
403 if (old_type < SVt_PVGV) {
404 if (old_type >= SVt_PV)
406 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
414 Safefree(SvPVX_mutable(gv));
419 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
420 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
421 || CvSTART(has_constant)->op_type == OP_DBSTATE))
422 PL_curcop = (COP *)CvSTART(has_constant);
423 GvGP_set(gv, Perl_newGP(aTHX_ gv));
427 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
428 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
429 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
430 GvMULTI_on(gv); /* _was_ mentioned */
432 /* Not actually a constant. Just a regular sub. */
433 CV * const cv = (CV *)has_constant;
435 if (CvNAMED(cv) && CvSTASH(cv) == stash && (
436 CvNAME_HEK(cv) == GvNAME_HEK(gv)
437 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
438 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
439 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
440 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
448 /* newCONSTSUB takes ownership of the reference from us. */
449 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
450 /* In case op.c:S_process_special_blocks stole it: */
452 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
453 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
454 /* If this reference was a copy of another, then the subroutine
455 must have been "imported", by a Perl space assignment to a GV
456 from a reference to CV. */
457 if (exported_constant)
458 GvIMPORTED_CV_on(gv);
459 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
464 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
465 SV_HAS_TRAILING_NUL);
466 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
472 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
474 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
486 #ifdef PERL_DONT_CREATE_GVSV
494 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
495 If we just cast GvSVn(gv) to void, it ignores evaluating it for
502 static void core_xsub(pTHX_ CV* cv);
505 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
506 const char * const name, const STRLEN len)
508 const int code = keyword(name, len, 1);
509 static const char file[] = __FILE__;
510 CV *cv, *oldcompcv = NULL;
512 bool ampable = TRUE; /* &{}-able */
513 COP *oldcurcop = NULL;
514 yy_parser *oldparser = NULL;
515 I32 oldsavestack_ix = 0;
520 if (!code) return NULL; /* Not a keyword */
521 switch (code < 0 ? -code : code) {
522 /* no support for \&CORE::infix;
523 no support for funcs that do not parse like funcs */
524 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
525 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
526 case KEY_default : case KEY_DESTROY:
527 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
528 case KEY_END : case KEY_eq : case KEY_eval :
529 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
530 case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt :
531 case KEY_if : case KEY_isa : case KEY_INIT : case KEY_last :
532 case KEY_le : case KEY_local : case KEY_lt : case KEY_m :
533 case KEY_map : case KEY_my:
534 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
535 case KEY_package: case KEY_print: case KEY_printf:
536 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
537 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
538 case KEY_s : case KEY_say : case KEY_sort :
539 case KEY_state: case KEY_sub :
540 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
541 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
542 case KEY_x : case KEY_xor : case KEY_y :
545 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
546 case KEY_eof : case KEY_exec: case KEY_exists :
551 case KEY_truncate: case KEY_unlink:
556 gv_init(gv, stash, name, len, TRUE);
561 oldcurcop = PL_curcop;
562 oldparser = PL_parser;
563 lex_start(NULL, NULL, 0);
564 oldcompcv = PL_compcv;
565 PL_compcv = NULL; /* Prevent start_subparse from setting
567 oldsavestack_ix = start_subparse(FALSE,0);
571 /* Avoid calling newXS, as it calls us, and things start to
573 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
577 CvXSUB(cv) = core_xsub;
580 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
582 /* XSUBs can't be perl lang/perl5db.pl debugged
583 if (PERLDB_LINE_OR_SAVESRC)
584 (void)gv_fetchfile(file); */
585 CvFILE(cv) = (char *)file;
586 /* XXX This is inefficient, as doing things this order causes
587 a prototype check in newATTRSUB. But we have to do
588 it this order as we need an op number before calling
590 (void)core_prototype((SV *)cv, name, code, &opnum);
592 (void)hv_store(stash,name,len,(SV *)gv,0);
598 /* newATTRSUB will free the CV and return NULL if we're still
599 compiling after a syntax error */
600 if ((cv = newATTRSUB_x(
601 oldsavestack_ix, (OP *)gv,
606 : newSVpvn(name,len),
611 assert(GvCV(gv) == orig_cv);
612 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
613 && opnum != OP_UNDEF && opnum != OP_KEYS)
614 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
617 PL_parser = oldparser;
618 PL_curcop = oldcurcop;
619 PL_compcv = oldcompcv;
622 SV *opnumsv = newSViv(
623 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
624 (OP_ENTEREVAL | (1<<16))
625 : opnum ? opnum : (((I32)name[2]) << 16));
626 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
627 SvREFCNT_dec_NN(opnumsv);
634 =for apidoc gv_fetchmeth
636 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
638 =for apidoc gv_fetchmeth_sv
640 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
641 of an SV instead of a string/length pair.
647 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
651 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
652 if (LIKELY(SvPOK_nog(namesv))) /* common case */
653 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
654 flags | SvUTF8(namesv));
655 namepv = SvPV(namesv, namelen);
656 if (SvUTF8(namesv)) flags |= SVf_UTF8;
657 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
661 =for apidoc gv_fetchmeth_pv
663 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
664 instead of a string/length pair.
670 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
672 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
673 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
677 =for apidoc gv_fetchmeth_pvn
679 Returns the glob with the given C<name> and a defined subroutine or
680 C<NULL>. The glob lives in the given C<stash>, or in the stashes
681 accessible via C<@ISA> and C<UNIVERSAL::>.
683 The argument C<level> should be either 0 or -1. If C<level==0>, as a
684 side-effect creates a glob with the given C<name> in the given C<stash>
685 which in the case of success contains an alias for the subroutine, and sets
686 up caching info for this glob.
688 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
690 C<GV_SUPER> indicates that we want to look up the method in the superclasses
694 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
695 visible to Perl code. So when calling C<call_sv>, you should not use
696 the GV directly; instead, you should use the method's CV, which can be
697 obtained from the GV with the C<GvCV> macro.
699 =for apidoc Amnh||GV_SUPER
704 /* NOTE: No support for tied ISA */
706 PERL_STATIC_INLINE GV*
707 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
714 HV* cstash, *cachestash;
715 GV* candidate = NULL;
720 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
723 U32 is_utf8 = flags & SVf_UTF8;
725 /* UNIVERSAL methods should be callable without a stash */
727 create = 0; /* probably appropriate */
728 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
734 hvname = HvNAME_get(stash);
735 hvnamelen = HvNAMELEN_get(stash);
737 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
740 assert(name || meth);
742 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
743 flags & GV_SUPER ? "SUPER " : "",
744 name ? name : SvPV_nolen(meth), hvname) );
746 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
748 if (flags & GV_SUPER) {
749 if (!HvAUX(stash)->xhv_mro_meta->super)
750 HvAUX(stash)->xhv_mro_meta->super = newHV();
751 cachestash = HvAUX(stash)->xhv_mro_meta->super;
753 else cachestash = stash;
755 /* check locally for a real method or a cache entry */
757 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
759 if (he) gvp = (GV**)&HeVAL(he);
766 if (SvTYPE(topgv) != SVt_PVGV)
769 name = SvPV_nomg(meth, len);
770 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
772 if ((cand_cv = GvCV(topgv))) {
773 /* If genuine method or valid cache entry, use it */
774 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
778 /* stale cache entry, junk it and move on */
779 SvREFCNT_dec_NN(cand_cv);
780 GvCV_set(topgv, NULL);
785 else if (GvCVGEN(topgv) == topgen_cmp) {
786 /* cache indicates no such method definitively */
789 else if (stash == cachestash
790 && len > 1 /* shortest is uc */
791 && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
792 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
796 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
797 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
798 items = AvFILLp(linear_av); /* no +1, to skip over self */
800 linear_sv = *linear_svp++;
802 cstash = gv_stashsv(linear_sv, 0);
805 if ( ckWARN(WARN_SYNTAX)) {
806 if( /* these are loaded from Perl_Gv_AMupdate() one way or another */
807 ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */
808 || ( memEQs( name, len, "DESTROY") )
810 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
811 "Can't locate package %" SVf " for @%" HEKf "::ISA",
813 HEKfARG(HvNAME_HEK(stash)));
815 } else if( memEQs( name, len, "AUTOLOAD") ) {
816 /* gobble this warning */
818 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
819 "While trying to resolve method call %.*s->%.*s()"
820 " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA"
821 " (perhaps you forgot to load \"%" SVf "\"?)",
822 (int) hvnamelen, hvname,
825 (int) hvnamelen, hvname,
834 gvp = (GV**)hv_common(
835 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
838 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
839 const char *hvname = HvNAME(cstash); assert(hvname);
840 if (strBEGINs(hvname, "CORE")
842 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
848 else candidate = *gvp;
851 if (SvTYPE(candidate) != SVt_PVGV)
852 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
853 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
855 * Found real method, cache method in topgv if:
856 * 1. topgv has no synonyms (else inheritance crosses wires)
857 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
859 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
860 CV *old_cv = GvCV(topgv);
861 SvREFCNT_dec(old_cv);
862 SvREFCNT_inc_simple_void_NN(cand_cv);
863 GvCV_set(topgv, cand_cv);
864 GvCVGEN(topgv) = topgen_cmp;
870 /* Check UNIVERSAL without caching */
871 if(level == 0 || level == -1) {
872 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
875 cand_cv = GvCV(candidate);
876 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
877 CV *old_cv = GvCV(topgv);
878 SvREFCNT_dec(old_cv);
879 SvREFCNT_inc_simple_void_NN(cand_cv);
880 GvCV_set(topgv, cand_cv);
881 GvCVGEN(topgv) = topgen_cmp;
887 if (topgv && GvREFCNT(topgv) == 1) {
888 /* cache the fact that the method is not defined */
889 GvCVGEN(topgv) = topgen_cmp;
896 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
898 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
899 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
903 =for apidoc gv_fetchmeth_autoload
905 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
908 =for apidoc gv_fetchmeth_sv_autoload
910 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
911 of an SV instead of a string/length pair.
917 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
921 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
922 namepv = SvPV(namesv, namelen);
925 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
929 =for apidoc gv_fetchmeth_pv_autoload
931 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
932 instead of a string/length pair.
938 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
940 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
941 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
945 =for apidoc gv_fetchmeth_pvn_autoload
947 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
948 Returns a glob for the subroutine.
950 For an autoloaded subroutine without a GV, will create a GV even
951 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
952 of the result may be zero.
954 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
960 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
962 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
964 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
971 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
972 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
974 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
977 if (!(CvROOT(cv) || CvXSUB(cv)))
979 /* Have an autoload */
980 if (level < 0) /* Cannot do without a stub */
981 gv_fetchmeth_pvn(stash, name, len, 0, flags);
982 gvp = (GV**)hv_fetch(stash, name,
983 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
992 =for apidoc gv_fetchmethod_autoload
994 Returns the glob which contains the subroutine to call to invoke the method
995 on the C<stash>. In fact in the presence of autoloading this may be the
996 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
999 The third parameter of C<gv_fetchmethod_autoload> determines whether
1000 AUTOLOAD lookup is performed if the given method is not present: non-zero
1001 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
1002 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
1003 with a non-zero C<autoload> parameter.
1005 These functions grant C<"SUPER"> token
1006 as a prefix of the method name. Note
1007 that if you want to keep the returned glob for a long time, you need to
1008 check for it being "AUTOLOAD", since at the later time the call may load a
1009 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
1010 created as a side effect to do this.
1012 These functions have the same side-effects as C<gv_fetchmeth> with
1013 C<level==0>. The warning against passing the GV returned by
1014 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
1020 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
1022 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
1024 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1028 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1032 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1033 namepv = SvPV(namesv, namelen);
1036 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1040 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1042 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1043 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1047 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1049 const char * const origname = name;
1050 const char * const name_end = name + len;
1051 const char *last_separator = NULL;
1054 SV *const error_report = MUTABLE_SV(stash);
1055 const U32 autoload = flags & GV_AUTOLOAD;
1056 const U32 do_croak = flags & GV_CROAK;
1057 const U32 is_utf8 = flags & SVf_UTF8;
1059 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1061 if (SvTYPE(stash) < SVt_PVHV)
1064 /* The only way stash can become NULL later on is if last_separator is set,
1065 which in turn means that there is no need for a SVt_PVHV case
1066 the error reporting code. */
1070 /* check if the method name is fully qualified or
1071 * not, and separate the package name from the actual
1074 * leaves last_separator pointing to the beginning of the
1075 * last package separator (either ' or ::) or 0
1076 * if none was found.
1078 * leaves name pointing at the beginning of the
1081 const char *name_cursor = name;
1082 const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1083 for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1084 if (*name_cursor == '\'') {
1085 last_separator = name_cursor;
1086 name = name_cursor + 1;
1088 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1089 last_separator = name_cursor++;
1090 name = name_cursor + 1;
1095 /* did we find a separator? */
1096 if (last_separator) {
1097 STRLEN sep_len= last_separator - origname;
1098 if ( memEQs(origname, sep_len, "SUPER")) {
1099 /* ->SUPER::method should really be looked up in original stash */
1100 stash = CopSTASH(PL_curcop);
1102 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1103 origname, HvENAME_get(stash), name) );
1105 else if ( sep_len >= 7 &&
1106 strBEGINs(last_separator - 7, "::SUPER")) {
1107 /* don't autovifify if ->NoSuchStash::SUPER::method */
1108 stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1109 if (stash) flags |= GV_SUPER;
1112 /* don't autovifify if ->NoSuchStash::method */
1113 stash = gv_stashpvn(origname, sep_len, is_utf8);
1118 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1120 /* This is the special case that exempts Foo->import and
1121 Foo->unimport from being an error even if there's no
1122 import/unimport subroutine */
1123 if (strEQ(name,"import") || strEQ(name,"unimport")) {
1124 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1126 } else if (autoload)
1127 gv = gv_autoload_pvn(
1128 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1130 if (!gv && do_croak) {
1131 /* Right now this is exclusively for the benefit of S_method_common
1134 /* If we can't find an IO::File method, it might be a call on
1135 * a filehandle. If IO:File has not been loaded, try to
1136 * require it first instead of croaking */
1137 const char *stash_name = HvNAME_get(stash);
1138 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1139 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1140 STR_WITH_LEN("IO/File.pm"), 0,
1141 HV_FETCH_ISEXISTS, NULL, 0)
1143 require_pv("IO/File.pm");
1144 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1149 "Can't locate object method \"%" UTF8f
1150 "\" via package \"%" HEKf "\"",
1151 UTF8fARG(is_utf8, name_end - name, name),
1152 HEKfARG(HvNAME_HEK(stash)));
1157 if (last_separator) {
1158 packnamesv = newSVpvn_flags(origname, last_separator - origname,
1159 SVs_TEMP | is_utf8);
1161 packnamesv = error_report;
1165 "Can't locate object method \"%" UTF8f
1166 "\" via package \"%" SVf "\""
1167 " (perhaps you forgot to load \"%" SVf "\"?)",
1168 UTF8fARG(is_utf8, name_end - name, name),
1169 SVfARG(packnamesv), SVfARG(packnamesv));
1173 else if (autoload) {
1174 CV* const cv = GvCV(gv);
1175 if (!CvROOT(cv) && !CvXSUB(cv)) {
1179 if (CvANON(cv) || CvLEXICAL(cv))
1183 if (GvCV(stubgv) != cv) /* orphaned import */
1186 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1187 GvNAME(stubgv), GvNAMELEN(stubgv),
1188 GV_AUTOLOAD_ISMETHOD
1189 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1199 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1203 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1204 namepv = SvPV(namesv, namelen);
1207 return gv_autoload_pvn(stash, namepv, namelen, flags);
1211 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1213 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1214 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1218 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1225 SV *packname = NULL;
1226 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1228 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1230 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1233 if (SvTYPE(stash) < SVt_PVHV) {
1234 STRLEN packname_len = 0;
1235 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1236 packname = newSVpvn_flags(packname_ptr, packname_len,
1237 SVs_TEMP | SvUTF8(stash));
1241 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1242 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1244 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1245 is_utf8 | (flags & GV_SUPER))))
1249 if (!(CvROOT(cv) || CvXSUB(cv)))
1253 * Inheriting AUTOLOAD for non-methods no longer works
1256 !(flags & GV_AUTOLOAD_ISMETHOD)
1257 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1259 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1260 "::%" UTF8f "() is no longer allowed",
1262 UTF8fARG(is_utf8, len, name));
1265 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1266 * and split that value on the last '::', pass along the same data
1267 * via the SvPVX field in the CV, and the stash in CvSTASH.
1269 * Due to an unfortunate accident of history, the SvPVX field
1270 * serves two purposes. It is also used for the subroutine's pro-
1271 * type. Since SvPVX has been documented as returning the sub name
1272 * for a long time, but not as returning the prototype, we have
1273 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1276 * We put the prototype in the same allocated buffer, but after
1277 * the sub name. The SvPOK flag indicates the presence of a proto-
1278 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1279 * If both flags are on, then SvLEN is used to indicate the end of
1280 * the prototype (artificially lower than what is actually allo-
1281 * cated), at the risk of having to reallocate a few bytes unneces-
1282 * sarily--but that should happen very rarely, if ever.
1284 * We use SvUTF8 for both prototypes and sub names, so if one is
1285 * UTF8, the other must be upgraded.
1287 CvSTASH_set(cv, stash);
1288 if (SvPOK(cv)) { /* Ouch! */
1289 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1291 const char *proto = CvPROTO(cv);
1294 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1295 ulen = SvCUR(tmpsv);
1296 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1298 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1300 SvTEMP_on(tmpsv); /* Allow theft */
1301 sv_setsv_nomg((SV *)cv, tmpsv);
1303 SvREFCNT_dec_NN(tmpsv);
1304 SvLEN_set(cv, SvCUR(cv) + 1);
1305 SvCUR_set(cv, ulen);
1308 sv_setpvn((SV *)cv, name, len);
1312 else SvUTF8_off(cv);
1318 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1319 * The subroutine's original name may not be "AUTOLOAD", so we don't
1320 * use that, but for lack of anything better we will use the sub's
1321 * original package to look up $AUTOLOAD.
1323 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1324 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1328 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1329 #ifdef PERL_DONT_CREATE_GVSV
1330 GvSV(vargv) = newSV(0);
1334 varsv = GvSVn(vargv);
1335 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1336 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1337 sv_setsv(varsv, packname);
1338 sv_catpvs(varsv, "::");
1339 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1340 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1343 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1351 /* require_tie_mod() internal routine for requiring a module
1352 * that implements the logic of automatic ties like %! and %-
1353 * It loads the module and then calls the _tie_it subroutine
1354 * with the passed gv as an argument.
1356 * The "gv" parameter should be the glob.
1357 * "varname" holds the 1-char name of the var, used for error messages.
1358 * "namesv" holds the module name. Its refcount will be decremented.
1359 * "flags": if flag & 1 then save the scalar before loading.
1360 * For the protection of $! to work (it is set by this routine)
1361 * the sv slot must already be magicalized.
1364 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1365 STRLEN len, const U32 flags)
1367 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1369 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1371 /* If it is not tied */
1372 if (!target || !SvRMAGICAL(target)
1374 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1380 PUSHSTACKi(PERLSI_MAGIC);
1383 #define GET_HV_FETCH_TIE_FUNC \
1384 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
1386 && ( (isGV(*gvp) && GvCV(*gvp)) \
1387 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
1390 /* Load the module if it is not loaded. */
1391 if (!(stash = gv_stashpvn(name, len, 0))
1392 || ! GET_HV_FETCH_TIE_FUNC)
1394 SV * const module = newSVpvn(name, len);
1395 const char type = varname == '[' ? '$' : '%';
1398 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1399 assert(sp == PL_stack_sp);
1400 stash = gv_stashpvn(name, len, 0);
1402 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1403 type, varname, name);
1404 else if (! GET_HV_FETCH_TIE_FUNC)
1405 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1406 type, varname, name);
1408 /* Now call the tie function. It should be in *gvp. */
1409 assert(gvp); assert(*gvp);
1413 call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1419 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1420 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1421 * a true string WITHOUT a len.
1423 #define require_tie_mod_s(gv, varname, name, flags) \
1424 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1427 =for apidoc gv_stashpv
1429 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1430 determine the length of C<name>, then calls C<gv_stashpvn()>.
1436 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1438 PERL_ARGS_ASSERT_GV_STASHPV;
1439 return gv_stashpvn(name, strlen(name), create);
1443 =for apidoc gv_stashpvn
1445 Returns a pointer to the stash for a specified package. The C<namelen>
1446 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1447 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1448 created if it does not already exist. If the package does not exist and
1449 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1452 Flags may be one of:
1461 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1463 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1464 recommended for performance reasons.
1466 =for apidoc Amnh||GV_ADD
1467 =for apidoc Amnh||GV_NOADD_NOINIT
1468 =for apidoc Amnh||GV_NOINIT
1469 =for apidoc Amnh||GV_NOEXPAND
1470 =for apidoc Amnh||GV_ADDMG
1471 =for apidoc Amnh||SVf_UTF8
1477 gv_stashpvn_internal
1479 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1480 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1484 PERL_STATIC_INLINE HV*
1485 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1491 U32 tmplen = namelen + 2;
1493 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1495 if (tmplen <= sizeof smallbuf)
1498 Newx(tmpbuf, tmplen, char);
1499 Copy(name, tmpbuf, namelen, char);
1500 tmpbuf[namelen] = ':';
1501 tmpbuf[namelen+1] = ':';
1502 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1503 if (tmpbuf != smallbuf)
1505 if (!tmpgv || !isGV_with_GP(tmpgv))
1507 stash = GvHV(tmpgv);
1508 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1510 if (!HvNAME_get(stash)) {
1511 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1513 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1514 /* If the containing stash has multiple effective
1515 names, see that this one gets them, too. */
1516 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1517 mro_package_moved(stash, NULL, tmpgv, 1);
1523 gv_stashsvpvn_cached
1525 Returns a pointer to the stash for a specified package, possibly
1526 cached. Implements both C<gv_stashpvn> and C<gv_stashsv>.
1528 Requires one of either namesv or namepv to be non-null.
1530 See C<L</gv_stashpvn>> for details on "flags".
1532 Note the sv interface is strongly preferred for performance reasons.
1536 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1537 assert(namesv || name)
1540 Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1545 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1547 he = (HE *)hv_common(
1548 PL_stashcache, namesv, name, namelen,
1549 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1556 hv = INT2PTR(HV*, SvIVX(sv));
1557 assert(SvTYPE(hv) == SVt_PVHV);
1560 else if (flags & GV_CACHE_ONLY) return NULL;
1563 if (SvOK(namesv)) { /* prevent double uninit warning */
1565 name = SvPV_const(namesv, len);
1567 flags |= SvUTF8(namesv);
1569 name = ""; namelen = 0;
1572 stash = gv_stashpvn_internal(name, namelen, flags);
1574 if (stash && namelen) {
1575 SV* const ref = newSViv(PTR2IV(stash));
1576 (void)hv_store(PL_stashcache, name,
1577 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1584 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1586 PERL_ARGS_ASSERT_GV_STASHPVN;
1587 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1591 =for apidoc gv_stashsv
1593 Returns a pointer to the stash for a specified package. See
1596 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1603 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1605 PERL_ARGS_ASSERT_GV_STASHSV;
1606 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1611 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1612 PERL_ARGS_ASSERT_GV_FETCHPV;
1613 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1617 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1619 const char * const nambeg =
1620 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1621 PERL_ARGS_ASSERT_GV_FETCHSV;
1622 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1625 PERL_STATIC_INLINE void
1626 S_gv_magicalize_isa(pTHX_ GV *gv)
1630 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1634 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1638 /* This function grabs name and tries to split a stash and glob
1639 * from its contents. TODO better description, comments
1641 * If the function returns TRUE and 'name == name_end', then
1642 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1644 PERL_STATIC_INLINE bool
1645 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1646 STRLEN *len, const char *nambeg, STRLEN full_len,
1647 const U32 is_utf8, const I32 add)
1649 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1650 const char *name_cursor;
1651 const char *const name_end = nambeg + full_len;
1652 const char *const name_em1 = name_end - 1;
1653 char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1655 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1659 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1661 /* accidental stringify on a GV? */
1665 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1666 if (name_cursor < name_em1 &&
1667 ((*name_cursor == ':' && name_cursor[1] == ':')
1668 || *name_cursor == '\''))
1671 *stash = PL_defstash;
1672 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1675 *len = name_cursor - *name;
1676 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1679 if (*name_cursor == ':') {
1683 else { /* using ' for package separator */
1684 /* use our pre-allocated buffer when possible to save a malloc */
1686 if ( *len+2 <= sizeof smallbuf)
1689 /* only malloc once if needed */
1690 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1691 Newx(tmpfullbuf, full_len+2, char);
1692 tmpbuf = tmpfullbuf;
1694 Copy(*name, tmpbuf, *len, char);
1695 tmpbuf[(*len)++] = ':';
1696 tmpbuf[(*len)++] = ':';
1699 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1700 *gv = gvp ? *gvp : NULL;
1701 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1704 /* here we know that *gv && *gv != &PL_sv_undef */
1705 if (SvTYPE(*gv) != SVt_PVGV)
1706 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1710 if (!(*stash = GvHV(*gv))) {
1711 *stash = GvHV(*gv) = newHV();
1712 if (!HvNAME_get(*stash)) {
1713 if (GvSTASH(*gv) == PL_defstash && *len == 6
1714 && strBEGINs(*name, "CORE"))
1715 hv_name_sets(*stash, "CORE", 0);
1718 *stash, nambeg, name_cursor-nambeg, is_utf8
1720 /* If the containing stash has multiple effective
1721 names, see that this one gets them, too. */
1722 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1723 mro_package_moved(*stash, NULL, *gv, 1);
1726 else if (!HvNAME_get(*stash))
1727 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1730 if (*name_cursor == ':')
1732 *name = name_cursor+1;
1733 if (*name == name_end) {
1735 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1736 if (SvTYPE(*gv) != SVt_PVGV) {
1737 gv_init_pvn(*gv, PL_defstash, "main::", 6,
1740 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1747 *len = name_cursor - *name;
1749 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1752 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1757 /* Checks if an unqualified name is in the main stash */
1758 PERL_STATIC_INLINE bool
1759 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1761 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1763 /* If it's an alphanumeric variable */
1764 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1765 /* Some "normal" variables are always in main::,
1766 * like INC or STDOUT.
1774 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1775 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1776 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1780 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1785 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1786 && name[3] == 'I' && name[4] == 'N')
1790 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1791 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1792 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1796 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1797 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1803 /* *{""}, or a special variable like $@ */
1811 /* This function is called if parse_gv_stash_name() failed to
1812 * find a stash, or if GV_NOTQUAL or an empty name was passed
1813 * to gv_fetchpvn_flags.
1815 * It returns FALSE if the default stash can't be found nor created,
1816 * which might happen during global destruction.
1818 PERL_STATIC_INLINE bool
1819 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1820 const U32 is_utf8, const I32 add,
1821 const svtype sv_type)
1823 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1825 /* No stash in name, so see how we can default */
1827 if ( gv_is_in_main(name, len, is_utf8) ) {
1828 *stash = PL_defstash;
1831 if (IN_PERL_COMPILETIME) {
1832 *stash = PL_curstash;
1833 if (add && (PL_hints & HINT_STRICT_VARS) &&
1834 sv_type != SVt_PVCV &&
1835 sv_type != SVt_PVGV &&
1836 sv_type != SVt_PVFM &&
1837 sv_type != SVt_PVIO &&
1838 !(len == 1 && sv_type == SVt_PV &&
1839 (*name == 'a' || *name == 'b')) )
1841 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1842 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1843 SvTYPE(*gvp) != SVt_PVGV)
1847 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1848 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1849 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1851 /* diag_listed_as: Variable "%s" is not imported%s */
1853 aTHX_ packWARN(WARN_MISC),
1854 "Variable \"%c%" UTF8f "\" is not imported",
1855 sv_type == SVt_PVAV ? '@' :
1856 sv_type == SVt_PVHV ? '%' : '$',
1857 UTF8fARG(is_utf8, len, name));
1860 aTHX_ packWARN(WARN_MISC),
1861 "\t(Did you mean &%" UTF8f " instead?)\n",
1862 UTF8fARG(is_utf8, len, name)
1869 /* Use the current op's stash */
1870 *stash = CopSTASH(PL_curcop);
1875 if (add && !PL_in_clean_all) {
1877 qerror(Perl_mess(aTHX_
1878 "Global symbol \"%s%" UTF8f
1879 "\" requires explicit package name (did you forget to "
1880 "declare \"my %s%" UTF8f "\"?)",
1881 (sv_type == SVt_PV ? "$"
1882 : sv_type == SVt_PVAV ? "@"
1883 : sv_type == SVt_PVHV ? "%"
1884 : ""), UTF8fARG(is_utf8, len, name),
1885 (sv_type == SVt_PV ? "$"
1886 : sv_type == SVt_PVAV ? "@"
1887 : sv_type == SVt_PVHV ? "%"
1888 : ""), UTF8fARG(is_utf8, len, name)));
1889 /* To maintain the output of errors after the strict exception
1890 * above, and to keep compat with older releases, rather than
1891 * placing the variables in the pad, we place
1892 * them in the <none>:: stash.
1894 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1896 /* symbol table under destruction */
1905 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1911 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
1912 redefine SvREADONLY_on for that purpose. We don’t use it later on in
1914 #undef SvREADONLY_on
1915 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1917 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1919 * Note that it does not insert the GV into the stash prior to
1920 * magicalization, which some variables require need in order
1921 * to work (like %+, %-, %!), so callers must take care of
1924 * It returns true if the gv did turn out to be magical one; i.e.,
1925 * if gv_magicalize actually did something.
1927 PERL_STATIC_INLINE bool
1928 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1929 const svtype sv_type)
1933 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1935 if (stash != PL_defstash) { /* not the main stash */
1936 /* We only have to check for a few names here: a, b, EXPORT, ISA
1937 and VERSION. All the others apply only to the main stash or to
1938 CORE (which is checked right after this). */
1943 len >= 6 && name[1] == 'X' &&
1944 (memEQs(name, len, "EXPORT")
1945 ||memEQs(name, len, "EXPORT_OK")
1946 ||memEQs(name, len, "EXPORT_FAIL")
1947 ||memEQs(name, len, "EXPORT_TAGS"))
1952 if (memEQs(name, len, "ISA"))
1953 gv_magicalize_isa(gv);
1956 if (memEQs(name, len, "VERSION"))
1960 if (stash == PL_debstash && memEQs(name, len, "args")) {
1961 GvMULTI_on(gv_AVadd(gv));
1966 if (len == 1 && sv_type == SVt_PV)
1975 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1976 /* Avoid null warning: */
1977 const char * const stashname = HvNAME(stash); assert(stashname);
1978 if (strBEGINs(stashname, "CORE"))
1979 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1986 /* Nothing else to do.
1987 The compiler will probably turn the switch statement into a
1988 branch table. Make sure we avoid even that small overhead for
1989 the common case of lower case variable names. (On EBCDIC
1990 platforms, we can't just do:
1991 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1992 because cases like '\027' in the switch statement below are
1993 C1 (non-ASCII) controls on those platforms, so the remapping
1994 would make them larger than 'V')
2001 if (memEQs(name, len, "ARGV")) {
2002 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
2004 else if (memEQs(name, len, "ARGVOUT")) {
2010 len >= 6 && name[1] == 'X' &&
2011 (memEQs(name, len, "EXPORT")
2012 ||memEQs(name, len, "EXPORT_OK")
2013 ||memEQs(name, len, "EXPORT_FAIL")
2014 ||memEQs(name, len, "EXPORT_TAGS"))
2019 if (memEQs(name, len, "ISA")) {
2020 gv_magicalize_isa(gv);
2024 if (memEQs(name, len, "SIG")) {
2027 if (!PL_psig_name) {
2028 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
2029 Newxz(PL_psig_pend, SIG_SIZE, int);
2030 PL_psig_ptr = PL_psig_name + SIG_SIZE;
2032 /* I think that the only way to get here is to re-use an
2033 embedded perl interpreter, where the previous
2034 use didn't clean up fully because
2035 PL_perl_destruct_level was 0. I'm not sure that we
2036 "support" that, in that I suspect in that scenario
2037 there are sufficient other garbage values left in the
2038 interpreter structure that something else will crash
2039 before we get here. I suspect that this is one of
2040 those "doctor, it hurts when I do this" bugs. */
2041 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2042 Zero(PL_psig_pend, SIG_SIZE, int);
2046 hv_magic(hv, NULL, PERL_MAGIC_sig);
2047 for (i = 1; i < SIG_SIZE; i++) {
2048 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2050 sv_setsv(*init, &PL_sv_undef);
2055 if (memEQs(name, len, "VERSION"))
2058 case '\003': /* $^CHILD_ERROR_NATIVE */
2059 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2061 /* @{^CAPTURE} %{^CAPTURE} */
2062 if (memEQs(name, len, "\003APTURE")) {
2063 AV* const av = GvAVn(gv);
2064 const Size_t n = *name;
2066 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2069 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2071 } else /* %{^CAPTURE_ALL} */
2072 if (memEQs(name, len, "\003APTURE_ALL")) {
2073 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2076 case '\005': /* $^ENCODING */
2077 if (memEQs(name, len, "\005NCODING"))
2080 case '\007': /* $^GLOBAL_PHASE */
2081 if (memEQs(name, len, "\007LOBAL_PHASE"))
2084 case '\014': /* $^LAST_FH */
2085 if (memEQs(name, len, "\014AST_FH"))
2088 case '\015': /* $^MATCH */
2089 if (memEQs(name, len, "\015ATCH")) {
2090 paren = RX_BUFF_IDX_CARET_FULLMATCH;
2094 case '\017': /* $^OPEN */
2095 if (memEQs(name, len, "\017PEN"))
2098 case '\020': /* $^PREMATCH $^POSTMATCH */
2099 if (memEQs(name, len, "\020REMATCH")) {
2100 paren = RX_BUFF_IDX_CARET_PREMATCH;
2103 if (memEQs(name, len, "\020OSTMATCH")) {
2104 paren = RX_BUFF_IDX_CARET_POSTMATCH;
2109 if (memEQs(name, len, "\023AFE_LOCALES"))
2112 case '\024': /* ${^TAINT} */
2113 if (memEQs(name, len, "\024AINT"))
2116 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
2117 if (memEQs(name, len, "\025NICODE"))
2119 if (memEQs(name, len, "\025TF8LOCALE"))
2121 if (memEQs(name, len, "\025TF8CACHE"))
2124 case '\027': /* $^WARNING_BITS */
2125 if (memEQs(name, len, "\027ARNING_BITS"))
2128 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2142 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2145 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2147 /* XXX why are we using a SSize_t? */
2148 paren = (SSize_t)(I32)uv;
2154 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2155 be case '\0' in this switch statement (ie a default case) */
2158 paren = RX_BUFF_IDX_FULLMATCH;
2161 paren = RX_BUFF_IDX_PREMATCH;
2164 paren = RX_BUFF_IDX_POSTMATCH;
2166 #ifdef PERL_SAWAMPERSAND
2168 sv_type == SVt_PVAV ||
2169 sv_type == SVt_PVHV ||
2170 sv_type == SVt_PVCV ||
2171 sv_type == SVt_PVFM ||
2173 )) { PL_sawampersand |=
2177 ? SAWAMPERSAND_MIDDLE
2178 : SAWAMPERSAND_RIGHT;
2191 paren = *name - '0';
2194 /* Flag the capture variables with a NULL mg_ptr
2195 Use mg_len for the array index to lookup. */
2196 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2200 sv_setpv(GvSVn(gv),PL_chopset);
2204 #ifdef COMPLEX_STATUS
2205 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2211 /* If %! has been used, automatically load Errno.pm. */
2213 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2215 /* magicalization must be done before require_tie_mod_s is called */
2216 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2217 require_tie_mod_s(gv, '!', "Errno", 1);
2220 case '-': /* $-, %-, @- */
2221 case '+': /* $+, %+, @+ */
2222 GvMULTI_on(gv); /* no used once warnings here */
2224 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2226 SvREADONLY_on(GvSVn(gv));
2229 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2230 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2233 AV* const av = GvAVn(gv);
2234 const Size_t n = *name;
2236 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2242 if (sv_type == SVt_PV)
2243 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2244 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2246 case '\010': /* $^H */
2248 HV *const hv = GvHVn(gv);
2249 hv_magic(hv, NULL, PERL_MAGIC_hints);
2252 case '\023': /* $^S */
2254 SvREADONLY_on(GvSVn(gv));
2271 case '\001': /* $^A */
2272 case '\003': /* $^C */
2273 case '\004': /* $^D */
2274 case '\005': /* $^E */
2275 case '\006': /* $^F */
2276 case '\011': /* $^I, NOT \t in EBCDIC */
2277 case '\016': /* $^N */
2278 case '\017': /* $^O */
2279 case '\020': /* $^P */
2280 case '\024': /* $^T */
2281 case '\027': /* $^W */
2283 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2286 case '\014': /* $^L */
2287 sv_setpvs(GvSVn(gv),"\f");
2290 sv_setpvs(GvSVn(gv),"\034");
2294 SV * const sv = GvSV(gv);
2295 if (!sv_derived_from(PL_patchlevel, "version"))
2296 upg_version(PL_patchlevel, TRUE);
2297 GvSV(gv) = vnumify(PL_patchlevel);
2298 SvREADONLY_on(GvSV(gv));
2302 case '\026': /* $^V */
2304 SV * const sv = GvSV(gv);
2305 GvSV(gv) = new_version(PL_patchlevel);
2306 SvREADONLY_on(GvSV(gv));
2312 if (sv_type == SVt_PV)
2318 /* Return true if we actually did something. */
2319 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2321 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2326 /* If we do ever start using this later on in the file, we need to make
2327 sure we don’t accidentally use the wrong definition. */
2328 #undef SvREADONLY_on
2330 /* This function is called when the stash already holds the GV of the magic
2331 * variable we're looking for, but we need to check that it has the correct
2332 * kind of magic. For example, if someone first uses $! and then %!, the
2333 * latter would end up here, and we add the Errno tie to the HASH slot of
2336 PERL_STATIC_INLINE void
2337 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2339 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2341 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2343 require_tie_mod_s(gv, '!', "Errno", 1);
2344 else if (*name == '-' || *name == '+')
2345 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2346 } else if (sv_type == SVt_PV) {
2347 if (*name == '*' || *name == '#') {
2348 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2349 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2352 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2354 #ifdef PERL_SAWAMPERSAND
2356 PL_sawampersand |= SAWAMPERSAND_LEFT;
2360 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2364 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2373 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2374 const svtype sv_type)
2376 const char *name = nambeg;
2381 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2382 const I32 no_expand = flags & GV_NOEXPAND;
2383 const I32 add = flags & ~GV_NOADD_MASK;
2384 const U32 is_utf8 = flags & SVf_UTF8;
2385 bool addmg = cBOOL(flags & GV_ADDMG);
2386 const char *const name_end = nambeg + full_len;
2389 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2391 /* If we have GV_NOTQUAL, the caller promised that
2392 * there is no stash, so we can skip the check.
2393 * Similarly if full_len is 0, since then we're
2394 * dealing with something like *{""} or ""->foo()
2396 if ((flags & GV_NOTQUAL) || !full_len) {
2399 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2400 if (name == name_end) return gv;
2406 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2410 /* By this point we should have a stash and a name */
2411 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2412 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2413 if (addmg) gv = (GV *)newSV(0);
2416 else gv = *gvp, addmg = 0;
2417 /* From this point on, addmg means gv has not been inserted in the
2420 if (SvTYPE(gv) == SVt_PVGV) {
2421 /* The GV already exists, so return it, but check if we need to do
2422 * anything else with it before that.
2425 /* This is the heuristic that handles if a variable triggers the
2426 * 'used only once' warning. If there's already a GV in the stash
2427 * with this name, then we assume that the variable has been used
2428 * before and turn its MULTI flag on.
2429 * It's a heuristic because it can easily be "tricked", like with
2430 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2431 * not warning about $main::foo being used just once
2434 gv_init_svtype(gv, sv_type);
2435 /* You reach this path once the typeglob has already been created,
2436 either by the same or a different sigil. If this path didn't
2437 exist, then (say) referencing $! first, and %! second would
2438 mean that %! was not handled correctly. */
2439 if (len == 1 && stash == PL_defstash) {
2440 maybe_multimagic_gv(gv, name, sv_type);
2442 else if (sv_type == SVt_PVAV
2443 && memEQs(name, len, "ISA")
2444 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2445 gv_magicalize_isa(gv);
2448 } else if (no_init) {
2452 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2453 * don't expand it to a glob. This is an optimization so that things
2454 * copying constants over, like Exporter, don't have to be rewritten
2455 * to take into account that you can store more than just globs in
2458 else if (no_expand && SvROK(gv)) {
2463 /* Adding a new symbol.
2464 Unless of course there was already something non-GV here, in which case
2465 we want to behave as if there was always a GV here, containing some sort
2467 Otherwise we run the risk of creating things like GvIO, which can cause
2468 subtle bugs. eg the one that tripped up SQL::Translator */
2470 faking_it = SvOK(gv);
2472 if (add & GV_ADDWARN)
2473 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2474 "Had to create %" UTF8f " unexpectedly",
2475 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2476 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2479 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2480 && !ckWARN(WARN_ONCE) )
2485 /* set up magic where warranted */
2486 if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2489 /* gv_magicalize magicalised this gv, so we want it
2490 * stored in the symtab.
2491 * Effectively the caller is asking, ‘Does this gv exist?’
2492 * And we respond, ‘Er, *now* it does!’
2494 (void)hv_store(stash,name,len,(SV *)gv,0);
2498 /* The temporary GV created above */
2499 SvREFCNT_dec_NN(gv);
2503 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2508 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2511 const HV * const hv = GvSTASH(gv);
2513 PERL_ARGS_ASSERT_GV_FULLNAME4;
2515 sv_setpv(sv, prefix ? prefix : "");
2517 if (hv && (name = HvNAME(hv))) {
2518 const STRLEN len = HvNAMELEN(hv);
2519 if (keepmain || ! memBEGINs(name, len, "main")) {
2520 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2524 else sv_catpvs(sv,"__ANON__::");
2525 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2529 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2531 const GV * const egv = GvEGVx(gv);
2533 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2535 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2539 /* recursively scan a stash and any nested stashes looking for entries
2540 * that need the "only used once" warning raised
2544 Perl_gv_check(pTHX_ HV *stash)
2548 PERL_ARGS_ASSERT_GV_CHECK;
2553 assert(HvARRAY(stash));
2555 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2557 /* mark stash is being scanned, to avoid recursing */
2558 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2559 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2562 STRLEN keylen = HeKLEN(entry);
2563 const char * const key = HeKEY(entry);
2565 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
2566 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2568 if (hv != PL_defstash && hv != stash
2570 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2572 gv_check(hv); /* nested package */
2574 else if ( HeKLEN(entry) != 0
2575 && *HeKEY(entry) != '_'
2576 && isIDFIRST_lazy_if_safe(HeKEY(entry),
2577 HeKEY(entry) + HeKLEN(entry),
2581 gv = MUTABLE_GV(HeVAL(entry));
2582 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2585 CopLINE_set(PL_curcop, GvLINE(gv));
2587 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2589 CopFILEGV(PL_curcop)
2590 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2592 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2593 "Name \"%" HEKf "::%" HEKf
2594 "\" used only once: possible typo",
2595 HEKfARG(HvNAME_HEK(stash)),
2596 HEKfARG(GvNAME_HEK(gv)));
2599 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2604 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2606 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2607 assert(!(flags & ~SVf_UTF8));
2609 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2610 UTF8fARG(flags, strlen(pack), pack),
2615 /* hopefully this is only called on local symbol table entries */
2618 Perl_gp_ref(pTHX_ GP *gp)
2625 /* If the GP they asked for a reference to contains
2626 a method cache entry, clear it first, so that we
2627 don't infect them with our cached entry */
2628 SvREFCNT_dec_NN(gp->gp_cv);
2637 Perl_gp_free(pTHX_ GV *gv)
2642 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2644 if (gp->gp_refcnt == 0) {
2645 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2646 "Attempt to free unreferenced glob pointers"
2647 pTHX__FORMAT pTHX__VALUE);
2650 if (gp->gp_refcnt > 1) {
2652 if (gp->gp_egv == gv)
2660 /* Copy and null out all the glob slots, so destructors do not see
2662 HEK * const file_hek = gp->gp_file_hek;
2663 SV * const sv = gp->gp_sv;
2664 AV * const av = gp->gp_av;
2665 HV * const hv = gp->gp_hv;
2666 IO * const io = gp->gp_io;
2667 CV * const cv = gp->gp_cv;
2668 CV * const form = gp->gp_form;
2670 gp->gp_file_hek = NULL;
2679 unshare_hek(file_hek);
2683 /* FIXME - another reference loop GV -> symtab -> GV ?
2684 Somehow gp->gp_hv can end up pointing at freed garbage. */
2685 if (hv && SvTYPE(hv) == SVt_PVHV) {
2686 const HEK *hvname_hek = HvNAME_HEK(hv);
2687 if (PL_stashcache && hvname_hek) {
2688 DEBUG_o(Perl_deb(aTHX_
2689 "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2690 HEKfARG(hvname_hek)));
2691 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2695 if (io && SvREFCNT(io) == 1 && IoIFP(io)
2696 && (IoTYPE(io) == IoTYPE_WRONLY ||
2697 IoTYPE(io) == IoTYPE_RDWR ||
2698 IoTYPE(io) == IoTYPE_APPEND)
2699 && ckWARN_d(WARN_IO)
2700 && IoIFP(io) != PerlIO_stdin()
2701 && IoIFP(io) != PerlIO_stdout()
2702 && IoIFP(io) != PerlIO_stderr()
2703 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2704 io_close(io, gv, FALSE, TRUE);
2709 /* Possibly reallocated by a destructor */
2712 if (!gp->gp_file_hek
2718 && !gp->gp_form) break;
2720 if (--attempts == 0) {
2722 "panic: gp_free failed to free glob pointer - "
2723 "something is repeatedly re-creating entries"
2728 /* Possibly incremented by a destructor doing glob assignment */
2729 if (gp->gp_refcnt > 1) goto borrowed;
2735 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2737 AMT * const amtp = (AMT*)mg->mg_ptr;
2738 PERL_UNUSED_ARG(sv);
2740 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2742 if (amtp && AMT_AMAGIC(amtp)) {
2744 for (i = 1; i < NofAMmeth; i++) {
2745 CV * const cv = amtp->table[i];
2747 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2748 amtp->table[i] = NULL;
2755 /* Updates and caches the CV's */
2757 * 1 on success and there is some overload
2758 * 0 if there is no overload
2759 * -1 if some error occurred and it couldn't croak
2763 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2765 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2767 const struct mro_meta* stash_meta = HvMROMETA(stash);
2770 PERL_ARGS_ASSERT_GV_AMUPDATE;
2772 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2774 const AMT * const amtp = (AMT*)mg->mg_ptr;
2775 if (amtp->was_ok_sub == newgen) {
2776 return AMT_AMAGIC(amtp) ? 1 : 0;
2778 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2781 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2784 amt.was_ok_sub = newgen;
2785 amt.fallback = AMGfallNO;
2791 bool deref_seen = 0;
2794 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2796 /* Try to find via inheritance. */
2797 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2798 SV * const sv = gv ? GvSV(gv) : NULL;
2803 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2806 #ifdef PERL_DONT_CREATE_GVSV
2808 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2811 else if (SvTRUE(sv))
2812 /* don't need to set overloading here because fallback => 1
2813 * is the default setting for classes without overloading */
2814 amt.fallback=AMGfallYES;
2815 else if (SvOK(sv)) {
2816 amt.fallback=AMGfallNEVER;
2823 assert(SvOOK(stash));
2824 /* initially assume the worst */
2825 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2827 for (i = 1; i < NofAMmeth; i++) {
2828 const char * const cooky = PL_AMG_names[i];
2829 /* Human-readable form, for debugging: */
2830 const char * const cp = AMG_id2name(i);
2831 const STRLEN l = PL_AMG_namelens[i];
2833 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2834 cp, HvNAME_get(stash)) );
2835 /* don't fill the cache while looking up!
2836 Creation of inheritance stubs in intermediate packages may
2837 conflict with the logic of runtime method substitution.
2838 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2839 then we could have created stubs for "(+0" in A and C too.
2840 But if B overloads "bool", we may want to use it for
2841 numifying instead of C's "+0". */
2842 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2844 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2845 const HEK * const gvhek = CvGvNAME_HEK(cv);
2846 const HEK * const stashek =
2847 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2848 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
2850 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
2851 /* This is a hack to support autoloading..., while
2852 knowing *which* methods were declared as overloaded. */
2853 /* GvSV contains the name of the method. */
2855 SV *gvsv = GvSV(gv);
2857 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
2858 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2859 (void*)GvSV(gv), cp, HvNAME(stash)) );
2860 if (!gvsv || !SvPOK(gvsv)
2861 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2863 /* Can be an import stub (created by "can"). */
2868 const SV * const name = (gvsv && SvPOK(gvsv))
2870 : newSVpvs_flags("???", SVs_TEMP);
2871 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2872 Perl_croak(aTHX_ "%s method \"%" SVf256
2873 "\" overloading \"%s\" "\
2874 "in package \"%" HEKf256 "\"",
2875 (GvCVGEN(gv) ? "Stub found while resolving"
2883 cv = GvCV(gv = ngv);
2885 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2886 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2887 GvNAME(CvGV(cv))) );
2889 } else if (gv) { /* Autoloaded... */
2890 cv = MUTABLE_CV(gv);
2893 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2909 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2910 * NB - aux var invalid here, HvARRAY() could have been
2911 * reallocated since it was assigned to */
2912 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2915 AMT_AMAGIC_on(&amt);
2916 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2917 (char*)&amt, sizeof(AMT));
2921 /* Here we have no table: */
2923 AMT_AMAGIC_off(&amt);
2924 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2925 (char*)&amt, sizeof(AMTS));
2931 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2936 struct mro_meta* stash_meta;
2938 if (!stash || !HvNAME_get(stash))
2941 stash_meta = HvMROMETA(stash);
2942 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2944 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2947 if (Gv_AMupdate(stash, 0) == -1)
2949 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2952 amtp = (AMT*)mg->mg_ptr;
2953 if ( amtp->was_ok_sub != newgen )
2955 if (AMT_AMAGIC(amtp)) {
2956 CV * const ret = amtp->table[id];
2957 if (ret && isGV(ret)) { /* Autoloading stab */
2958 /* Passing it through may have resulted in a warning
2959 "Inherited AUTOLOAD for a non-method deprecated", since
2960 our caller is going through a function call, not a method call.
2961 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2962 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2974 /* Implement tryAMAGICun_MG macro.
2975 Do get magic, then see if the stack arg is overloaded and if so call it.
2977 AMGf_numeric apply sv_2num to the stack arg.
2981 Perl_try_amagic_un(pTHX_ int method, int flags) {
2984 SV* const arg = TOPs;
2988 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2989 AMGf_noright | AMGf_unary
2990 | (flags & AMGf_numarg))))
2992 /* where the op is of the form:
2993 * $lex = $x op $y (where the assign is optimised away)
2994 * then assign the returned value to targ and return that;
2995 * otherwise return the value directly
2997 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
2998 && (PL_op->op_private & OPpTARGET_MY))
3001 sv_setsv(TARG, tmpsv);
3011 if ((flags & AMGf_numeric) && SvROK(arg))
3017 /* Implement tryAMAGICbin_MG macro.
3018 Do get magic, then see if the two stack args are overloaded and if so
3021 AMGf_assign op may be called as mutator (eg +=)
3022 AMGf_numeric apply sv_2num to the stack arg.
3026 Perl_try_amagic_bin(pTHX_ int method, int flags) {
3028 SV* const left = TOPm1s;
3029 SV* const right = TOPs;
3035 if (SvAMAGIC(left) || SvAMAGIC(right)) {
3037 /* STACKED implies mutator variant, e.g. $x += 1 */
3038 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3040 tmpsv = amagic_call(left, right, method,
3041 (mutator ? AMGf_assign: 0)
3042 | (flags & AMGf_numarg));
3045 /* where the op is one of the two forms:
3047 * $lex = $x op $y (where the assign is optimised away)
3048 * then assign the returned value to targ and return that;
3049 * otherwise return the value directly
3052 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3053 && (PL_op->op_private & OPpTARGET_MY)))
3056 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3057 sv_setsv(TARG, tmpsv);
3068 if(left==right && SvGMAGICAL(left)) {
3069 SV * const left = sv_newmortal();
3071 /* Print the uninitialized warning now, so it includes the vari-
3074 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3075 sv_setsv_flags(left, &PL_sv_no, 0);
3077 else sv_setsv_flags(left, right, 0);
3080 if (flags & AMGf_numeric) {
3082 *(sp-1) = sv_2num(TOPm1s);
3084 *sp = sv_2num(right);
3090 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3094 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3098 /* return quickly if none of the deref ops are overloaded */
3099 stash = SvSTASH(SvRV(ref));
3100 assert(SvOOK(stash));
3101 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3104 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3105 AMGf_noright | AMGf_unary))) {
3107 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3108 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3109 /* Bail out if it returns us the same reference. */
3116 return tmpsv ? tmpsv : ref;
3120 Perl_amagic_is_enabled(pTHX_ int method)
3122 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3124 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3126 if ( !lex_mask || !SvOK(lex_mask) )
3127 /* overloading lexically disabled */
3129 else if ( lex_mask && SvPOK(lex_mask) ) {
3130 /* we have an entry in the hints hash, check if method has been
3131 * masked by overloading.pm */
3133 const int offset = method / 8;
3134 const int bit = method % 8;
3135 char *pv = SvPV(lex_mask, len);
3137 /* Bit set, so this overloading operator is disabled */
3138 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3145 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3150 CV **cvp=NULL, **ocvp=NULL;
3151 AMT *amtp=NULL, *oamtp=NULL;
3152 int off = 0, off1, lr = 0, notfound = 0;
3153 int postpr = 0, force_cpy = 0;
3154 int assign = AMGf_assign & flags;
3155 const int assignshift = assign ? 1 : 0;
3156 int use_default_op = 0;
3157 int force_scalar = 0;
3163 PERL_ARGS_ASSERT_AMAGIC_CALL;
3165 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3166 if (!amagic_is_enabled(method)) return NULL;
3169 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3170 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3171 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3172 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3173 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3175 && ((cv = cvp[off=method+assignshift])
3176 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3182 cv = cvp[off=method])))) {
3183 lr = -1; /* Call method for left argument */
3185 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3188 /* look for substituted methods */
3189 /* In all the covered cases we should be called with assign==0. */
3193 if ((cv = cvp[off=add_ass_amg])
3194 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3195 right = &PL_sv_yes; lr = -1; assign = 1;
3200 if ((cv = cvp[off = subtr_ass_amg])
3201 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3202 right = &PL_sv_yes; lr = -1; assign = 1;
3206 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3209 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3212 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3215 (void)((cv = cvp[off=bool__amg])
3216 || (cv = cvp[off=numer_amg])
3217 || (cv = cvp[off=string_amg]));
3224 * SV* ref causes confusion with the interpreter variable of
3227 SV* const tmpRef=SvRV(left);
3228 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3230 * Just to be extra cautious. Maybe in some
3231 * additional cases sv_setsv is safe, too.
3233 SV* const newref = newSVsv(tmpRef);
3234 SvOBJECT_on(newref);
3235 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3236 delegate to the stash. */
3237 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3243 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3244 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3245 SV* const nullsv=&PL_sv_zero;
3247 SV* const lessp = amagic_call(left,nullsv,
3248 lt_amg,AMGf_noright);
3249 logic = SvTRUE_NN(lessp);
3251 SV* const lessp = amagic_call(left,nullsv,
3252 ncmp_amg,AMGf_noright);
3253 logic = (SvNV(lessp) < 0);
3256 if (off==subtr_amg) {
3267 if ((cv = cvp[off=subtr_amg])) {
3274 case iter_amg: /* XXXX Eventually should do to_gv. */
3275 case ftest_amg: /* XXXX Eventually should do to_gv. */
3278 return NULL; /* Delegate operation to standard mechanisms. */
3286 return left; /* Delegate operation to standard mechanisms. */
3291 if (!cv) goto not_found;
3292 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3293 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3294 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3295 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3296 ? (amtp = (AMT*)mg->mg_ptr)->table
3298 && (cv = cvp[off=method])) { /* Method for right
3301 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3302 || (ocvp && oamtp->fallback > AMGfallNEVER))
3303 && !(flags & AMGf_unary)) {
3304 /* We look for substitution for
3305 * comparison operations and
3307 if (method==concat_amg || method==concat_ass_amg
3308 || method==repeat_amg || method==repeat_ass_amg) {
3309 return NULL; /* Delegate operation to string conversion */
3331 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3335 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3345 not_found: /* No method found, either report or croak */
3353 return left; /* Delegate operation to standard mechanisms. */
3355 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3356 notfound = 1; lr = -1;
3357 } else if (cvp && (cv=cvp[nomethod_amg])) {
3358 notfound = 1; lr = 1;
3359 } else if ((use_default_op =
3360 (!ocvp || oamtp->fallback >= AMGfallYES)
3361 && (!cvp || amtp->fallback >= AMGfallYES))
3363 /* Skip generating the "no method found" message. */
3367 if (off==-1) off=method;
3368 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3369 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3370 AMG_id2name(method + assignshift),
3371 (flags & AMGf_unary ? " " : "\n\tleft "),
3373 "in overloaded package ":
3374 "has no overloaded magic",
3376 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3379 ",\n\tright argument in overloaded package ":
3382 : ",\n\tright argument has no overloaded magic"),
3384 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3385 SVfARG(&PL_sv_no)));
3386 if (use_default_op) {
3387 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3389 Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3393 force_cpy = force_cpy || assign;
3398 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3399 * operation. we need this to return a value, so that it can be assigned
3400 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3401 * increment or decrement was itself called in void context */
3407 if (off == subtr_amg)
3410 /* in these cases, we're calling an assignment variant of an operator
3411 * (+= rather than +, for instance). regardless of whether it's a
3412 * fallback or not, it always has to return a value, which will be
3413 * assigned to the proper variable later */
3433 /* the copy constructor always needs to return a value */
3437 /* because of the way these are implemented (they don't perform the
3438 * dereferencing themselves, they return a reference that perl then
3439 * dereferences later), they always have to be in scalar context */
3447 /* these don't have an op of their own; they're triggered by their parent
3448 * op, so the context there isn't meaningful ('$a and foo()' in void
3449 * context still needs to pass scalar context on to $a's bool overload) */
3459 DEBUG_o(Perl_deb(aTHX_
3460 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3462 method+assignshift==off? "" :
3464 method+assignshift==off? "" :
3465 AMG_id2name(method+assignshift),
3466 method+assignshift==off? "" : "\")",
3467 flags & AMGf_unary? "" :
3468 lr==1 ? " for right argument": " for left argument",
3469 flags & AMGf_unary? " for argument" : "",
3470 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3471 fl? ",\n\tassignment variant used": "") );
3474 /* Since we use shallow copy during assignment, we need
3475 * to dublicate the contents, probably calling user-supplied
3476 * version of copy operator
3478 /* We need to copy in following cases:
3479 * a) Assignment form was called.
3480 * assignshift==1, assign==T, method + 1 == off
3481 * b) Increment or decrement, called directly.
3482 * assignshift==0, assign==0, method + 0 == off
3483 * c) Increment or decrement, translated to assignment add/subtr.
3484 * assignshift==0, assign==T,
3486 * d) Increment or decrement, translated to nomethod.
3487 * assignshift==0, assign==0,
3489 * e) Assignment form translated to nomethod.
3490 * assignshift==1, assign==T, method + 1 != off
3493 /* off is method, method+assignshift, or a result of opcode substitution.
3494 * In the latter case assignshift==0, so only notfound case is important.
3496 if ( (lr == -1) && ( ( (method + assignshift == off)
3497 && (assign || (method == inc_amg) || (method == dec_amg)))
3500 /* newSVsv does not behave as advertised, so we copy missing
3501 * information by hand */
3502 SV *tmpRef = SvRV(left);
3504 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3505 SvRV_set(left, rv_copy);
3507 SvREFCNT_dec_NN(tmpRef);
3515 const bool oldcatch = CATCH_GET;
3517 /* for multiconcat, we may call overload several times,
3518 * with the context of individual concats being scalar,
3519 * regardless of the overall context of the multiconcat op
3521 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3522 ? G_SCALAR : GIMME_V;
3525 Zero(&myop, 1, BINOP);
3526 myop.op_last = (OP *) &myop;
3527 myop.op_next = NULL;
3528 myop.op_flags = OPf_STACKED;
3532 myop.op_flags |= OPf_WANT_VOID;
3535 if (flags & AMGf_want_list) {
3536 myop.op_flags |= OPf_WANT_LIST;
3541 myop.op_flags |= OPf_WANT_SCALAR;
3545 PUSHSTACKi(PERLSI_OVERLOAD);
3548 PL_op = (OP *) &myop;
3549 if (PERLDB_SUB && PL_curstash != PL_debstash)
3550 PL_op->op_private |= OPpENTERSUB_DB;
3551 Perl_pp_pushmark(aTHX);
3553 EXTEND(SP, notfound + 5);
3554 PUSHs(lr>0? right: left);
3555 PUSHs(lr>0? left: right);
3556 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3558 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3559 AMG_id2namelen(method + assignshift), SVs_TEMP));
3561 else if (flags & AMGf_numarg)
3562 PUSHs(&PL_sv_undef);
3563 if (flags & AMGf_numarg)
3565 PUSHs(MUTABLE_SV(cv));
3569 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3573 nret = SP - (PL_stack_base + oldmark);
3577 /* returning NULL has another meaning, and we check the context
3578 * at the call site too, so this can be differentiated from the
3581 SP = PL_stack_base + oldmark;
3584 if (flags & AMGf_want_list) {
3585 res = sv_2mortal((SV *)newAV());
3586 av_extend((AV *)res, nret);
3588 av_store((AV *)res, nret, POPs);
3599 CATCH_SET(oldcatch);
3606 ans=SvIV(res)<=0; break;
3609 ans=SvIV(res)<0; break;
3612 ans=SvIV(res)>=0; break;
3615 ans=SvIV(res)>0; break;
3618 ans=SvIV(res)==0; break;
3621 ans=SvIV(res)!=0; break;
3624 SvSetSV(left,res); return left;
3626 ans=!SvTRUE_NN(res); break;
3631 } else if (method==copy_amg) {
3633 Perl_croak(aTHX_ "Copy method did not return a reference");
3635 return SvREFCNT_inc(SvRV(res));
3643 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3648 PERL_ARGS_ASSERT_GV_NAME_SET;
3651 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3653 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3654 unshare_hek(GvNAME_HEK(gv));
3657 PERL_HASH(hash, name, len);
3658 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3662 =for apidoc gv_try_downgrade
3664 If the typeglob C<gv> can be expressed more succinctly, by having
3665 something other than a real GV in its place in the stash, replace it
3666 with the optimised form. Basic requirements for this are that C<gv>
3667 is a real typeglob, is sufficiently ordinary, and is only referenced
3668 from its package. This function is meant to be used when a GV has been
3669 looked up in part to see what was there, causing upgrading, but based
3670 on what was found it turns out that the real GV isn't required after all.
3672 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3674 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3675 sub, the typeglob is replaced with a scalar-reference placeholder that
3676 more compactly represents the same thing.
3682 Perl_gv_try_downgrade(pTHX_ GV *gv)
3688 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3690 /* XXX Why and where does this leave dangling pointers during global
3692 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3694 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3695 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3696 isGV_with_GP(gv) && GvGP(gv) &&
3697 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3698 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3699 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3701 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3703 if (SvMAGICAL(gv)) {
3705 /* only backref magic is allowed */
3706 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3708 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3709 if (mg->mg_type != PERL_MAGIC_backref)
3715 HEK *gvnhek = GvNAME_HEK(gv);
3716 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3717 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3718 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3719 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3720 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3721 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3722 (namehek = GvNAME_HEK(gv)) &&
3723 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3725 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3726 const bool imported = !!GvIMPORTED_CV(gv);
3730 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3732 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3733 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3734 STRUCT_OFFSET(XPVIV, xiv_iv));
3735 SvRV_set(gv, value);
3740 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3742 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3744 PERL_ARGS_ASSERT_GV_OVERRIDE;
3745 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3746 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3747 gv = gvp ? *gvp : NULL;
3748 if (gv && !isGV(gv)) {
3749 if (!SvPCS_IMPORTED(gv)) return NULL;
3750 gv_init(gv, PL_globalstash, name, len, 0);
3753 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3759 core_xsub(pTHX_ CV* cv)
3762 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3767 * ex: set ts=8 sts=4 sw=4 et: