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).
328 The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
329 has no flags parameter. If the C<multi> parameter is set, the
330 C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
332 =for apidoc gv_init_pv
334 Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
335 instead of separate char * and length parameters.
337 =for apidoc gv_init_sv
339 Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
340 char * and length parameters. C<flags> is currently unused.
346 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
350 PERL_ARGS_ASSERT_GV_INIT_SV;
351 namepv = SvPV(namesv, namelen);
354 gv_init_pvn(gv, stash, namepv, namelen, flags);
358 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
360 PERL_ARGS_ASSERT_GV_INIT_PV;
361 gv_init_pvn(gv, stash, name, strlen(name), flags);
365 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
367 const U32 old_type = SvTYPE(gv);
368 const bool doproto = old_type > SVt_NULL;
369 char * const proto = (doproto && SvPOK(gv))
370 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
372 const STRLEN protolen = proto ? SvCUR(gv) : 0;
373 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
374 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
375 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
376 const bool really_sub =
377 has_constant && SvTYPE(has_constant) == SVt_PVCV;
378 COP * const old = PL_curcop;
380 PERL_ARGS_ASSERT_GV_INIT_PVN;
381 assert (!(proto && has_constant));
384 /* The constant has to be a scalar, array or subroutine. */
385 switch (SvTYPE(has_constant)) {
389 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
390 sv_reftype(has_constant, 0));
391 NOT_REACHED; /* NOTREACHED */
401 if (old_type < SVt_PVGV) {
402 if (old_type >= SVt_PV)
404 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
412 Safefree(SvPVX_mutable(gv));
417 if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
418 && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
419 || CvSTART(has_constant)->op_type == OP_DBSTATE))
420 PL_curcop = (COP *)CvSTART(has_constant);
421 GvGP_set(gv, Perl_newGP(aTHX_ gv));
425 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
426 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
427 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
428 GvMULTI_on(gv); /* _was_ mentioned */
430 /* Not actually a constant. Just a regular sub. */
431 CV * const cv = (CV *)has_constant;
433 if (CvNAMED(cv) && CvSTASH(cv) == stash && (
434 CvNAME_HEK(cv) == GvNAME_HEK(gv)
435 || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
436 && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
437 && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
438 && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
446 /* newCONSTSUB takes ownership of the reference from us. */
447 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
448 /* In case op.c:S_process_special_blocks stole it: */
450 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
451 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
452 /* If this reference was a copy of another, then the subroutine
453 must have been "imported", by a Perl space assignment to a GV
454 from a reference to CV. */
455 if (exported_constant)
456 GvIMPORTED_CV_on(gv);
457 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
462 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
463 SV_HAS_TRAILING_NUL);
464 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
470 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
472 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
484 #ifdef PERL_DONT_CREATE_GVSV
492 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
493 If we just cast GvSVn(gv) to void, it ignores evaluating it for
500 static void core_xsub(pTHX_ CV* cv);
503 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
504 const char * const name, const STRLEN len)
506 const int code = keyword(name, len, 1);
507 static const char file[] = __FILE__;
508 CV *cv, *oldcompcv = NULL;
510 bool ampable = TRUE; /* &{}-able */
511 COP *oldcurcop = NULL;
512 yy_parser *oldparser = NULL;
513 I32 oldsavestack_ix = 0;
518 if (!code) return NULL; /* Not a keyword */
519 switch (code < 0 ? -code : code) {
520 /* no support for \&CORE::infix;
521 no support for funcs that do not parse like funcs */
522 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
523 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
524 case KEY_default : case KEY_DESTROY:
525 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
526 case KEY_END : case KEY_eq : case KEY_eval :
527 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
528 case KEY_given : case KEY_goto : case KEY_grep :
529 case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
530 case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
531 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
532 case KEY_package: case KEY_print: case KEY_printf:
533 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
534 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
535 case KEY_s : case KEY_say : case KEY_sort :
536 case KEY_state: case KEY_sub :
537 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
538 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
539 case KEY_x : case KEY_xor : case KEY_y :
542 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
543 case KEY_eof : case KEY_exec: case KEY_exists :
548 case KEY_truncate: case KEY_unlink:
553 gv_init(gv, stash, name, len, TRUE);
558 oldcurcop = PL_curcop;
559 oldparser = PL_parser;
560 lex_start(NULL, NULL, 0);
561 oldcompcv = PL_compcv;
562 PL_compcv = NULL; /* Prevent start_subparse from setting
564 oldsavestack_ix = start_subparse(FALSE,0);
568 /* Avoid calling newXS, as it calls us, and things start to
570 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
574 CvXSUB(cv) = core_xsub;
577 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
579 /* XSUBs can't be perl lang/perl5db.pl debugged
580 if (PERLDB_LINE_OR_SAVESRC)
581 (void)gv_fetchfile(file); */
582 CvFILE(cv) = (char *)file;
583 /* XXX This is inefficient, as doing things this order causes
584 a prototype check in newATTRSUB. But we have to do
585 it this order as we need an op number before calling
587 (void)core_prototype((SV *)cv, name, code, &opnum);
589 (void)hv_store(stash,name,len,(SV *)gv,0);
595 /* newATTRSUB will free the CV and return NULL if we're still
596 compiling after a syntax error */
597 if ((cv = newATTRSUB_x(
598 oldsavestack_ix, (OP *)gv,
603 : newSVpvn(name,len),
608 assert(GvCV(gv) == orig_cv);
609 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
610 && opnum != OP_UNDEF && opnum != OP_KEYS)
611 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
614 PL_parser = oldparser;
615 PL_curcop = oldcurcop;
616 PL_compcv = oldcompcv;
619 SV *opnumsv = newSViv(
620 (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
621 (OP_ENTEREVAL | (1<<16))
622 : opnum ? opnum : (((I32)name[2]) << 16));
623 cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
624 SvREFCNT_dec_NN(opnumsv);
631 =for apidoc gv_fetchmeth
633 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
635 =for apidoc gv_fetchmeth_sv
637 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
638 of an SV instead of a string/length pair.
644 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
648 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
649 if (LIKELY(SvPOK_nog(namesv))) /* common case */
650 return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
651 flags | SvUTF8(namesv));
652 namepv = SvPV(namesv, namelen);
653 if (SvUTF8(namesv)) flags |= SVf_UTF8;
654 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
658 =for apidoc gv_fetchmeth_pv
660 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
661 instead of a string/length pair.
667 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
669 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
670 return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
674 =for apidoc gv_fetchmeth_pvn
676 Returns the glob with the given C<name> and a defined subroutine or
677 C<NULL>. The glob lives in the given C<stash>, or in the stashes
678 accessible via C<@ISA> and C<UNIVERSAL::>.
680 The argument C<level> should be either 0 or -1. If C<level==0>, as a
681 side-effect creates a glob with the given C<name> in the given C<stash>
682 which in the case of success contains an alias for the subroutine, and sets
683 up caching info for this glob.
685 The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
687 C<GV_SUPER> indicates that we want to look up the method in the superclasses
691 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
692 visible to Perl code. So when calling C<call_sv>, you should not use
693 the GV directly; instead, you should use the method's CV, which can be
694 obtained from the GV with the C<GvCV> macro.
696 =for apidoc Amnh||GV_SUPER
701 /* NOTE: No support for tied ISA */
703 PERL_STATIC_INLINE GV*
704 S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
711 HV* cstash, *cachestash;
712 GV* candidate = NULL;
716 I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
719 U32 is_utf8 = flags & SVf_UTF8;
721 /* UNIVERSAL methods should be callable without a stash */
723 create = 0; /* probably appropriate */
724 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
730 hvname = HvNAME_get(stash);
732 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
735 assert(name || meth);
737 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
738 flags & GV_SUPER ? "SUPER " : "",
739 name ? name : SvPV_nolen(meth), hvname) );
741 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
743 if (flags & GV_SUPER) {
744 if (!HvAUX(stash)->xhv_mro_meta->super)
745 HvAUX(stash)->xhv_mro_meta->super = newHV();
746 cachestash = HvAUX(stash)->xhv_mro_meta->super;
748 else cachestash = stash;
750 /* check locally for a real method or a cache entry */
752 cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0
754 if (he) gvp = (GV**)&HeVAL(he);
761 if (SvTYPE(topgv) != SVt_PVGV)
764 name = SvPV_nomg(meth, len);
765 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
767 if ((cand_cv = GvCV(topgv))) {
768 /* If genuine method or valid cache entry, use it */
769 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
773 /* stale cache entry, junk it and move on */
774 SvREFCNT_dec_NN(cand_cv);
775 GvCV_set(topgv, NULL);
780 else if (GvCVGEN(topgv) == topgen_cmp) {
781 /* cache indicates no such method definitively */
784 else if (stash == cachestash
785 && len > 1 /* shortest is uc */
786 && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
787 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
791 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
792 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
793 items = AvFILLp(linear_av); /* no +1, to skip over self */
795 linear_sv = *linear_svp++;
797 cstash = gv_stashsv(linear_sv, 0);
800 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
801 "Can't locate package %" SVf " for @%" HEKf "::ISA",
803 HEKfARG(HvNAME_HEK(stash)));
809 gvp = (GV**)hv_common(
810 cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
813 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
814 const char *hvname = HvNAME(cstash); assert(hvname);
815 if (strBEGINs(hvname, "CORE")
817 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
823 else candidate = *gvp;
826 if (SvTYPE(candidate) != SVt_PVGV)
827 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
828 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
830 * Found real method, cache method in topgv if:
831 * 1. topgv has no synonyms (else inheritance crosses wires)
832 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
834 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
835 CV *old_cv = GvCV(topgv);
836 SvREFCNT_dec(old_cv);
837 SvREFCNT_inc_simple_void_NN(cand_cv);
838 GvCV_set(topgv, cand_cv);
839 GvCVGEN(topgv) = topgen_cmp;
845 /* Check UNIVERSAL without caching */
846 if(level == 0 || level == -1) {
847 candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
850 cand_cv = GvCV(candidate);
851 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
852 CV *old_cv = GvCV(topgv);
853 SvREFCNT_dec(old_cv);
854 SvREFCNT_inc_simple_void_NN(cand_cv);
855 GvCV_set(topgv, cand_cv);
856 GvCVGEN(topgv) = topgen_cmp;
862 if (topgv && GvREFCNT(topgv) == 1) {
863 /* cache the fact that the method is not defined */
864 GvCVGEN(topgv) = topgen_cmp;
871 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
873 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
874 return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
878 =for apidoc gv_fetchmeth_autoload
880 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
883 =for apidoc gv_fetchmeth_sv_autoload
885 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
886 of an SV instead of a string/length pair.
892 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
896 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
897 namepv = SvPV(namesv, namelen);
900 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
904 =for apidoc gv_fetchmeth_pv_autoload
906 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
907 instead of a string/length pair.
913 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
915 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
916 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
920 =for apidoc gv_fetchmeth_pvn_autoload
922 Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
923 Returns a glob for the subroutine.
925 For an autoloaded subroutine without a GV, will create a GV even
926 if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
927 of the result may be zero.
929 Currently, the only significant value for C<flags> is C<SVf_UTF8>.
935 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
937 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
939 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
946 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
947 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
949 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
952 if (!(CvROOT(cv) || CvXSUB(cv)))
954 /* Have an autoload */
955 if (level < 0) /* Cannot do without a stub */
956 gv_fetchmeth_pvn(stash, name, len, 0, flags);
957 gvp = (GV**)hv_fetch(stash, name,
958 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
967 =for apidoc gv_fetchmethod_autoload
969 Returns the glob which contains the subroutine to call to invoke the method
970 on the C<stash>. In fact in the presence of autoloading this may be the
971 glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
974 The third parameter of C<gv_fetchmethod_autoload> determines whether
975 AUTOLOAD lookup is performed if the given method is not present: non-zero
976 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
977 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
978 with a non-zero C<autoload> parameter.
980 These functions grant C<"SUPER"> token
981 as a prefix of the method name. Note
982 that if you want to keep the returned glob for a long time, you need to
983 check for it being "AUTOLOAD", since at the later time the call may load a
984 different subroutine due to C<$AUTOLOAD> changing its value. Use the glob
985 created as a side effect to do this.
987 These functions have the same side-effects as C<gv_fetchmeth> with
988 C<level==0>. The warning against passing the GV returned by
989 C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
995 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
997 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
999 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
1003 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
1007 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
1008 namepv = SvPV(namesv, namelen);
1011 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
1015 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
1017 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
1018 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
1022 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
1024 const char * const origname = name;
1025 const char * const name_end = name + len;
1026 const char *last_separator = NULL;
1029 SV *const error_report = MUTABLE_SV(stash);
1030 const U32 autoload = flags & GV_AUTOLOAD;
1031 const U32 do_croak = flags & GV_CROAK;
1032 const U32 is_utf8 = flags & SVf_UTF8;
1034 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
1036 if (SvTYPE(stash) < SVt_PVHV)
1039 /* The only way stash can become NULL later on is if last_separator is set,
1040 which in turn means that there is no need for a SVt_PVHV case
1041 the error reporting code. */
1045 /* check if the method name is fully qualified or
1046 * not, and separate the package name from the actual
1049 * leaves last_separator pointing to the beginning of the
1050 * last package separator (either ' or ::) or 0
1051 * if none was found.
1053 * leaves name pointing at the beginning of the
1056 const char *name_cursor = name;
1057 const char * const name_em1 = name_end - 1; /* name_end minus 1 */
1058 for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
1059 if (*name_cursor == '\'') {
1060 last_separator = name_cursor;
1061 name = name_cursor + 1;
1063 else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
1064 last_separator = name_cursor++;
1065 name = name_cursor + 1;
1070 /* did we find a separator? */
1071 if (last_separator) {
1072 STRLEN sep_len= last_separator - origname;
1073 if ( memEQs(origname, sep_len, "SUPER")) {
1074 /* ->SUPER::method should really be looked up in original stash */
1075 stash = CopSTASH(PL_curcop);
1077 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1078 origname, HvENAME_get(stash), name) );
1080 else if ( sep_len >= 7 &&
1081 strBEGINs(last_separator - 7, "::SUPER")) {
1082 /* don't autovifify if ->NoSuchStash::SUPER::method */
1083 stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
1084 if (stash) flags |= GV_SUPER;
1087 /* don't autovifify if ->NoSuchStash::method */
1088 stash = gv_stashpvn(origname, sep_len, is_utf8);
1093 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1095 /* This is the special case that exempts Foo->import and
1096 Foo->unimport from being an error even if there's no
1097 import/unimport subroutine */
1098 if (strEQ(name,"import") || strEQ(name,"unimport")) {
1099 gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1101 } else if (autoload)
1102 gv = gv_autoload_pvn(
1103 ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
1105 if (!gv && do_croak) {
1106 /* Right now this is exclusively for the benefit of S_method_common
1109 /* If we can't find an IO::File method, it might be a call on
1110 * a filehandle. If IO:File has not been loaded, try to
1111 * require it first instead of croaking */
1112 const char *stash_name = HvNAME_get(stash);
1113 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1114 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1115 STR_WITH_LEN("IO/File.pm"), 0,
1116 HV_FETCH_ISEXISTS, NULL, 0)
1118 require_pv("IO/File.pm");
1119 gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags);
1124 "Can't locate object method \"%" UTF8f
1125 "\" via package \"%" HEKf "\"",
1126 UTF8fARG(is_utf8, name_end - name, name),
1127 HEKfARG(HvNAME_HEK(stash)));
1132 if (last_separator) {
1133 packnamesv = newSVpvn_flags(origname, last_separator - origname,
1134 SVs_TEMP | is_utf8);
1136 packnamesv = error_report;
1140 "Can't locate object method \"%" UTF8f
1141 "\" via package \"%" SVf "\""
1142 " (perhaps you forgot to load \"%" SVf "\"?)",
1143 UTF8fARG(is_utf8, name_end - name, name),
1144 SVfARG(packnamesv), SVfARG(packnamesv));
1148 else if (autoload) {
1149 CV* const cv = GvCV(gv);
1150 if (!CvROOT(cv) && !CvXSUB(cv)) {
1154 if (CvANON(cv) || CvLEXICAL(cv))
1158 if (GvCV(stubgv) != cv) /* orphaned import */
1161 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1162 GvNAME(stubgv), GvNAMELEN(stubgv),
1163 GV_AUTOLOAD_ISMETHOD
1164 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1174 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1178 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1179 namepv = SvPV(namesv, namelen);
1182 return gv_autoload_pvn(stash, namepv, namelen, flags);
1186 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1188 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1189 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1193 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1200 SV *packname = NULL;
1201 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1203 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1205 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1208 if (SvTYPE(stash) < SVt_PVHV) {
1209 STRLEN packname_len = 0;
1210 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1211 packname = newSVpvn_flags(packname_ptr, packname_len,
1212 SVs_TEMP | SvUTF8(stash));
1216 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1217 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1219 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
1220 is_utf8 | (flags & GV_SUPER))))
1224 if (!(CvROOT(cv) || CvXSUB(cv)))
1228 * Inheriting AUTOLOAD for non-methods no longer works
1231 !(flags & GV_AUTOLOAD_ISMETHOD)
1232 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1234 Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
1235 "::%" UTF8f "() is no longer allowed",
1237 UTF8fARG(is_utf8, len, name));
1240 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1241 * and split that value on the last '::', pass along the same data
1242 * via the SvPVX field in the CV, and the stash in CvSTASH.
1244 * Due to an unfortunate accident of history, the SvPVX field
1245 * serves two purposes. It is also used for the subroutine's pro-
1246 * type. Since SvPVX has been documented as returning the sub name
1247 * for a long time, but not as returning the prototype, we have
1248 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1251 * We put the prototype in the same allocated buffer, but after
1252 * the sub name. The SvPOK flag indicates the presence of a proto-
1253 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1254 * If both flags are on, then SvLEN is used to indicate the end of
1255 * the prototype (artificially lower than what is actually allo-
1256 * cated), at the risk of having to reallocate a few bytes unneces-
1257 * sarily--but that should happen very rarely, if ever.
1259 * We use SvUTF8 for both prototypes and sub names, so if one is
1260 * UTF8, the other must be upgraded.
1262 CvSTASH_set(cv, stash);
1263 if (SvPOK(cv)) { /* Ouch! */
1264 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1266 const char *proto = CvPROTO(cv);
1269 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1270 ulen = SvCUR(tmpsv);
1271 SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
1273 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1275 SvTEMP_on(tmpsv); /* Allow theft */
1276 sv_setsv_nomg((SV *)cv, tmpsv);
1278 SvREFCNT_dec_NN(tmpsv);
1279 SvLEN_set(cv, SvCUR(cv) + 1);
1280 SvCUR_set(cv, ulen);
1283 sv_setpvn((SV *)cv, name, len);
1287 else SvUTF8_off(cv);
1293 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1294 * The subroutine's original name may not be "AUTOLOAD", so we don't
1295 * use that, but for lack of anything better we will use the sub's
1296 * original package to look up $AUTOLOAD.
1298 varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
1299 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1303 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1304 #ifdef PERL_DONT_CREATE_GVSV
1305 GvSV(vargv) = newSV(0);
1309 varsv = GvSVn(vargv);
1310 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1311 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1312 sv_setsv(varsv, packname);
1313 sv_catpvs(varsv, "::");
1314 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1315 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1318 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1326 /* require_tie_mod() internal routine for requiring a module
1327 * that implements the logic of automatic ties like %! and %-
1328 * It loads the module and then calls the _tie_it subroutine
1329 * with the passed gv as an argument.
1331 * The "gv" parameter should be the glob.
1332 * "varname" holds the 1-char name of the var, used for error messages.
1333 * "namesv" holds the module name. Its refcount will be decremented.
1334 * "flags": if flag & 1 then save the scalar before loading.
1335 * For the protection of $! to work (it is set by this routine)
1336 * the sv slot must already be magicalized.
1339 S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
1340 STRLEN len, const U32 flags)
1342 const SV * const target = varname == '[' ? GvSV(gv) : (SV *)GvHV(gv);
1344 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1346 /* If it is not tied */
1347 if (!target || !SvRMAGICAL(target)
1349 varname == '[' ? PERL_MAGIC_tiedscalar : PERL_MAGIC_tied))
1355 PUSHSTACKi(PERLSI_MAGIC);
1358 #define GET_HV_FETCH_TIE_FUNC \
1359 ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
1361 && ( (isGV(*gvp) && GvCV(*gvp)) \
1362 || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
1365 /* Load the module if it is not loaded. */
1366 if (!(stash = gv_stashpvn(name, len, 0))
1367 || ! GET_HV_FETCH_TIE_FUNC)
1369 SV * const module = newSVpvn(name, len);
1370 const char type = varname == '[' ? '$' : '%';
1373 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1374 assert(sp == PL_stack_sp);
1375 stash = gv_stashpvn(name, len, 0);
1377 Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
1378 type, varname, name);
1379 else if (! GET_HV_FETCH_TIE_FUNC)
1380 Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
1381 type, varname, name);
1383 /* Now call the tie function. It should be in *gvp. */
1384 assert(gvp); assert(*gvp);
1388 call_sv((SV *)*gvp, G_VOID|G_DISCARD);
1394 /* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
1395 * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
1396 * a true string WITHOUT a len.
1398 #define require_tie_mod_s(gv, varname, name, flags) \
1399 S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
1402 =for apidoc gv_stashpv
1404 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1405 determine the length of C<name>, then calls C<gv_stashpvn()>.
1411 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1413 PERL_ARGS_ASSERT_GV_STASHPV;
1414 return gv_stashpvn(name, strlen(name), create);
1418 =for apidoc gv_stashpvn
1420 Returns a pointer to the stash for a specified package. The C<namelen>
1421 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1422 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1423 created if it does not already exist. If the package does not exist and
1424 C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
1427 Flags may be one of:
1436 The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
1438 Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
1439 recommended for performance reasons.
1441 =for apidoc Amnh||GV_ADD
1447 gv_stashpvn_internal
1449 Perform the internal bits of gv_stashsvpvn_cached. You could think of this
1450 as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
1454 PERL_STATIC_INLINE HV*
1455 S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
1461 U32 tmplen = namelen + 2;
1463 PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
1465 if (tmplen <= sizeof smallbuf)
1468 Newx(tmpbuf, tmplen, char);
1469 Copy(name, tmpbuf, namelen, char);
1470 tmpbuf[namelen] = ':';
1471 tmpbuf[namelen+1] = ':';
1472 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1473 if (tmpbuf != smallbuf)
1475 if (!tmpgv || !isGV_with_GP(tmpgv))
1477 stash = GvHV(tmpgv);
1478 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1480 if (!HvNAME_get(stash)) {
1481 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1483 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1484 /* If the containing stash has multiple effective
1485 names, see that this one gets them, too. */
1486 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1487 mro_package_moved(stash, NULL, tmpgv, 1);
1493 gv_stashsvpvn_cached
1495 Returns a pointer to the stash for a specified package, possibly
1496 cached. Implements both C<gv_stashpvn> and C<gv_stashsv>.
1498 Requires one of either namesv or namepv to be non-null.
1500 See C<L</gv_stashpvn>> for details on "flags".
1502 Note the sv interface is strongly preferred for performance reasons.
1506 #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
1507 assert(namesv || name)
1509 PERL_STATIC_INLINE HV*
1510 S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
1515 PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
1517 he = (HE *)hv_common(
1518 PL_stashcache, namesv, name, namelen,
1519 (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
1526 hv = INT2PTR(HV*, SvIVX(sv));
1527 assert(SvTYPE(hv) == SVt_PVHV);
1530 else if (flags & GV_CACHE_ONLY) return NULL;
1533 if (SvOK(namesv)) { /* prevent double uninit warning */
1535 name = SvPV_const(namesv, len);
1537 flags |= SvUTF8(namesv);
1539 name = ""; namelen = 0;
1542 stash = gv_stashpvn_internal(name, namelen, flags);
1544 if (stash && namelen) {
1545 SV* const ref = newSViv(PTR2IV(stash));
1546 (void)hv_store(PL_stashcache, name,
1547 (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
1554 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1556 PERL_ARGS_ASSERT_GV_STASHPVN;
1557 return gv_stashsvpvn_cached(NULL, name, namelen, flags);
1561 =for apidoc gv_stashsv
1563 Returns a pointer to the stash for a specified package. See
1566 Note this interface is strongly preferred over C<gv_stashpvn> for performance
1573 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1575 PERL_ARGS_ASSERT_GV_STASHSV;
1576 return gv_stashsvpvn_cached(sv, NULL, 0, flags);
1581 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1582 PERL_ARGS_ASSERT_GV_FETCHPV;
1583 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1587 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1589 const char * const nambeg =
1590 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1591 PERL_ARGS_ASSERT_GV_FETCHSV;
1592 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1595 PERL_STATIC_INLINE void
1596 S_gv_magicalize_isa(pTHX_ GV *gv)
1600 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1604 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1608 /* This function grabs name and tries to split a stash and glob
1609 * from its contents. TODO better description, comments
1611 * If the function returns TRUE and 'name == name_end', then
1612 * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
1614 PERL_STATIC_INLINE bool
1615 S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
1616 STRLEN *len, const char *nambeg, STRLEN full_len,
1617 const U32 is_utf8, const I32 add)
1619 char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
1620 const char *name_cursor;
1621 const char *const name_end = nambeg + full_len;
1622 const char *const name_em1 = name_end - 1;
1623 char smallbuf[64]; /* small buffer to avoid a malloc when possible */
1625 PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
1629 && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8))
1631 /* accidental stringify on a GV? */
1635 for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
1636 if (name_cursor < name_em1 &&
1637 ((*name_cursor == ':' && name_cursor[1] == ':')
1638 || *name_cursor == '\''))
1641 *stash = PL_defstash;
1642 if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
1645 *len = name_cursor - *name;
1646 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1649 if (*name_cursor == ':') {
1653 else { /* using ' for package separator */
1654 /* use our pre-allocated buffer when possible to save a malloc */
1656 if ( *len+2 <= sizeof smallbuf)
1659 /* only malloc once if needed */
1660 if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
1661 Newx(tmpfullbuf, full_len+2, char);
1662 tmpbuf = tmpfullbuf;
1664 Copy(*name, tmpbuf, *len, char);
1665 tmpbuf[(*len)++] = ':';
1666 tmpbuf[(*len)++] = ':';
1669 gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
1670 *gv = gvp ? *gvp : NULL;
1671 if (!*gv || *gv == (const GV *)&PL_sv_undef) {
1674 /* here we know that *gv && *gv != &PL_sv_undef */
1675 if (SvTYPE(*gv) != SVt_PVGV)
1676 gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
1680 if (!(*stash = GvHV(*gv))) {
1681 *stash = GvHV(*gv) = newHV();
1682 if (!HvNAME_get(*stash)) {
1683 if (GvSTASH(*gv) == PL_defstash && *len == 6
1684 && strBEGINs(*name, "CORE"))
1685 hv_name_sets(*stash, "CORE", 0);
1688 *stash, nambeg, name_cursor-nambeg, is_utf8
1690 /* If the containing stash has multiple effective
1691 names, see that this one gets them, too. */
1692 if (HvAUX(GvSTASH(*gv))->xhv_name_count)
1693 mro_package_moved(*stash, NULL, *gv, 1);
1696 else if (!HvNAME_get(*stash))
1697 hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
1700 if (*name_cursor == ':')
1702 *name = name_cursor+1;
1703 if (*name == name_end) {
1705 *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1706 if (SvTYPE(*gv) != SVt_PVGV) {
1707 gv_init_pvn(*gv, PL_defstash, "main::", 6,
1710 MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
1717 *len = name_cursor - *name;
1719 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1722 Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
1727 /* Checks if an unqualified name is in the main stash */
1728 PERL_STATIC_INLINE bool
1729 S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
1731 PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
1733 /* If it's an alphanumeric variable */
1734 if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) {
1735 /* Some "normal" variables are always in main::,
1736 * like INC or STDOUT.
1744 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1745 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1746 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1750 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1755 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1756 && name[3] == 'I' && name[4] == 'N')
1760 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1761 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1762 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1766 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1767 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1773 /* *{""}, or a special variable like $@ */
1781 /* This function is called if parse_gv_stash_name() failed to
1782 * find a stash, or if GV_NOTQUAL or an empty name was passed
1783 * to gv_fetchpvn_flags.
1785 * It returns FALSE if the default stash can't be found nor created,
1786 * which might happen during global destruction.
1788 PERL_STATIC_INLINE bool
1789 S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
1790 const U32 is_utf8, const I32 add,
1791 const svtype sv_type)
1793 PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
1795 /* No stash in name, so see how we can default */
1797 if ( gv_is_in_main(name, len, is_utf8) ) {
1798 *stash = PL_defstash;
1801 if (IN_PERL_COMPILETIME) {
1802 *stash = PL_curstash;
1803 if (add && (PL_hints & HINT_STRICT_VARS) &&
1804 sv_type != SVt_PVCV &&
1805 sv_type != SVt_PVGV &&
1806 sv_type != SVt_PVFM &&
1807 sv_type != SVt_PVIO &&
1808 !(len == 1 && sv_type == SVt_PV &&
1809 (*name == 'a' || *name == 'b')) )
1811 GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
1812 if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
1813 SvTYPE(*gvp) != SVt_PVGV)
1817 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1818 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1819 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1821 /* diag_listed_as: Variable "%s" is not imported%s */
1823 aTHX_ packWARN(WARN_MISC),
1824 "Variable \"%c%" UTF8f "\" is not imported",
1825 sv_type == SVt_PVAV ? '@' :
1826 sv_type == SVt_PVHV ? '%' : '$',
1827 UTF8fARG(is_utf8, len, name));
1830 aTHX_ packWARN(WARN_MISC),
1831 "\t(Did you mean &%" UTF8f " instead?)\n",
1832 UTF8fARG(is_utf8, len, name)
1839 /* Use the current op's stash */
1840 *stash = CopSTASH(PL_curcop);
1845 if (add && !PL_in_clean_all) {
1847 qerror(Perl_mess(aTHX_
1848 "Global symbol \"%s%" UTF8f
1849 "\" requires explicit package name (did you forget to "
1850 "declare \"my %s%" UTF8f "\"?)",
1851 (sv_type == SVt_PV ? "$"
1852 : sv_type == SVt_PVAV ? "@"
1853 : sv_type == SVt_PVHV ? "%"
1854 : ""), UTF8fARG(is_utf8, len, name),
1855 (sv_type == SVt_PV ? "$"
1856 : sv_type == SVt_PVAV ? "@"
1857 : sv_type == SVt_PVHV ? "%"
1858 : ""), UTF8fARG(is_utf8, len, name)));
1859 /* To maintain the output of errors after the strict exception
1860 * above, and to keep compat with older releases, rather than
1861 * placing the variables in the pad, we place
1862 * them in the <none>:: stash.
1864 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1866 /* symbol table under destruction */
1875 if (!SvREFCNT(*stash)) /* symbol table under destruction */
1881 /* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
1882 redefine SvREADONLY_on for that purpose. We don’t use it later on in
1884 #undef SvREADONLY_on
1885 #define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
1887 /* gv_magicalize() is called by gv_fetchpvn_flags when creating
1889 * Note that it does not insert the GV into the stash prior to
1890 * magicalization, which some variables require need in order
1891 * to work (like %+, %-, %!), so callers must take care of
1894 * It returns true if the gv did turn out to be magical one; i.e.,
1895 * if gv_magicalize actually did something.
1897 PERL_STATIC_INLINE bool
1898 S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
1899 const svtype sv_type)
1903 PERL_ARGS_ASSERT_GV_MAGICALIZE;
1905 if (stash != PL_defstash) { /* not the main stash */
1906 /* We only have to check for a few names here: a, b, EXPORT, ISA
1907 and VERSION. All the others apply only to the main stash or to
1908 CORE (which is checked right after this). */
1913 len >= 6 && name[1] == 'X' &&
1914 (memEQs(name, len, "EXPORT")
1915 ||memEQs(name, len, "EXPORT_OK")
1916 ||memEQs(name, len, "EXPORT_FAIL")
1917 ||memEQs(name, len, "EXPORT_TAGS"))
1922 if (memEQs(name, len, "ISA"))
1923 gv_magicalize_isa(gv);
1926 if (memEQs(name, len, "VERSION"))
1930 if (stash == PL_debstash && memEQs(name, len, "args")) {
1931 GvMULTI_on(gv_AVadd(gv));
1936 if (len == 1 && sv_type == SVt_PV)
1945 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1946 /* Avoid null warning: */
1947 const char * const stashname = HvNAME(stash); assert(stashname);
1948 if (strBEGINs(stashname, "CORE"))
1949 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1956 /* Nothing else to do.
1957 The compiler will probably turn the switch statement into a
1958 branch table. Make sure we avoid even that small overhead for
1959 the common case of lower case variable names. (On EBCDIC
1960 platforms, we can't just do:
1961 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1962 because cases like '\027' in the switch statement below are
1963 C1 (non-ASCII) controls on those platforms, so the remapping
1964 would make them larger than 'V')
1971 if (memEQs(name, len, "ARGV")) {
1972 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1974 else if (memEQs(name, len, "ARGVOUT")) {
1980 len >= 6 && name[1] == 'X' &&
1981 (memEQs(name, len, "EXPORT")
1982 ||memEQs(name, len, "EXPORT_OK")
1983 ||memEQs(name, len, "EXPORT_FAIL")
1984 ||memEQs(name, len, "EXPORT_TAGS"))
1989 if (memEQs(name, len, "ISA")) {
1990 gv_magicalize_isa(gv);
1994 if (memEQs(name, len, "SIG")) {
1997 if (!PL_psig_name) {
1998 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1999 Newxz(PL_psig_pend, SIG_SIZE, int);
2000 PL_psig_ptr = PL_psig_name + SIG_SIZE;
2002 /* I think that the only way to get here is to re-use an
2003 embedded perl interpreter, where the previous
2004 use didn't clean up fully because
2005 PL_perl_destruct_level was 0. I'm not sure that we
2006 "support" that, in that I suspect in that scenario
2007 there are sufficient other garbage values left in the
2008 interpreter structure that something else will crash
2009 before we get here. I suspect that this is one of
2010 those "doctor, it hurts when I do this" bugs. */
2011 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
2012 Zero(PL_psig_pend, SIG_SIZE, int);
2016 hv_magic(hv, NULL, PERL_MAGIC_sig);
2017 for (i = 1; i < SIG_SIZE; i++) {
2018 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
2020 sv_setsv(*init, &PL_sv_undef);
2025 if (memEQs(name, len, "VERSION"))
2028 case '\003': /* $^CHILD_ERROR_NATIVE */
2029 if (memEQs(name, len, "\003HILD_ERROR_NATIVE"))
2031 /* @{^CAPTURE} %{^CAPTURE} */
2032 if (memEQs(name, len, "\003APTURE")) {
2033 AV* const av = GvAVn(gv);
2034 const Size_t n = *name;
2036 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2039 require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
2041 } else /* %{^CAPTURE_ALL} */
2042 if (memEQs(name, len, "\003APTURE_ALL")) {
2043 require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
2046 case '\005': /* $^ENCODING */
2047 if (memEQs(name, len, "\005NCODING"))
2050 case '\007': /* $^GLOBAL_PHASE */
2051 if (memEQs(name, len, "\007LOBAL_PHASE"))
2054 case '\014': /* $^LAST_FH */
2055 if (memEQs(name, len, "\014AST_FH"))
2058 case '\015': /* $^MATCH */
2059 if (memEQs(name, len, "\015ATCH")) {
2060 paren = RX_BUFF_IDX_CARET_FULLMATCH;
2064 case '\017': /* $^OPEN */
2065 if (memEQs(name, len, "\017PEN"))
2068 case '\020': /* $^PREMATCH $^POSTMATCH */
2069 if (memEQs(name, len, "\020REMATCH")) {
2070 paren = RX_BUFF_IDX_CARET_PREMATCH;
2073 if (memEQs(name, len, "\020OSTMATCH")) {
2074 paren = RX_BUFF_IDX_CARET_POSTMATCH;
2079 if (memEQs(name, len, "\023AFE_LOCALES"))
2082 case '\024': /* ${^TAINT} */
2083 if (memEQs(name, len, "\024AINT"))
2086 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
2087 if (memEQs(name, len, "\025NICODE"))
2089 if (memEQs(name, len, "\025TF8LOCALE"))
2091 if (memEQs(name, len, "\025TF8CACHE"))
2094 case '\027': /* $^WARNING_BITS */
2095 if (memEQs(name, len, "\027ARNING_BITS"))
2098 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT"))
2112 /* Ensures that we have an all-digit variable, ${"1foo"} fails
2115 if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
2117 /* XXX why are we using a SSize_t? */
2118 paren = (SSize_t)(I32)uv;
2124 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
2125 be case '\0' in this switch statement (ie a default case) */
2128 paren = RX_BUFF_IDX_FULLMATCH;
2131 paren = RX_BUFF_IDX_PREMATCH;
2134 paren = RX_BUFF_IDX_POSTMATCH;
2136 #ifdef PERL_SAWAMPERSAND
2138 sv_type == SVt_PVAV ||
2139 sv_type == SVt_PVHV ||
2140 sv_type == SVt_PVCV ||
2141 sv_type == SVt_PVFM ||
2143 )) { PL_sawampersand |=
2147 ? SAWAMPERSAND_MIDDLE
2148 : SAWAMPERSAND_RIGHT;
2161 paren = *name - '0';
2164 /* Flag the capture variables with a NULL mg_ptr
2165 Use mg_len for the array index to lookup. */
2166 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren);
2170 sv_setpv(GvSVn(gv),PL_chopset);
2174 #ifdef COMPLEX_STATUS
2175 SvUPGRADE(GvSVn(gv), SVt_PVLV);
2181 /* If %! has been used, automatically load Errno.pm. */
2183 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2185 /* magicalization must be done before require_tie_mod_s is called */
2186 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2187 require_tie_mod_s(gv, '!', "Errno", 1);
2190 case '-': /* $-, %-, @- */
2191 case '+': /* $+, %+, @+ */
2192 GvMULTI_on(gv); /* no used once warnings here */
2194 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2196 SvREADONLY_on(GvSVn(gv));
2199 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
2200 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
2203 AV* const av = GvAVn(gv);
2204 const Size_t n = *name;
2206 sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
2212 if (sv_type == SVt_PV)
2213 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2214 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2216 case '\010': /* $^H */
2218 HV *const hv = GvHVn(gv);
2219 hv_magic(hv, NULL, PERL_MAGIC_hints);
2222 case '\023': /* $^S */
2224 SvREADONLY_on(GvSVn(gv));
2241 case '\001': /* $^A */
2242 case '\003': /* $^C */
2243 case '\004': /* $^D */
2244 case '\005': /* $^E */
2245 case '\006': /* $^F */
2246 case '\011': /* $^I, NOT \t in EBCDIC */
2247 case '\016': /* $^N */
2248 case '\017': /* $^O */
2249 case '\020': /* $^P */
2250 case '\024': /* $^T */
2251 case '\027': /* $^W */
2253 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2256 case '\014': /* $^L */
2257 sv_setpvs(GvSVn(gv),"\f");
2260 sv_setpvs(GvSVn(gv),"\034");
2264 SV * const sv = GvSV(gv);
2265 if (!sv_derived_from(PL_patchlevel, "version"))
2266 upg_version(PL_patchlevel, TRUE);
2267 GvSV(gv) = vnumify(PL_patchlevel);
2268 SvREADONLY_on(GvSV(gv));
2272 case '\026': /* $^V */
2274 SV * const sv = GvSV(gv);
2275 GvSV(gv) = new_version(PL_patchlevel);
2276 SvREADONLY_on(GvSV(gv));
2282 if (sv_type == SVt_PV)
2288 /* Return true if we actually did something. */
2289 return GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv)
2291 SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))
2296 /* If we do ever start using this later on in the file, we need to make
2297 sure we don’t accidentally use the wrong definition. */
2298 #undef SvREADONLY_on
2300 /* This function is called when the stash already holds the GV of the magic
2301 * variable we're looking for, but we need to check that it has the correct
2302 * kind of magic. For example, if someone first uses $! and then %!, the
2303 * latter would end up here, and we add the Errno tie to the HASH slot of
2306 PERL_STATIC_INLINE void
2307 S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
2309 PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
2311 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
2313 require_tie_mod_s(gv, '!', "Errno", 1);
2314 else if (*name == '-' || *name == '+')
2315 require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
2316 } else if (sv_type == SVt_PV) {
2317 if (*name == '*' || *name == '#') {
2318 /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
2319 Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
2322 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
2324 #ifdef PERL_SAWAMPERSAND
2326 PL_sawampersand |= SAWAMPERSAND_LEFT;
2330 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
2334 PL_sawampersand |= SAWAMPERSAND_RIGHT;
2343 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
2344 const svtype sv_type)
2346 const char *name = nambeg;
2351 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
2352 const I32 no_expand = flags & GV_NOEXPAND;
2353 const I32 add = flags & ~GV_NOADD_MASK;
2354 const U32 is_utf8 = flags & SVf_UTF8;
2355 bool addmg = cBOOL(flags & GV_ADDMG);
2356 const char *const name_end = nambeg + full_len;
2359 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
2361 /* If we have GV_NOTQUAL, the caller promised that
2362 * there is no stash, so we can skip the check.
2363 * Similarly if full_len is 0, since then we're
2364 * dealing with something like *{""} or ""->foo()
2366 if ((flags & GV_NOTQUAL) || !full_len) {
2369 else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
2370 if (name == name_end) return gv;
2376 if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
2380 /* By this point we should have a stash and a name */
2381 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
2382 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
2383 if (addmg) gv = (GV *)newSV(0);
2386 else gv = *gvp, addmg = 0;
2387 /* From this point on, addmg means gv has not been inserted in the
2390 if (SvTYPE(gv) == SVt_PVGV) {
2391 /* The GV already exists, so return it, but check if we need to do
2392 * anything else with it before that.
2395 /* This is the heuristic that handles if a variable triggers the
2396 * 'used only once' warning. If there's already a GV in the stash
2397 * with this name, then we assume that the variable has been used
2398 * before and turn its MULTI flag on.
2399 * It's a heuristic because it can easily be "tricked", like with
2400 * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
2401 * not warning about $main::foo being used just once
2404 gv_init_svtype(gv, sv_type);
2405 /* You reach this path once the typeglob has already been created,
2406 either by the same or a different sigil. If this path didn't
2407 exist, then (say) referencing $! first, and %! second would
2408 mean that %! was not handled correctly. */
2409 if (len == 1 && stash == PL_defstash) {
2410 maybe_multimagic_gv(gv, name, sv_type);
2412 else if (sv_type == SVt_PVAV
2413 && memEQs(name, len, "ISA")
2414 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
2415 gv_magicalize_isa(gv);
2418 } else if (no_init) {
2422 /* If GV_NOEXPAND is true and what we got off the stash is a ref,
2423 * don't expand it to a glob. This is an optimization so that things
2424 * copying constants over, like Exporter, don't have to be rewritten
2425 * to take into account that you can store more than just globs in
2428 else if (no_expand && SvROK(gv)) {
2433 /* Adding a new symbol.
2434 Unless of course there was already something non-GV here, in which case
2435 we want to behave as if there was always a GV here, containing some sort
2437 Otherwise we run the risk of creating things like GvIO, which can cause
2438 subtle bugs. eg the one that tripped up SQL::Translator */
2440 faking_it = SvOK(gv);
2442 if (add & GV_ADDWARN)
2443 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2444 "Had to create %" UTF8f " unexpectedly",
2445 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
2446 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
2449 && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)
2450 && !ckWARN(WARN_ONCE) )
2455 /* set up magic where warranted */
2456 if ( gv_magicalize(gv, stash, name, len, sv_type) ) {
2459 /* gv_magicalize magicalised this gv, so we want it
2460 * stored in the symtab.
2461 * Effectively the caller is asking, ‘Does this gv exist?’
2462 * And we respond, ‘Er, *now* it does!’
2464 (void)hv_store(stash,name,len,(SV *)gv,0);
2468 /* The temporary GV created above */
2469 SvREFCNT_dec_NN(gv);
2473 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2478 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2481 const HV * const hv = GvSTASH(gv);
2483 PERL_ARGS_ASSERT_GV_FULLNAME4;
2485 sv_setpv(sv, prefix ? prefix : "");
2487 if (hv && (name = HvNAME(hv))) {
2488 const STRLEN len = HvNAMELEN(hv);
2489 if (keepmain || ! memBEGINs(name, len, "main")) {
2490 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2494 else sv_catpvs(sv,"__ANON__::");
2495 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2499 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2501 const GV * const egv = GvEGVx(gv);
2503 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2505 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2509 /* recursively scan a stash and any nested stashes looking for entries
2510 * that need the "only used once" warning raised
2514 Perl_gv_check(pTHX_ HV *stash)
2518 PERL_ARGS_ASSERT_GV_CHECK;
2523 assert(HvARRAY(stash));
2525 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2527 /* mark stash is being scanned, to avoid recursing */
2528 HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
2529 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2532 STRLEN keylen = HeKLEN(entry);
2533 const char * const key = HeKEY(entry);
2535 if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' &&
2536 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2538 if (hv != PL_defstash && hv != stash
2540 && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
2542 gv_check(hv); /* nested package */
2544 else if ( HeKLEN(entry) != 0
2545 && *HeKEY(entry) != '_'
2546 && isIDFIRST_lazy_if_safe(HeKEY(entry),
2547 HeKEY(entry) + HeKLEN(entry),
2551 gv = MUTABLE_GV(HeVAL(entry));
2552 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2555 CopLINE_set(PL_curcop, GvLINE(gv));
2557 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2559 CopFILEGV(PL_curcop)
2560 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2562 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2563 "Name \"%" HEKf "::%" HEKf
2564 "\" used only once: possible typo",
2565 HEKfARG(HvNAME_HEK(stash)),
2566 HEKfARG(GvNAME_HEK(gv)));
2569 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
2574 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2576 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2577 assert(!(flags & ~SVf_UTF8));
2579 return gv_fetchpv(Perl_form(aTHX_ "%" UTF8f "::_GEN_%ld",
2580 UTF8fARG(flags, strlen(pack), pack),
2585 /* hopefully this is only called on local symbol table entries */
2588 Perl_gp_ref(pTHX_ GP *gp)
2595 /* If the GP they asked for a reference to contains
2596 a method cache entry, clear it first, so that we
2597 don't infect them with our cached entry */
2598 SvREFCNT_dec_NN(gp->gp_cv);
2607 Perl_gp_free(pTHX_ GV *gv)
2612 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2614 if (gp->gp_refcnt == 0) {
2615 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2616 "Attempt to free unreferenced glob pointers"
2617 pTHX__FORMAT pTHX__VALUE);
2620 if (gp->gp_refcnt > 1) {
2622 if (gp->gp_egv == gv)
2630 /* Copy and null out all the glob slots, so destructors do not see
2632 HEK * const file_hek = gp->gp_file_hek;
2633 SV * const sv = gp->gp_sv;
2634 AV * const av = gp->gp_av;
2635 HV * const hv = gp->gp_hv;
2636 IO * const io = gp->gp_io;
2637 CV * const cv = gp->gp_cv;
2638 CV * const form = gp->gp_form;
2640 gp->gp_file_hek = NULL;
2649 unshare_hek(file_hek);
2653 /* FIXME - another reference loop GV -> symtab -> GV ?
2654 Somehow gp->gp_hv can end up pointing at freed garbage. */
2655 if (hv && SvTYPE(hv) == SVt_PVHV) {
2656 const HEK *hvname_hek = HvNAME_HEK(hv);
2657 if (PL_stashcache && hvname_hek) {
2658 DEBUG_o(Perl_deb(aTHX_
2659 "gp_free clearing PL_stashcache for '%" HEKf "'\n",
2660 HEKfARG(hvname_hek)));
2661 (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
2665 if (io && SvREFCNT(io) == 1 && IoIFP(io)
2666 && (IoTYPE(io) == IoTYPE_WRONLY ||
2667 IoTYPE(io) == IoTYPE_RDWR ||
2668 IoTYPE(io) == IoTYPE_APPEND)
2669 && ckWARN_d(WARN_IO)
2670 && IoIFP(io) != PerlIO_stdin()
2671 && IoIFP(io) != PerlIO_stdout()
2672 && IoIFP(io) != PerlIO_stderr()
2673 && !(IoFLAGS(io) & IOf_FAKE_DIRP))
2674 io_close(io, gv, FALSE, TRUE);
2679 /* Possibly reallocated by a destructor */
2682 if (!gp->gp_file_hek
2688 && !gp->gp_form) break;
2690 if (--attempts == 0) {
2692 "panic: gp_free failed to free glob pointer - "
2693 "something is repeatedly re-creating entries"
2698 /* Possibly incremented by a destructor doing glob assignment */
2699 if (gp->gp_refcnt > 1) goto borrowed;
2705 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2707 AMT * const amtp = (AMT*)mg->mg_ptr;
2708 PERL_UNUSED_ARG(sv);
2710 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2712 if (amtp && AMT_AMAGIC(amtp)) {
2714 for (i = 1; i < NofAMmeth; i++) {
2715 CV * const cv = amtp->table[i];
2717 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2718 amtp->table[i] = NULL;
2725 /* Updates and caches the CV's */
2727 * 1 on success and there is some overload
2728 * 0 if there is no overload
2729 * -1 if some error occurred and it couldn't croak
2733 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2735 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2737 const struct mro_meta* stash_meta = HvMROMETA(stash);
2740 PERL_ARGS_ASSERT_GV_AMUPDATE;
2742 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2744 const AMT * const amtp = (AMT*)mg->mg_ptr;
2745 if (amtp->was_ok_sub == newgen) {
2746 return AMT_AMAGIC(amtp) ? 1 : 0;
2748 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2751 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2754 amt.was_ok_sub = newgen;
2755 amt.fallback = AMGfallNO;
2761 bool deref_seen = 0;
2764 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2766 /* Try to find via inheritance. */
2767 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2768 SV * const sv = gv ? GvSV(gv) : NULL;
2773 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2776 #ifdef PERL_DONT_CREATE_GVSV
2778 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2781 else if (SvTRUE(sv))
2782 /* don't need to set overloading here because fallback => 1
2783 * is the default setting for classes without overloading */
2784 amt.fallback=AMGfallYES;
2785 else if (SvOK(sv)) {
2786 amt.fallback=AMGfallNEVER;
2793 assert(SvOOK(stash));
2794 /* initially assume the worst */
2795 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
2797 for (i = 1; i < NofAMmeth; i++) {
2798 const char * const cooky = PL_AMG_names[i];
2799 /* Human-readable form, for debugging: */
2800 const char * const cp = AMG_id2name(i);
2801 const STRLEN l = PL_AMG_namelens[i];
2803 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2804 cp, HvNAME_get(stash)) );
2805 /* don't fill the cache while looking up!
2806 Creation of inheritance stubs in intermediate packages may
2807 conflict with the logic of runtime method substitution.
2808 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2809 then we could have created stubs for "(+0" in A and C too.
2810 But if B overloads "bool", we may want to use it for
2811 numifying instead of C's "+0". */
2812 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2814 if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
2815 const HEK * const gvhek = CvGvNAME_HEK(cv);
2816 const HEK * const stashek =
2817 HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
2818 if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
2820 && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
2821 /* This is a hack to support autoloading..., while
2822 knowing *which* methods were declared as overloaded. */
2823 /* GvSV contains the name of the method. */
2825 SV *gvsv = GvSV(gv);
2827 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\
2828 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2829 (void*)GvSV(gv), cp, HvNAME(stash)) );
2830 if (!gvsv || !SvPOK(gvsv)
2831 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2833 /* Can be an import stub (created by "can"). */
2838 const SV * const name = (gvsv && SvPOK(gvsv))
2840 : newSVpvs_flags("???", SVs_TEMP);
2841 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2842 Perl_croak(aTHX_ "%s method \"%" SVf256
2843 "\" overloading \"%s\" "\
2844 "in package \"%" HEKf256 "\"",
2845 (GvCVGEN(gv) ? "Stub found while resolving"
2853 cv = GvCV(gv = ngv);
2855 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2856 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2857 GvNAME(CvGV(cv))) );
2859 } else if (gv) { /* Autoloaded... */
2860 cv = MUTABLE_CV(gv);
2863 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2879 /* none of @{} etc overloaded; we can do $obj->[N] quicker.
2880 * NB - aux var invalid here, HvARRAY() could have been
2881 * reallocated since it was assigned to */
2882 HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
2885 AMT_AMAGIC_on(&amt);
2886 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2887 (char*)&amt, sizeof(AMT));
2891 /* Here we have no table: */
2893 AMT_AMAGIC_off(&amt);
2894 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2895 (char*)&amt, sizeof(AMTS));
2901 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2906 struct mro_meta* stash_meta;
2908 if (!stash || !HvNAME_get(stash))
2911 stash_meta = HvMROMETA(stash);
2912 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2914 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2917 if (Gv_AMupdate(stash, 0) == -1)
2919 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2922 amtp = (AMT*)mg->mg_ptr;
2923 if ( amtp->was_ok_sub != newgen )
2925 if (AMT_AMAGIC(amtp)) {
2926 CV * const ret = amtp->table[id];
2927 if (ret && isGV(ret)) { /* Autoloading stab */
2928 /* Passing it through may have resulted in a warning
2929 "Inherited AUTOLOAD for a non-method deprecated", since
2930 our caller is going through a function call, not a method call.
2931 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2932 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2944 /* Implement tryAMAGICun_MG macro.
2945 Do get magic, then see if the stack arg is overloaded and if so call it.
2947 AMGf_numeric apply sv_2num to the stack arg.
2951 Perl_try_amagic_un(pTHX_ int method, int flags) {
2954 SV* const arg = TOPs;
2958 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2959 AMGf_noright | AMGf_unary
2960 | (flags & AMGf_numarg))))
2962 /* where the op is of the form:
2963 * $lex = $x op $y (where the assign is optimised away)
2964 * then assign the returned value to targ and return that;
2965 * otherwise return the value directly
2967 if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
2968 && (PL_op->op_private & OPpTARGET_MY))
2971 sv_setsv(TARG, tmpsv);
2981 if ((flags & AMGf_numeric) && SvROK(arg))
2987 /* Implement tryAMAGICbin_MG macro.
2988 Do get magic, then see if the two stack args are overloaded and if so
2991 AMGf_assign op may be called as mutator (eg +=)
2992 AMGf_numeric apply sv_2num to the stack arg.
2996 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2998 SV* const left = TOPm1s;
2999 SV* const right = TOPs;
3005 if (SvAMAGIC(left) || SvAMAGIC(right)) {
3007 /* STACKED implies mutator variant, e.g. $x += 1 */
3008 bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
3010 tmpsv = amagic_call(left, right, method,
3011 (mutator ? AMGf_assign: 0)
3012 | (flags & AMGf_numarg));
3015 /* where the op is one of the two forms:
3017 * $lex = $x op $y (where the assign is optimised away)
3018 * then assign the returned value to targ and return that;
3019 * otherwise return the value directly
3022 || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
3023 && (PL_op->op_private & OPpTARGET_MY)))
3026 TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
3027 sv_setsv(TARG, tmpsv);
3038 if(left==right && SvGMAGICAL(left)) {
3039 SV * const left = sv_newmortal();
3041 /* Print the uninitialized warning now, so it includes the vari-
3044 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
3045 sv_setsv_flags(left, &PL_sv_no, 0);
3047 else sv_setsv_flags(left, right, 0);
3050 if (flags & AMGf_numeric) {
3052 *(sp-1) = sv_2num(TOPm1s);
3054 *sp = sv_2num(right);
3060 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
3064 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
3068 /* return quickly if none of the deref ops are overloaded */
3069 stash = SvSTASH(SvRV(ref));
3070 assert(SvOOK(stash));
3071 if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
3074 while ((tmpsv = amagic_call(ref, &PL_sv_undef, method,
3075 AMGf_noright | AMGf_unary))) {
3077 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
3078 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
3079 /* Bail out if it returns us the same reference. */
3086 return tmpsv ? tmpsv : ref;
3090 Perl_amagic_is_enabled(pTHX_ int method)
3092 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
3094 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
3096 if ( !lex_mask || !SvOK(lex_mask) )
3097 /* overloading lexically disabled */
3099 else if ( lex_mask && SvPOK(lex_mask) ) {
3100 /* we have an entry in the hints hash, check if method has been
3101 * masked by overloading.pm */
3103 const int offset = method / 8;
3104 const int bit = method % 8;
3105 char *pv = SvPV(lex_mask, len);
3107 /* Bit set, so this overloading operator is disabled */
3108 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
3115 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
3120 CV **cvp=NULL, **ocvp=NULL;
3121 AMT *amtp=NULL, *oamtp=NULL;
3122 int off = 0, off1, lr = 0, notfound = 0;
3123 int postpr = 0, force_cpy = 0;
3124 int assign = AMGf_assign & flags;
3125 const int assignshift = assign ? 1 : 0;
3126 int use_default_op = 0;
3127 int force_scalar = 0;
3133 PERL_ARGS_ASSERT_AMAGIC_CALL;
3135 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
3136 if (!amagic_is_enabled(method)) return NULL;
3139 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
3140 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
3141 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3142 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3143 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
3145 && ((cv = cvp[off=method+assignshift])
3146 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
3152 cv = cvp[off=method])))) {
3153 lr = -1; /* Call method for left argument */
3155 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
3158 /* look for substituted methods */
3159 /* In all the covered cases we should be called with assign==0. */
3163 if ((cv = cvp[off=add_ass_amg])
3164 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
3165 right = &PL_sv_yes; lr = -1; assign = 1;
3170 if ((cv = cvp[off = subtr_ass_amg])
3171 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
3172 right = &PL_sv_yes; lr = -1; assign = 1;
3176 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
3179 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
3182 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
3185 (void)((cv = cvp[off=bool__amg])
3186 || (cv = cvp[off=numer_amg])
3187 || (cv = cvp[off=string_amg]));
3194 * SV* ref causes confusion with the interpreter variable of
3197 SV* const tmpRef=SvRV(left);
3198 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
3200 * Just to be extra cautious. Maybe in some
3201 * additional cases sv_setsv is safe, too.
3203 SV* const newref = newSVsv(tmpRef);
3204 SvOBJECT_on(newref);
3205 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
3206 delegate to the stash. */
3207 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
3213 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
3214 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
3215 SV* const nullsv=&PL_sv_zero;
3217 SV* const lessp = amagic_call(left,nullsv,
3218 lt_amg,AMGf_noright);
3219 logic = SvTRUE_NN(lessp);
3221 SV* const lessp = amagic_call(left,nullsv,
3222 ncmp_amg,AMGf_noright);
3223 logic = (SvNV(lessp) < 0);
3226 if (off==subtr_amg) {
3237 if ((cv = cvp[off=subtr_amg])) {
3244 case iter_amg: /* XXXX Eventually should do to_gv. */
3245 case ftest_amg: /* XXXX Eventually should do to_gv. */
3248 return NULL; /* Delegate operation to standard mechanisms. */
3256 return left; /* Delegate operation to standard mechanisms. */
3261 if (!cv) goto not_found;
3262 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
3263 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
3264 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
3265 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
3266 ? (amtp = (AMT*)mg->mg_ptr)->table
3268 && (cv = cvp[off=method])) { /* Method for right
3271 } else if (((cvp && amtp->fallback > AMGfallNEVER)
3272 || (ocvp && oamtp->fallback > AMGfallNEVER))
3273 && !(flags & AMGf_unary)) {
3274 /* We look for substitution for
3275 * comparison operations and
3277 if (method==concat_amg || method==concat_ass_amg
3278 || method==repeat_amg || method==repeat_ass_amg) {
3279 return NULL; /* Delegate operation to string conversion */
3301 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
3305 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
3315 not_found: /* No method found, either report or croak */
3323 return left; /* Delegate operation to standard mechanisms. */
3325 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
3326 notfound = 1; lr = -1;
3327 } else if (cvp && (cv=cvp[nomethod_amg])) {
3328 notfound = 1; lr = 1;
3329 } else if ((use_default_op =
3330 (!ocvp || oamtp->fallback >= AMGfallYES)
3331 && (!cvp || amtp->fallback >= AMGfallYES))
3333 /* Skip generating the "no method found" message. */
3337 if (off==-1) off=method;
3338 msg = sv_2mortal(Perl_newSVpvf(aTHX_
3339 "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf,
3340 AMG_id2name(method + assignshift),
3341 (flags & AMGf_unary ? " " : "\n\tleft "),
3343 "in overloaded package ":
3344 "has no overloaded magic",
3346 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
3349 ",\n\tright argument in overloaded package ":
3352 : ",\n\tright argument has no overloaded magic"),
3354 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
3355 SVfARG(&PL_sv_no)));
3356 if (use_default_op) {
3357 DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) );
3359 Perl_croak(aTHX_ "%" SVf, SVfARG(msg));
3363 force_cpy = force_cpy || assign;
3368 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
3369 * operation. we need this to return a value, so that it can be assigned
3370 * later on, in the postpr block (case inc_amg/dec_amg), even if the
3371 * increment or decrement was itself called in void context */
3377 if (off == subtr_amg)
3380 /* in these cases, we're calling an assignment variant of an operator
3381 * (+= rather than +, for instance). regardless of whether it's a
3382 * fallback or not, it always has to return a value, which will be
3383 * assigned to the proper variable later */
3403 /* the copy constructor always needs to return a value */
3407 /* because of the way these are implemented (they don't perform the
3408 * dereferencing themselves, they return a reference that perl then
3409 * dereferences later), they always have to be in scalar context */
3417 /* these don't have an op of their own; they're triggered by their parent
3418 * op, so the context there isn't meaningful ('$a and foo()' in void
3419 * context still needs to pass scalar context on to $a's bool overload) */
3429 DEBUG_o(Perl_deb(aTHX_
3430 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n",
3432 method+assignshift==off? "" :
3434 method+assignshift==off? "" :
3435 AMG_id2name(method+assignshift),
3436 method+assignshift==off? "" : "\")",
3437 flags & AMGf_unary? "" :
3438 lr==1 ? " for right argument": " for left argument",
3439 flags & AMGf_unary? " for argument" : "",
3440 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
3441 fl? ",\n\tassignment variant used": "") );
3444 /* Since we use shallow copy during assignment, we need
3445 * to dublicate the contents, probably calling user-supplied
3446 * version of copy operator
3448 /* We need to copy in following cases:
3449 * a) Assignment form was called.
3450 * assignshift==1, assign==T, method + 1 == off
3451 * b) Increment or decrement, called directly.
3452 * assignshift==0, assign==0, method + 0 == off
3453 * c) Increment or decrement, translated to assignment add/subtr.
3454 * assignshift==0, assign==T,
3456 * d) Increment or decrement, translated to nomethod.
3457 * assignshift==0, assign==0,
3459 * e) Assignment form translated to nomethod.
3460 * assignshift==1, assign==T, method + 1 != off
3463 /* off is method, method+assignshift, or a result of opcode substitution.
3464 * In the latter case assignshift==0, so only notfound case is important.
3466 if ( (lr == -1) && ( ( (method + assignshift == off)
3467 && (assign || (method == inc_amg) || (method == dec_amg)))
3470 /* newSVsv does not behave as advertised, so we copy missing
3471 * information by hand */
3472 SV *tmpRef = SvRV(left);
3474 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
3475 SvRV_set(left, rv_copy);
3477 SvREFCNT_dec_NN(tmpRef);
3485 const bool oldcatch = CATCH_GET;
3487 /* for multiconcat, we may call overload several times,
3488 * with the context of individual concats being scalar,
3489 * regardless of the overall context of the multiconcat op
3491 U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
3492 ? G_SCALAR : GIMME_V;
3495 Zero(&myop, 1, BINOP);
3496 myop.op_last = (OP *) &myop;
3497 myop.op_next = NULL;
3498 myop.op_flags = OPf_STACKED;
3502 myop.op_flags |= OPf_WANT_VOID;
3505 if (flags & AMGf_want_list) {
3506 myop.op_flags |= OPf_WANT_LIST;
3511 myop.op_flags |= OPf_WANT_SCALAR;
3515 PUSHSTACKi(PERLSI_OVERLOAD);
3518 PL_op = (OP *) &myop;
3519 if (PERLDB_SUB && PL_curstash != PL_debstash)
3520 PL_op->op_private |= OPpENTERSUB_DB;
3521 Perl_pp_pushmark(aTHX);
3523 EXTEND(SP, notfound + 5);
3524 PUSHs(lr>0? right: left);
3525 PUSHs(lr>0? left: right);
3526 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3528 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3529 AMG_id2namelen(method + assignshift), SVs_TEMP));
3531 else if (flags & AMGf_numarg)
3532 PUSHs(&PL_sv_undef);
3533 if (flags & AMGf_numarg)
3535 PUSHs(MUTABLE_SV(cv));
3539 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3543 nret = SP - (PL_stack_base + oldmark);
3547 /* returning NULL has another meaning, and we check the context
3548 * at the call site too, so this can be differentiated from the
3551 SP = PL_stack_base + oldmark;
3554 if (flags & AMGf_want_list) {
3555 res = sv_2mortal((SV *)newAV());
3556 av_extend((AV *)res, nret);
3558 av_store((AV *)res, nret, POPs);
3569 CATCH_SET(oldcatch);
3576 ans=SvIV(res)<=0; break;
3579 ans=SvIV(res)<0; break;
3582 ans=SvIV(res)>=0; break;
3585 ans=SvIV(res)>0; break;
3588 ans=SvIV(res)==0; break;
3591 ans=SvIV(res)!=0; break;
3594 SvSetSV(left,res); return left;
3596 ans=!SvTRUE_NN(res); break;
3601 } else if (method==copy_amg) {
3603 Perl_croak(aTHX_ "Copy method did not return a reference");
3605 return SvREFCNT_inc(SvRV(res));
3613 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3618 PERL_ARGS_ASSERT_GV_NAME_SET;
3621 Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len);
3623 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3624 unshare_hek(GvNAME_HEK(gv));
3627 PERL_HASH(hash, name, len);
3628 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3632 =for apidoc gv_try_downgrade
3634 If the typeglob C<gv> can be expressed more succinctly, by having
3635 something other than a real GV in its place in the stash, replace it
3636 with the optimised form. Basic requirements for this are that C<gv>
3637 is a real typeglob, is sufficiently ordinary, and is only referenced
3638 from its package. This function is meant to be used when a GV has been
3639 looked up in part to see what was there, causing upgrading, but based
3640 on what was found it turns out that the real GV isn't required after all.
3642 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3644 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3645 sub, the typeglob is replaced with a scalar-reference placeholder that
3646 more compactly represents the same thing.
3652 Perl_gv_try_downgrade(pTHX_ GV *gv)
3658 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3660 /* XXX Why and where does this leave dangling pointers during global
3662 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3664 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3665 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3666 isGV_with_GP(gv) && GvGP(gv) &&
3667 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3668 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3669 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3671 if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
3673 if (SvMAGICAL(gv)) {
3675 /* only backref magic is allowed */
3676 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3678 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3679 if (mg->mg_type != PERL_MAGIC_backref)
3685 HEK *gvnhek = GvNAME_HEK(gv);
3686 (void)hv_deletehek(stash, gvnhek, G_DISCARD);
3687 } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
3688 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3689 CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
3690 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3691 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3692 (namehek = GvNAME_HEK(gv)) &&
3693 (gvp = hv_fetchhek(stash, namehek, 0)) &&
3695 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3696 const bool imported = !!GvIMPORTED_CV(gv);
3700 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3702 /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
3703 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3704 STRUCT_OFFSET(XPVIV, xiv_iv));
3705 SvRV_set(gv, value);
3710 Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
3712 GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
3714 PERL_ARGS_ASSERT_GV_OVERRIDE;
3715 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
3716 gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
3717 gv = gvp ? *gvp : NULL;
3718 if (gv && !isGV(gv)) {
3719 if (!SvPCS_IMPORTED(gv)) return NULL;
3720 gv_init(gv, PL_globalstash, name, len, 0);
3723 return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
3729 core_xsub(pTHX_ CV* cv)
3732 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3737 * ex: set ts=8 sts=4 sw=4 et: