3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
13 * of your inquisitiveness, I shall spend all the rest of my days in answering
14 * you. What more do you want to know?'
15 * 'The names of all the stars, and of all living things, and the whole
16 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
19 * [p.599 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
27 corresponding to $foo, @foo, %foo.
29 GVs are usually found as values in stashes (symbol table hashes) where
30 Perl stores its global variables.
42 static const char S_autoload[] = "AUTOLOAD";
43 static const STRLEN S_autolen = sizeof(S_autoload)-1;
46 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
53 SvTYPE((const SV *)gv) != SVt_PVGV
54 && SvTYPE((const SV *)gv) != SVt_PVLV
58 if (type == SVt_PVIO) {
60 * if it walks like a dirhandle, then let's assume that
61 * this is a dirhandle.
63 what = OP_IS_DIRHOP(PL_op->op_type) ?
64 "dirhandle" : "filehandle";
65 } else if (type == SVt_PVHV) {
68 what = type == SVt_PVAV ? "array" : "scalar";
70 /* diag_listed_as: Bad symbol for filehandle */
71 Perl_croak(aTHX_ "Bad symbol for %s", what);
74 if (type == SVt_PVHV) {
75 where = (SV **)&GvHV(gv);
76 } else if (type == SVt_PVAV) {
77 where = (SV **)&GvAV(gv);
78 } else if (type == SVt_PVIO) {
79 where = (SV **)&GvIOp(gv);
85 *where = newSV_type(type);
86 if (type == SVt_PVAV && GvNAMELEN(gv) == 3
87 && strnEQ(GvNAME(gv), "ISA", 3))
88 sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
93 Perl_gv_fetchfile(pTHX_ const char *name)
95 PERL_ARGS_ASSERT_GV_FETCHFILE;
96 return gv_fetchfile_flags(name, strlen(name), 0);
100 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 || PERLDB_SAVESRC) && !GvAV(gv))
133 hv_magic(GvHVn(gv_AVadd(gv)), NULL, 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;
155 if (SvTYPE(gv) == SVt_PVGV)
156 return cv_const_sv(GvCVu(gv));
157 return SvROK(gv) ? SvRV(gv) : NULL;
161 Perl_newGP(pTHX_ GV *const gv)
166 const char *const file
167 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
168 const STRLEN len = strlen(file);
170 SV *const temp_sv = CopFILESV(PL_curcop);
174 PERL_ARGS_ASSERT_NEWGP;
177 file = SvPVX(temp_sv);
178 len = SvCUR(temp_sv);
185 PERL_HASH(hash, file, len);
189 #ifndef PERL_DONT_CREATE_GVSV
190 gp->gp_sv = newSV(0);
193 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
194 /* XXX Ideally this cast would be replaced with a change to const char*
196 gp->gp_file_hek = share_hek(file, len, hash);
203 /* Assign CvGV(cv) = gv, handling weak references.
204 * See also S_anonymise_cv_maybe */
207 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
209 GV * const oldgv = CvGV(cv);
211 PERL_ARGS_ASSERT_CVGV_SET;
222 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
225 else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
227 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
228 assert(!CvCVGV_RC(cv));
233 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
234 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
237 SvREFCNT_inc_simple_void_NN(gv);
241 /* Assign CvSTASH(cv) = st, handling weak references. */
244 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
246 HV *oldst = CvSTASH(cv);
247 PERL_ARGS_ASSERT_CVSTASH_SET;
251 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
252 SvANY(cv)->xcv_stash = st;
254 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
258 =for apidoc gv_init_pvn
260 Converts a scalar into a typeglob. This is an incoercible typeglob;
261 assigning a reference to it will assign to one of its slots, instead of
262 overwriting it as happens with typeglobs created by SvSetSV. Converting
263 any scalar that is SvOK() may produce unpredictable results and is reserved
264 for perl's internal use.
266 C<gv> is the scalar to be converted.
268 C<stash> is the parent stash/package, if any.
270 C<name> and C<len> give the name. The name must be unqualified;
271 that is, it must not include the package name. If C<gv> is a
272 stash element, it is the caller's responsibility to ensure that the name
273 passed to this function matches the name of the element. If it does not
274 match, perl's internal bookkeeping will get out of sync.
276 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
277 the return value of SvUTF8(sv). It can also take the
278 GV_ADDMULTI flag, which means to pretend that the GV has been
279 seen before (i.e., suppress "Used once" warnings).
283 The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
284 has no flags parameter. If the C<multi> parameter is set, the
285 GV_ADDMULTI flag will be passed to gv_init_pvn().
287 =for apidoc gv_init_pv
289 Same as gv_init_pvn(), but takes a nul-terminated string for the name
290 instead of separate char * and length parameters.
292 =for apidoc gv_init_sv
294 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
295 char * and length parameters. C<flags> is currently unused.
301 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
305 PERL_ARGS_ASSERT_GV_INIT_SV;
306 namepv = SvPV(namesv, namelen);
309 gv_init_pvn(gv, stash, namepv, namelen, flags);
313 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
315 PERL_ARGS_ASSERT_GV_INIT_PV;
316 gv_init_pvn(gv, stash, name, strlen(name), flags);
320 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
323 const U32 old_type = SvTYPE(gv);
324 const bool doproto = old_type > SVt_NULL;
325 char * const proto = (doproto && SvPOK(gv))
326 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
328 const STRLEN protolen = proto ? SvCUR(gv) : 0;
329 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
330 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
331 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
333 PERL_ARGS_ASSERT_GV_INIT_PVN;
334 assert (!(proto && has_constant));
337 /* The constant has to be a simple scalar type. */
338 switch (SvTYPE(has_constant)) {
344 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
345 sv_reftype(has_constant, 0));
353 if (old_type < SVt_PVGV) {
354 if (old_type >= SVt_PV)
356 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
364 Safefree(SvPVX_mutable(gv));
369 GvGP_set(gv, Perl_newGP(aTHX_ gv));
372 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
373 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
374 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
375 GvMULTI_on(gv); /* _was_ mentioned */
379 /* newCONSTSUB takes ownership of the reference from us. */
380 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
381 /* In case op.c:S_process_special_blocks stole it: */
383 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
384 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
385 /* If this reference was a copy of another, then the subroutine
386 must have been "imported", by a Perl space assignment to a GV
387 from a reference to CV. */
388 if (exported_constant)
389 GvIMPORTED_CV_on(gv);
390 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
395 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
396 SV_HAS_TRAILING_NUL);
397 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
403 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
405 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
417 #ifdef PERL_DONT_CREATE_GVSV
425 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
426 If we just cast GvSVn(gv) to void, it ignores evaluating it for
433 static void core_xsub(pTHX_ CV* cv);
436 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
437 const char * const name, const STRLEN len)
439 const int code = keyword(name, len, 1);
440 static const char file[] = __FILE__;
441 CV *cv, *oldcompcv = NULL;
444 bool ampable = TRUE; /* &{}-able */
445 COP *oldcurcop = NULL;
446 yy_parser *oldparser = NULL;
447 I32 oldsavestack_ix = 0;
452 if (!code) return NULL; /* Not a keyword */
453 switch (code < 0 ? -code : code) {
454 /* no support for \&CORE::infix;
455 no support for funcs that do not parse like funcs */
456 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
457 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
458 case KEY_default : case KEY_DESTROY:
459 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
460 case KEY_END : case KEY_eq : case KEY_eval :
461 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
462 case KEY_given : case KEY_goto : case KEY_grep :
463 case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
464 case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
465 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
466 case KEY_package: case KEY_print: case KEY_printf:
467 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
468 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
469 case KEY_s : case KEY_say : case KEY_sort :
470 case KEY_state: case KEY_sub :
471 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
472 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
473 case KEY_x : case KEY_xor : case KEY_y :
476 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
477 case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
483 case KEY_splice: case KEY_split:
486 case KEY_truncate: case KEY_unlink:
493 gv_init(gv, stash, name, len, TRUE);
498 oldcurcop = PL_curcop;
499 oldparser = PL_parser;
500 lex_start(NULL, NULL, 0);
501 oldcompcv = PL_compcv;
502 PL_compcv = NULL; /* Prevent start_subparse from setting
504 oldsavestack_ix = start_subparse(FALSE,0);
508 /* Avoid calling newXS, as it calls us, and things start to
510 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
513 mro_method_changed_in(GvSTASH(gv));
515 CvXSUB(cv) = core_xsub;
517 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
519 (void)gv_fetchfile(file);
520 CvFILE(cv) = (char *)file;
521 /* XXX This is inefficient, as doing things this order causes
522 a prototype check in newATTRSUB. But we have to do
523 it this order as we need an op number before calling
525 (void)core_prototype((SV *)cv, name, code, &opnum);
527 (void)hv_store(stash,name,len,(SV *)gv,0);
531 oldsavestack_ix, (OP *)gv,
536 : newSVpvn(name,len),
541 assert(GvCV(gv) == cv);
542 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
543 && opnum != OP_UNDEF)
544 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
546 PL_parser = oldparser;
547 PL_curcop = oldcurcop;
548 PL_compcv = oldcompcv;
550 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
552 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
554 SvREFCNT_dec(opnumsv);
559 =for apidoc gv_fetchmeth
561 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
563 =for apidoc gv_fetchmeth_sv
565 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
566 of an SV instead of a string/length pair.
572 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
576 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
577 namepv = SvPV(namesv, namelen);
580 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
584 =for apidoc gv_fetchmeth_pv
586 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
587 instead of a string/length pair.
593 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
595 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
596 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
600 =for apidoc gv_fetchmeth_pvn
602 Returns the glob with the given C<name> and a defined subroutine or
603 C<NULL>. The glob lives in the given C<stash>, or in the stashes
604 accessible via @ISA and UNIVERSAL::.
606 The argument C<level> should be either 0 or -1. If C<level==0>, as a
607 side-effect creates a glob with the given C<name> in the given C<stash>
608 which in the case of success contains an alias for the subroutine, and sets
609 up caching info for this glob.
611 The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
613 GV_SUPER indicates that we want to look up the method in the superclasses
617 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
618 visible to Perl code. So when calling C<call_sv>, you should not use
619 the GV directly; instead, you should use the method's CV, which can be
620 obtained from the GV with the C<GvCV> macro.
625 /* NOTE: No support for tied ISA */
628 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
635 HV* cstash, *cachestash;
636 GV* candidate = NULL;
640 I32 create = (level >= 0) ? 1 : 0;
644 U32 is_utf8 = flags & SVf_UTF8;
646 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
648 /* UNIVERSAL methods should be callable without a stash */
650 create = 0; /* probably appropriate */
651 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
657 hvname = HvNAME_get(stash);
659 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
664 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
665 flags & GV_SUPER ? "SUPER " : "",name,hvname) );
667 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
669 if (flags & GV_SUPER) {
670 if (!HvAUX(stash)->xhv_super) HvAUX(stash)->xhv_super = newHV();
671 cachestash = HvAUX(stash)->xhv_super;
673 else cachestash = stash;
675 /* check locally for a real method or a cache entry */
676 gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
682 if (SvTYPE(topgv) != SVt_PVGV)
683 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
684 if ((cand_cv = GvCV(topgv))) {
685 /* If genuine method or valid cache entry, use it */
686 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
690 /* stale cache entry, junk it and move on */
691 SvREFCNT_dec(cand_cv);
692 GvCV_set(topgv, NULL);
697 else if (GvCVGEN(topgv) == topgen_cmp) {
698 /* cache indicates no such method definitively */
701 else if (stash == cachestash
702 && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
703 && strnEQ(hvname, "CORE", 4)
704 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
708 packlen = HvNAMELEN_get(stash);
709 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
710 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
711 items = AvFILLp(linear_av); /* no +1, to skip over self */
713 linear_sv = *linear_svp++;
715 cstash = gv_stashsv(linear_sv, 0);
718 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
719 "Can't locate package %"SVf" for @%"HEKf"::ISA",
721 HEKfARG(HvNAME_HEK(stash)));
727 gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
729 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
730 const char *hvname = HvNAME(cstash); assert(hvname);
731 if (strnEQ(hvname, "CORE", 4)
733 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
739 else candidate = *gvp;
742 if (SvTYPE(candidate) != SVt_PVGV)
743 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
744 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
746 * Found real method, cache method in topgv if:
747 * 1. topgv has no synonyms (else inheritance crosses wires)
748 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
750 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
751 CV *old_cv = GvCV(topgv);
752 SvREFCNT_dec(old_cv);
753 SvREFCNT_inc_simple_void_NN(cand_cv);
754 GvCV_set(topgv, cand_cv);
755 GvCVGEN(topgv) = topgen_cmp;
761 /* Check UNIVERSAL without caching */
762 if(level == 0 || level == -1) {
763 candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
765 cand_cv = GvCV(candidate);
766 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
767 CV *old_cv = GvCV(topgv);
768 SvREFCNT_dec(old_cv);
769 SvREFCNT_inc_simple_void_NN(cand_cv);
770 GvCV_set(topgv, cand_cv);
771 GvCVGEN(topgv) = topgen_cmp;
777 if (topgv && GvREFCNT(topgv) == 1) {
778 /* cache the fact that the method is not defined */
779 GvCVGEN(topgv) = topgen_cmp;
786 =for apidoc gv_fetchmeth_autoload
788 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
791 =for apidoc gv_fetchmeth_sv_autoload
793 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
794 of an SV instead of a string/length pair.
800 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
804 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
805 namepv = SvPV(namesv, namelen);
808 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
812 =for apidoc gv_fetchmeth_pv_autoload
814 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
815 instead of a string/length pair.
821 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
823 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
824 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
828 =for apidoc gv_fetchmeth_pvn_autoload
830 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
831 Returns a glob for the subroutine.
833 For an autoloaded subroutine without a GV, will create a GV even
834 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
835 of the result may be zero.
837 Currently, the only significant value for C<flags> is SVf_UTF8.
843 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
845 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
847 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
854 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
855 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
857 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
860 if (!(CvROOT(cv) || CvXSUB(cv)))
862 /* Have an autoload */
863 if (level < 0) /* Cannot do without a stub */
864 gv_fetchmeth_pvn(stash, name, len, 0, flags);
865 gvp = (GV**)hv_fetch(stash, name,
866 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
875 =for apidoc gv_fetchmethod_autoload
877 Returns the glob which contains the subroutine to call to invoke the method
878 on the C<stash>. In fact in the presence of autoloading this may be the
879 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
882 The third parameter of C<gv_fetchmethod_autoload> determines whether
883 AUTOLOAD lookup is performed if the given method is not present: non-zero
884 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
885 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
886 with a non-zero C<autoload> parameter.
888 These functions grant C<"SUPER"> token as a prefix of the method name. Note
889 that if you want to keep the returned glob for a long time, you need to
890 check for it being "AUTOLOAD", since at the later time the call may load a
891 different subroutine due to $AUTOLOAD changing its value. Use the glob
892 created via a side effect to do this.
894 These functions have the same side-effects and as C<gv_fetchmeth> with
895 C<level==0>. C<name> should be writable if contains C<':'> or C<'
896 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
897 C<call_sv> apply equally to these functions.
903 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
905 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
907 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
911 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
915 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
916 namepv = SvPV(namesv, namelen);
919 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
923 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
925 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
926 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
929 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
932 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
936 const char *nsplit = NULL;
939 const char * const origname = name;
940 SV *const error_report = MUTABLE_SV(stash);
941 const U32 autoload = flags & GV_AUTOLOAD;
942 const U32 do_croak = flags & GV_CROAK;
943 const U32 is_utf8 = flags & SVf_UTF8;
945 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
947 if (SvTYPE(stash) < SVt_PVHV)
950 /* The only way stash can become NULL later on is if nsplit is set,
951 which in turn means that there is no need for a SVt_PVHV case
952 the error reporting code. */
955 for (nend = name; *nend || nend != (origname + len); nend++) {
960 else if (*nend == ':' && *(nend + 1) == ':') {
966 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
967 /* ->SUPER::method should really be looked up in original stash */
968 stash = CopSTASH(PL_curcop);
970 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
971 origname, HvENAME_get(stash), name) );
973 else if ((nsplit - origname) >= 7 &&
974 strnEQ(nsplit - 7, "::SUPER", 7)) {
975 /* don't autovifify if ->NoSuchStash::SUPER::method */
976 stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
977 if (stash) flags |= GV_SUPER;
980 /* don't autovifify if ->NoSuchStash::method */
981 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
986 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
988 if (strEQ(name,"import") || strEQ(name,"unimport"))
989 gv = MUTABLE_GV(&PL_sv_yes);
991 gv = gv_autoload_pvn(
992 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
994 if (!gv && do_croak) {
995 /* Right now this is exclusively for the benefit of S_method_common
998 /* If we can't find an IO::File method, it might be a call on
999 * a filehandle. If IO:File has not been loaded, try to
1000 * require it first instead of croaking */
1001 const char *stash_name = HvNAME_get(stash);
1002 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1003 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1004 STR_WITH_LEN("IO/File.pm"), 0,
1005 HV_FETCH_ISEXISTS, NULL, 0)
1007 require_pv("IO/File.pm");
1008 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1013 "Can't locate object method \"%"SVf
1014 "\" via package \"%"HEKf"\"",
1015 SVfARG(newSVpvn_flags(name, nend - name,
1016 SVs_TEMP | is_utf8)),
1017 HEKfARG(HvNAME_HEK(stash)));
1023 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1024 SVs_TEMP | is_utf8);
1026 packnamesv = sv_2mortal(newSVsv(error_report));
1030 "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
1031 " (perhaps you forgot to load \"%"SVf"\"?)",
1032 SVfARG(newSVpvn_flags(name, nend - name,
1033 SVs_TEMP | is_utf8)),
1034 SVfARG(packnamesv), SVfARG(packnamesv));
1038 else if (autoload) {
1039 CV* const cv = GvCV(gv);
1040 if (!CvROOT(cv) && !CvXSUB(cv)) {
1048 if (GvCV(stubgv) != cv) /* orphaned import */
1051 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1052 GvNAME(stubgv), GvNAMELEN(stubgv),
1053 GV_AUTOLOAD_ISMETHOD
1054 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1064 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1068 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1069 namepv = SvPV(namesv, namelen);
1072 return gv_autoload_pvn(stash, namepv, namelen, flags);
1076 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1078 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1079 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1083 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1091 SV *packname = NULL;
1092 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1094 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1096 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1099 if (SvTYPE(stash) < SVt_PVHV) {
1100 STRLEN packname_len = 0;
1101 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1102 packname = newSVpvn_flags(packname_ptr, packname_len,
1103 SVs_TEMP | SvUTF8(stash));
1107 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1108 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1110 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1114 if (!(CvROOT(cv) || CvXSUB(cv)))
1118 * Inheriting AUTOLOAD for non-methods works ... for now.
1121 !(flags & GV_AUTOLOAD_ISMETHOD)
1122 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1124 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1125 "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
1127 SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1130 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1131 * and split that value on the last '::', pass along the same data
1132 * via the SvPVX field in the CV, and the stash in CvSTASH.
1134 * Due to an unfortunate accident of history, the SvPVX field
1135 * serves two purposes. It is also used for the subroutine's pro-
1136 * type. Since SvPVX has been documented as returning the sub name
1137 * for a long time, but not as returning the prototype, we have
1138 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1141 * We put the prototype in the same allocated buffer, but after
1142 * the sub name. The SvPOK flag indicates the presence of a proto-
1143 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1144 * If both flags are on, then SvLEN is used to indicate the end of
1145 * the prototype (artificially lower than what is actually allo-
1146 * cated), at the risk of having to reallocate a few bytes unneces-
1147 * sarily--but that should happen very rarely, if ever.
1149 * We use SvUTF8 for both prototypes and sub names, so if one is
1150 * UTF8, the other must be upgraded.
1152 CvSTASH_set(cv, stash);
1153 if (SvPOK(cv)) { /* Ouch! */
1154 SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
1156 const char *proto = CvPROTO(cv);
1159 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1160 ulen = SvCUR(tmpsv);
1161 SvCUR(tmpsv)++; /* include null in string */
1163 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1165 SvTEMP_on(tmpsv); /* Allow theft */
1166 sv_setsv_nomg((SV *)cv, tmpsv);
1168 SvREFCNT_dec(tmpsv);
1169 SvLEN(cv) = SvCUR(cv) + 1;
1173 sv_setpvn((SV *)cv, name, len);
1177 else SvUTF8_off(cv);
1183 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1184 * The subroutine's original name may not be "AUTOLOAD", so we don't
1185 * use that, but for lack of anything better we will use the sub's
1186 * original package to look up $AUTOLOAD.
1188 varstash = GvSTASH(CvGV(cv));
1189 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1193 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1194 #ifdef PERL_DONT_CREATE_GVSV
1195 GvSV(vargv) = newSV(0);
1199 varsv = GvSVn(vargv);
1200 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1201 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1202 sv_setsv(varsv, packname);
1203 sv_catpvs(varsv, "::");
1204 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1205 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1208 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1216 /* require_tie_mod() internal routine for requiring a module
1217 * that implements the logic of automatic ties like %! and %-
1219 * The "gv" parameter should be the glob.
1220 * "varpv" holds the name of the var, used for error messages.
1221 * "namesv" holds the module name. Its refcount will be decremented.
1222 * "methpv" holds the method name to test for to check that things
1223 * are working reasonably close to as expected.
1224 * "flags": if flag & 1 then save the scalar before loading.
1225 * For the protection of $! to work (it is set by this routine)
1226 * the sv slot must already be magicalized.
1229 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1232 HV* stash = gv_stashsv(namesv, 0);
1234 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1236 if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1237 SV *module = newSVsv(namesv);
1238 char varname = *varpv; /* varpv might be clobbered by load_module,
1239 so save it. For the moment it's always
1241 const char type = varname == '[' ? '$' : '%';
1246 PUSHSTACKi(PERLSI_MAGIC);
1247 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1251 stash = gv_stashsv(namesv, 0);
1253 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1254 type, varname, SVfARG(namesv));
1255 else if (!gv_fetchmethod(stash, methpv))
1256 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1257 type, varname, SVfARG(namesv), methpv);
1259 SvREFCNT_dec(namesv);
1264 =for apidoc gv_stashpv
1266 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1267 determine the length of C<name>, then calls C<gv_stashpvn()>.
1273 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1275 PERL_ARGS_ASSERT_GV_STASHPV;
1276 return gv_stashpvn(name, strlen(name), create);
1280 =for apidoc gv_stashpvn
1282 Returns a pointer to the stash for a specified package. The C<namelen>
1283 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1284 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1285 created if it does not already exist. If the package does not exist and
1286 C<flags> is 0 (or any other setting that does not create packages) then NULL
1289 Flags may be one of:
1298 The most important of which are probably GV_ADD and SVf_UTF8.
1304 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1310 U32 tmplen = namelen + 2;
1312 PERL_ARGS_ASSERT_GV_STASHPVN;
1314 if (tmplen <= sizeof smallbuf)
1317 Newx(tmpbuf, tmplen, char);
1318 Copy(name, tmpbuf, namelen, char);
1319 tmpbuf[namelen] = ':';
1320 tmpbuf[namelen+1] = ':';
1321 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1322 if (tmpbuf != smallbuf)
1326 stash = GvHV(tmpgv);
1327 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1329 if (!HvNAME_get(stash)) {
1330 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1332 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1333 /* If the containing stash has multiple effective
1334 names, see that this one gets them, too. */
1335 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1336 mro_package_moved(stash, NULL, tmpgv, 1);
1342 =for apidoc gv_stashsv
1344 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
1350 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1353 const char * const ptr = SvPV_const(sv,len);
1355 PERL_ARGS_ASSERT_GV_STASHSV;
1357 return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1362 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1363 PERL_ARGS_ASSERT_GV_FETCHPV;
1364 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1368 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1370 const char * const nambeg =
1371 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1372 PERL_ARGS_ASSERT_GV_FETCHSV;
1373 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1377 S_gv_magicalize_isa(pTHX_ GV *gv)
1381 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1385 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1390 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1391 const svtype sv_type)
1394 const char *name = nambeg;
1398 const char *name_cursor;
1400 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1401 const I32 no_expand = flags & GV_NOEXPAND;
1402 const I32 add = flags & ~GV_NOADD_MASK;
1403 const U32 is_utf8 = flags & SVf_UTF8;
1404 bool addmg = !!(flags & GV_ADDMG);
1405 const char *const name_end = nambeg + full_len;
1406 const char *const name_em1 = name_end - 1;
1409 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1411 if (flags & GV_NOTQUAL) {
1412 /* Caller promised that there is no stash, so we can skip the check. */
1417 if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1418 /* accidental stringify on a GV? */
1422 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1423 if (name_cursor < name_em1 &&
1424 ((*name_cursor == ':'
1425 && name_cursor[1] == ':')
1426 || *name_cursor == '\''))
1429 stash = PL_defstash;
1430 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1433 len = name_cursor - name;
1434 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1436 if (*name_cursor == ':') {
1441 Newx(tmpbuf, len+2, char);
1442 Copy(name, tmpbuf, len, char);
1443 tmpbuf[len++] = ':';
1444 tmpbuf[len++] = ':';
1447 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1448 gv = gvp ? *gvp : NULL;
1449 if (gv && gv != (const GV *)&PL_sv_undef) {
1450 if (SvTYPE(gv) != SVt_PVGV)
1451 gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1457 if (!gv || gv == (const GV *)&PL_sv_undef)
1460 if (!(stash = GvHV(gv)))
1462 stash = GvHV(gv) = newHV();
1463 if (!HvNAME_get(stash)) {
1464 if (GvSTASH(gv) == PL_defstash && len == 6
1465 && strnEQ(name, "CORE", 4))
1466 hv_name_set(stash, "CORE", 4, 0);
1469 stash, nambeg, name_cursor-nambeg, is_utf8
1471 /* If the containing stash has multiple effective
1472 names, see that this one gets them, too. */
1473 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1474 mro_package_moved(stash, NULL, gv, 1);
1477 else if (!HvNAME_get(stash))
1478 hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1481 if (*name_cursor == ':')
1483 name = name_cursor+1;
1484 if (name == name_end)
1486 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1489 len = name_cursor - name;
1491 /* No stash in name, so see how we can default */
1495 if (len && isIDFIRST_lazy(name)) {
1496 bool global = FALSE;
1504 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1505 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1506 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1510 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1515 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1516 && name[3] == 'I' && name[4] == 'N')
1520 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1521 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1522 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1526 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1527 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1534 stash = PL_defstash;
1535 else if (IN_PERL_COMPILETIME) {
1536 stash = PL_curstash;
1537 if (add && (PL_hints & HINT_STRICT_VARS) &&
1538 sv_type != SVt_PVCV &&
1539 sv_type != SVt_PVGV &&
1540 sv_type != SVt_PVFM &&
1541 sv_type != SVt_PVIO &&
1542 !(len == 1 && sv_type == SVt_PV &&
1543 (*name == 'a' || *name == 'b')) )
1545 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1547 *gvp == (const GV *)&PL_sv_undef ||
1548 SvTYPE(*gvp) != SVt_PVGV)
1552 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1553 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1554 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1556 SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
1557 /* diag_listed_as: Variable "%s" is not imported%s */
1559 aTHX_ packWARN(WARN_MISC),
1560 "Variable \"%c%"SVf"\" is not imported",
1561 sv_type == SVt_PVAV ? '@' :
1562 sv_type == SVt_PVHV ? '%' : '$',
1566 aTHX_ packWARN(WARN_MISC),
1567 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
1574 stash = CopSTASH(PL_curcop);
1577 stash = PL_defstash;
1580 /* By this point we should have a stash and a name */
1584 SV * const err = Perl_mess(aTHX_
1585 "Global symbol \"%s%"SVf"\" requires explicit package name",
1586 (sv_type == SVt_PV ? "$"
1587 : sv_type == SVt_PVAV ? "@"
1588 : sv_type == SVt_PVHV ? "%"
1589 : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1591 if (USE_UTF8_IN_NAMES)
1594 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1596 /* symbol table under destruction */
1605 if (!SvREFCNT(stash)) /* symbol table under destruction */
1608 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1609 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1610 if (addmg) gv = (GV *)newSV(0);
1613 else gv = *gvp, addmg = 0;
1614 /* From this point on, addmg means gv has not been inserted in the
1617 if (SvTYPE(gv) == SVt_PVGV) {
1620 gv_init_svtype(gv, sv_type);
1621 if (len == 1 && stash == PL_defstash) {
1622 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
1624 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1625 else if (*name == '-' || *name == '+')
1626 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1628 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
1631 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1634 PL_sawampersand |= SAWAMPERSAND_LEFT;
1638 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
1642 PL_sawampersand |= SAWAMPERSAND_RIGHT;
1648 else if (len == 3 && sv_type == SVt_PVAV
1649 && strnEQ(name, "ISA", 3)
1650 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1651 gv_magicalize_isa(gv);
1654 } else if (no_init) {
1657 } else if (no_expand && SvROK(gv)) {
1662 /* Adding a new symbol.
1663 Unless of course there was already something non-GV here, in which case
1664 we want to behave as if there was always a GV here, containing some sort
1666 Otherwise we run the risk of creating things like GvIO, which can cause
1667 subtle bugs. eg the one that tripped up SQL::Translator */
1669 faking_it = SvOK(gv);
1671 if (add & GV_ADDWARN)
1672 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
1673 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
1674 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1676 if ( isIDFIRST_lazy_if(name, is_utf8)
1677 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1680 /* set up magic where warranted */
1681 if (stash != PL_defstash) { /* not the main stash */
1682 /* We only have to check for three names here: EXPORT, ISA
1683 and VERSION. All the others apply only to the main stash or to
1684 CORE (which is checked right after this). */
1686 const char * const name2 = name + 1;
1689 if (strnEQ(name2, "XPORT", 5))
1693 if (strEQ(name2, "SA"))
1694 gv_magicalize_isa(gv);
1697 if (strEQ(name2, "ERSION"))
1703 goto add_magical_gv;
1706 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1707 /* Avoid null warning: */
1708 const char * const stashname = HvNAME(stash); assert(stashname);
1709 if (strnEQ(stashname, "CORE", 4))
1710 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1717 /* Nothing else to do.
1718 The compiler will probably turn the switch statement into a
1719 branch table. Make sure we avoid even that small overhead for
1720 the common case of lower case variable names. */
1724 const char * const name2 = name + 1;
1727 if (strEQ(name2, "RGV")) {
1728 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1730 else if (strEQ(name2, "RGVOUT")) {
1735 if (strnEQ(name2, "XPORT", 5))
1739 if (strEQ(name2, "SA")) {
1740 gv_magicalize_isa(gv);
1744 if (strEQ(name2, "IG")) {
1747 if (!PL_psig_name) {
1748 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1749 Newxz(PL_psig_pend, SIG_SIZE, int);
1750 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1752 /* I think that the only way to get here is to re-use an
1753 embedded perl interpreter, where the previous
1754 use didn't clean up fully because
1755 PL_perl_destruct_level was 0. I'm not sure that we
1756 "support" that, in that I suspect in that scenario
1757 there are sufficient other garbage values left in the
1758 interpreter structure that something else will crash
1759 before we get here. I suspect that this is one of
1760 those "doctor, it hurts when I do this" bugs. */
1761 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1762 Zero(PL_psig_pend, SIG_SIZE, int);
1766 hv_magic(hv, NULL, PERL_MAGIC_sig);
1767 for (i = 1; i < SIG_SIZE; i++) {
1768 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1770 sv_setsv(*init, &PL_sv_undef);
1775 if (strEQ(name2, "ERSION"))
1778 case '\003': /* $^CHILD_ERROR_NATIVE */
1779 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1782 case '\005': /* $^ENCODING */
1783 if (strEQ(name2, "NCODING"))
1786 case '\007': /* $^GLOBAL_PHASE */
1787 if (strEQ(name2, "LOBAL_PHASE"))
1790 case '\015': /* $^MATCH */
1791 if (strEQ(name2, "ATCH"))
1793 case '\017': /* $^OPEN */
1794 if (strEQ(name2, "PEN"))
1797 case '\020': /* $^PREMATCH $^POSTMATCH */
1798 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1801 case '\024': /* ${^TAINT} */
1802 if (strEQ(name2, "AINT"))
1805 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1806 if (strEQ(name2, "NICODE"))
1808 if (strEQ(name2, "TF8LOCALE"))
1810 if (strEQ(name2, "TF8CACHE"))
1813 case '\027': /* $^WARNING_BITS */
1814 if (strEQ(name2, "ARNING_BITS"))
1827 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1829 /* This snippet is taken from is_gv_magical */
1830 const char *end = name + len;
1831 while (--end > name) {
1832 if (!isDIGIT(*end)) goto add_magical_gv;
1839 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1840 be case '\0' in this switch statement (ie a default case) */
1846 sv_type == SVt_PVAV ||
1847 sv_type == SVt_PVHV ||
1848 sv_type == SVt_PVCV ||
1849 sv_type == SVt_PVFM ||
1851 )) { PL_sawampersand |=
1855 ? SAWAMPERSAND_MIDDLE
1856 : SAWAMPERSAND_RIGHT;
1861 sv_setpv(GvSVn(gv),PL_chopset);
1865 #ifdef COMPLEX_STATUS
1866 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1872 /* If %! has been used, automatically load Errno.pm. */
1874 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1876 /* magicalization must be done before require_tie_mod is called */
1877 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1879 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1881 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1887 GvMULTI_on(gv); /* no used once warnings here */
1889 AV* const av = GvAVn(gv);
1890 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1892 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1893 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1895 SvREADONLY_on(GvSVn(gv));
1898 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1900 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1902 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1909 if (sv_type == SVt_PV)
1910 /* diag_listed_as: $* is no longer supported */
1911 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1912 "$%c is no longer supported", *name);
1915 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1918 case '\010': /* $^H */
1920 HV *const hv = GvHVn(gv);
1921 hv_magic(hv, NULL, PERL_MAGIC_hints);
1925 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1926 && FEATURE_ARYBASE_IS_ENABLED) {
1927 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1928 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1931 else goto magicalize;
1933 case '\023': /* $^S */
1935 SvREADONLY_on(GvSVn(gv));
1959 case '\001': /* $^A */
1960 case '\003': /* $^C */
1961 case '\004': /* $^D */
1962 case '\005': /* $^E */
1963 case '\006': /* $^F */
1964 case '\011': /* $^I, NOT \t in EBCDIC */
1965 case '\016': /* $^N */
1966 case '\017': /* $^O */
1967 case '\020': /* $^P */
1968 case '\024': /* $^T */
1969 case '\027': /* $^W */
1971 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1974 case '\014': /* $^L */
1975 sv_setpvs(GvSVn(gv),"\f");
1976 PL_formfeed = GvSV(gv);
1979 sv_setpvs(GvSVn(gv),"\034");
1983 SV * const sv = GvSV(gv);
1984 if (!sv_derived_from(PL_patchlevel, "version"))
1985 upg_version(PL_patchlevel, TRUE);
1986 GvSV(gv) = vnumify(PL_patchlevel);
1987 SvREADONLY_on(GvSV(gv));
1991 case '\026': /* $^V */
1993 SV * const sv = GvSV(gv);
1994 GvSV(gv) = new_version(PL_patchlevel);
1995 SvREADONLY_on(GvSV(gv));
2003 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2004 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2006 (void)hv_store(stash,name,len,(SV *)gv,0);
2007 else SvREFCNT_dec(gv), gv = NULL;
2009 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2014 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2017 const HV * const hv = GvSTASH(gv);
2019 PERL_ARGS_ASSERT_GV_FULLNAME4;
2021 sv_setpv(sv, prefix ? prefix : "");
2023 if (hv && (name = HvNAME(hv))) {
2024 const STRLEN len = HvNAMELEN(hv);
2025 if (keepmain || strnNE(name, "main", len)) {
2026 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2030 else sv_catpvs(sv,"__ANON__::");
2031 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2035 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2037 const GV * const egv = GvEGVx(gv);
2039 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2041 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2045 Perl_gv_check(pTHX_ const HV *stash)
2050 PERL_ARGS_ASSERT_GV_CHECK;
2052 if (!HvARRAY(stash))
2054 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2056 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2059 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2060 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2062 if (hv != PL_defstash && hv != stash)
2063 gv_check(hv); /* nested package */
2065 else if ( *HeKEY(entry) != '_'
2066 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2068 gv = MUTABLE_GV(HeVAL(entry));
2069 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2072 CopLINE_set(PL_curcop, GvLINE(gv));
2074 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2076 CopFILEGV(PL_curcop)
2077 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2079 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2080 "Name \"%"HEKf"::%"HEKf
2081 "\" used only once: possible typo",
2082 HEKfARG(HvNAME_HEK(stash)),
2083 HEKfARG(GvNAME_HEK(gv)));
2090 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2093 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2095 return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2096 SVfARG(newSVpvn_flags(pack, strlen(pack),
2102 /* hopefully this is only called on local symbol table entries */
2105 Perl_gp_ref(pTHX_ GP *gp)
2113 /* If the GP they asked for a reference to contains
2114 a method cache entry, clear it first, so that we
2115 don't infect them with our cached entry */
2116 SvREFCNT_dec(gp->gp_cv);
2125 Perl_gp_free(pTHX_ GV *gv)
2131 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2133 if (gp->gp_refcnt == 0) {
2134 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2135 "Attempt to free unreferenced glob pointers"
2136 pTHX__FORMAT pTHX__VALUE);
2139 if (--gp->gp_refcnt > 0) {
2140 if (gp->gp_egv == gv)
2147 /* Copy and null out all the glob slots, so destructors do not see
2149 HEK * const file_hek = gp->gp_file_hek;
2150 SV * const sv = gp->gp_sv;
2151 AV * const av = gp->gp_av;
2152 HV * const hv = gp->gp_hv;
2153 IO * const io = gp->gp_io;
2154 CV * const cv = gp->gp_cv;
2155 CV * const form = gp->gp_form;
2157 gp->gp_file_hek = NULL;
2166 unshare_hek(file_hek);
2170 /* FIXME - another reference loop GV -> symtab -> GV ?
2171 Somehow gp->gp_hv can end up pointing at freed garbage. */
2172 if (hv && SvTYPE(hv) == SVt_PVHV) {
2173 const HEK *hvname_hek = HvNAME_HEK(hv);
2174 if (PL_stashcache && hvname_hek)
2175 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2176 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2184 if (!gp->gp_file_hek
2190 && !gp->gp_form) break;
2192 if (--attempts == 0) {
2194 "panic: gp_free failed to free glob pointer - "
2195 "something is repeatedly re-creating entries"
2205 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2207 AMT * const amtp = (AMT*)mg->mg_ptr;
2208 PERL_UNUSED_ARG(sv);
2210 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2212 if (amtp && AMT_AMAGIC(amtp)) {
2214 for (i = 1; i < NofAMmeth; i++) {
2215 CV * const cv = amtp->table[i];
2217 SvREFCNT_dec(MUTABLE_SV(cv));
2218 amtp->table[i] = NULL;
2225 /* Updates and caches the CV's */
2227 * 1 on success and there is some overload
2228 * 0 if there is no overload
2229 * -1 if some error occurred and it couldn't croak
2233 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2236 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2238 const struct mro_meta* stash_meta = HvMROMETA(stash);
2241 PERL_ARGS_ASSERT_GV_AMUPDATE;
2243 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2245 const AMT * const amtp = (AMT*)mg->mg_ptr;
2246 if (amtp->was_ok_sub == newgen) {
2247 return AMT_OVERLOADED(amtp) ? 1 : 0;
2249 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2252 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2255 amt.was_ok_sub = newgen;
2256 amt.fallback = AMGfallNO;
2260 int filled = 0, have_ovl = 0;
2263 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2265 /* Try to find via inheritance. */
2266 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2267 SV * const sv = gv ? GvSV(gv) : NULL;
2272 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2273 lim = DESTROY_amg; /* Skip overloading entries. */
2275 #ifdef PERL_DONT_CREATE_GVSV
2277 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2280 else if (SvTRUE(sv))
2281 /* don't need to set overloading here because fallback => 1
2282 * is the default setting for classes without overloading */
2283 amt.fallback=AMGfallYES;
2284 else if (SvOK(sv)) {
2285 amt.fallback=AMGfallNEVER;
2294 for (i = 1; i < lim; i++)
2295 amt.table[i] = NULL;
2296 for (; i < NofAMmeth; i++) {
2297 const char * const cooky = PL_AMG_names[i];
2298 /* Human-readable form, for debugging: */
2299 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2300 const STRLEN l = PL_AMG_namelens[i];
2302 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2303 cp, HvNAME_get(stash)) );
2304 /* don't fill the cache while looking up!
2305 Creation of inheritance stubs in intermediate packages may
2306 conflict with the logic of runtime method substitution.
2307 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2308 then we could have created stubs for "(+0" in A and C too.
2309 But if B overloads "bool", we may want to use it for
2310 numifying instead of C's "+0". */
2311 if (i >= DESTROY_amg)
2312 gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2313 else /* Autoload taken care of below */
2314 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2316 if (gv && (cv = GvCV(gv))) {
2317 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2318 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2319 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2320 && strEQ(hvname, "overload")) {
2321 /* This is a hack to support autoloading..., while
2322 knowing *which* methods were declared as overloaded. */
2323 /* GvSV contains the name of the method. */
2325 SV *gvsv = GvSV(gv);
2327 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2328 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2329 (void*)GvSV(gv), cp, HvNAME(stash)) );
2330 if (!gvsv || !SvPOK(gvsv)
2331 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2333 /* Can be an import stub (created by "can"). */
2338 const SV * const name = (gvsv && SvPOK(gvsv))
2340 : newSVpvs_flags("???", SVs_TEMP);
2341 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2342 Perl_croak(aTHX_ "%s method \"%"SVf256
2343 "\" overloading \"%s\" "\
2344 "in package \"%"HEKf256"\"",
2345 (GvCVGEN(gv) ? "Stub found while resolving"
2353 cv = GvCV(gv = ngv);
2356 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2357 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2358 GvNAME(CvGV(cv))) );
2360 if (i < DESTROY_amg)
2362 } else if (gv) { /* Autoloaded... */
2363 cv = MUTABLE_CV(gv);
2366 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2369 AMT_AMAGIC_on(&amt);
2371 AMT_OVERLOADED_on(&amt);
2372 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2373 (char*)&amt, sizeof(AMT));
2377 /* Here we have no table: */
2379 AMT_AMAGIC_off(&amt);
2380 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2381 (char*)&amt, sizeof(AMTS));
2387 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2393 struct mro_meta* stash_meta;
2395 if (!stash || !HvNAME_get(stash))
2398 stash_meta = HvMROMETA(stash);
2399 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2401 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2404 /* If we're looking up a destructor to invoke, we must avoid
2405 * that Gv_AMupdate croaks, because we might be dying already */
2406 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2407 /* and if it didn't found a destructor, we fall back
2408 * to a simpler method that will only look for the
2409 * destructor instead of the whole magic */
2410 if (id == DESTROY_amg) {
2411 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2417 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2420 amtp = (AMT*)mg->mg_ptr;
2421 if ( amtp->was_ok_sub != newgen )
2423 if (AMT_AMAGIC(amtp)) {
2424 CV * const ret = amtp->table[id];
2425 if (ret && isGV(ret)) { /* Autoloading stab */
2426 /* Passing it through may have resulted in a warning
2427 "Inherited AUTOLOAD for a non-method deprecated", since
2428 our caller is going through a function call, not a method call.
2429 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2430 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2442 /* Implement tryAMAGICun_MG macro.
2443 Do get magic, then see if the stack arg is overloaded and if so call it.
2445 AMGf_set return the arg using SETs rather than assigning to
2447 AMGf_numeric apply sv_2num to the stack arg.
2451 Perl_try_amagic_un(pTHX_ int method, int flags) {
2455 SV* const arg = TOPs;
2459 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2460 AMGf_noright | AMGf_unary))) {
2461 if (flags & AMGf_set) {
2466 if (SvPADMY(TARG)) {
2467 sv_setsv(TARG, tmpsv);
2477 if ((flags & AMGf_numeric) && SvROK(arg))
2483 /* Implement tryAMAGICbin_MG macro.
2484 Do get magic, then see if the two stack args are overloaded and if so
2487 AMGf_set return the arg using SETs rather than assigning to
2489 AMGf_assign op may be called as mutator (eg +=)
2490 AMGf_numeric apply sv_2num to the stack arg.
2494 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2497 SV* const left = TOPm1s;
2498 SV* const right = TOPs;
2504 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2505 SV * const tmpsv = amagic_call(left, right, method,
2506 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2508 if (flags & AMGf_set) {
2515 if (opASSIGN || SvPADMY(TARG)) {
2516 sv_setsv(TARG, tmpsv);
2526 if(left==right && SvGMAGICAL(left)) {
2527 SV * const left = sv_newmortal();
2529 /* Print the uninitialized warning now, so it includes the vari-
2532 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2533 sv_setsv_flags(left, &PL_sv_no, 0);
2535 else sv_setsv_flags(left, right, 0);
2538 if (flags & AMGf_numeric) {
2540 *(sp-1) = sv_2num(TOPm1s);
2542 *sp = sv_2num(right);
2548 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2551 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2553 while (SvAMAGIC(ref) &&
2554 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2555 AMGf_noright | AMGf_unary))) {
2557 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2558 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2559 /* Bail out if it returns us the same reference. */
2564 return tmpsv ? tmpsv : ref;
2568 Perl_amagic_is_enabled(pTHX_ int method)
2570 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2572 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2574 if ( !lex_mask || !SvOK(lex_mask) )
2575 /* overloading lexically disabled */
2577 else if ( lex_mask && SvPOK(lex_mask) ) {
2578 /* we have an entry in the hints hash, check if method has been
2579 * masked by overloading.pm */
2581 const int offset = method / 8;
2582 const int bit = method % 8;
2583 char *pv = SvPV(lex_mask, len);
2585 /* Bit set, so this overloading operator is disabled */
2586 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2593 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2598 CV **cvp=NULL, **ocvp=NULL;
2599 AMT *amtp=NULL, *oamtp=NULL;
2600 int off = 0, off1, lr = 0, notfound = 0;
2601 int postpr = 0, force_cpy = 0;
2602 int assign = AMGf_assign & flags;
2603 const int assignshift = assign ? 1 : 0;
2604 int use_default_op = 0;
2605 int force_scalar = 0;
2611 PERL_ARGS_ASSERT_AMAGIC_CALL;
2613 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2614 if (!amagic_is_enabled(method)) return NULL;
2617 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2618 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2619 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2620 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2621 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2623 && ((cv = cvp[off=method+assignshift])
2624 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2630 cv = cvp[off=method])))) {
2631 lr = -1; /* Call method for left argument */
2633 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2636 /* look for substituted methods */
2637 /* In all the covered cases we should be called with assign==0. */
2641 if ((cv = cvp[off=add_ass_amg])
2642 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2643 right = &PL_sv_yes; lr = -1; assign = 1;
2648 if ((cv = cvp[off = subtr_ass_amg])
2649 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2650 right = &PL_sv_yes; lr = -1; assign = 1;
2654 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2657 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2660 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2663 (void)((cv = cvp[off=bool__amg])
2664 || (cv = cvp[off=numer_amg])
2665 || (cv = cvp[off=string_amg]));
2672 * SV* ref causes confusion with the interpreter variable of
2675 SV* const tmpRef=SvRV(left);
2676 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2678 * Just to be extra cautious. Maybe in some
2679 * additional cases sv_setsv is safe, too.
2681 SV* const newref = newSVsv(tmpRef);
2682 SvOBJECT_on(newref);
2683 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2684 delegate to the stash. */
2685 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2691 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2692 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2693 SV* const nullsv=sv_2mortal(newSViv(0));
2695 SV* const lessp = amagic_call(left,nullsv,
2696 lt_amg,AMGf_noright);
2697 logic = SvTRUE(lessp);
2699 SV* const lessp = amagic_call(left,nullsv,
2700 ncmp_amg,AMGf_noright);
2701 logic = (SvNV(lessp) < 0);
2704 if (off==subtr_amg) {
2715 if ((cv = cvp[off=subtr_amg])) {
2717 left = sv_2mortal(newSViv(0));
2722 case iter_amg: /* XXXX Eventually should do to_gv. */
2723 case ftest_amg: /* XXXX Eventually should do to_gv. */
2726 return NULL; /* Delegate operation to standard mechanisms. */
2734 return left; /* Delegate operation to standard mechanisms. */
2739 if (!cv) goto not_found;
2740 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2741 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2742 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2743 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2744 ? (amtp = (AMT*)mg->mg_ptr)->table
2746 && ((cv = cvp[off=method+assignshift])
2747 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2753 cv = cvp[off=method])))) { /* Method for right
2756 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2757 || (ocvp && oamtp->fallback > AMGfallNEVER))
2758 && !(flags & AMGf_unary)) {
2759 /* We look for substitution for
2760 * comparison operations and
2762 if (method==concat_amg || method==concat_ass_amg
2763 || method==repeat_amg || method==repeat_ass_amg) {
2764 return NULL; /* Delegate operation to string conversion */
2786 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2790 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2800 not_found: /* No method found, either report or croak */
2808 return left; /* Delegate operation to standard mechanisms. */
2811 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2812 notfound = 1; lr = -1;
2813 } else if (cvp && (cv=cvp[nomethod_amg])) {
2814 notfound = 1; lr = 1;
2815 } else if ((use_default_op =
2816 (!ocvp || oamtp->fallback >= AMGfallYES)
2817 && (!cvp || amtp->fallback >= AMGfallYES))
2819 /* Skip generating the "no method found" message. */
2823 if (off==-1) off=method;
2824 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2825 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2826 AMG_id2name(method + assignshift),
2827 (flags & AMGf_unary ? " " : "\n\tleft "),
2829 "in overloaded package ":
2830 "has no overloaded magic",
2832 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2835 ",\n\tright argument in overloaded package ":
2838 : ",\n\tright argument has no overloaded magic"),
2840 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2841 SVfARG(&PL_sv_no)));
2842 if (use_default_op) {
2843 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2845 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2849 force_cpy = force_cpy || assign;
2854 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2855 * operation. we need this to return a value, so that it can be assigned
2856 * later on, in the postpr block (case inc_amg/dec_amg), even if the
2857 * increment or decrement was itself called in void context */
2863 if (off == subtr_amg)
2866 /* in these cases, we're calling an assignment variant of an operator
2867 * (+= rather than +, for instance). regardless of whether it's a
2868 * fallback or not, it always has to return a value, which will be
2869 * assigned to the proper variable later */
2886 /* the copy constructor always needs to return a value */
2890 /* because of the way these are implemented (they don't perform the
2891 * dereferencing themselves, they return a reference that perl then
2892 * dereferences later), they always have to be in scalar context */
2900 /* these don't have an op of their own; they're triggered by their parent
2901 * op, so the context there isn't meaningful ('$a and foo()' in void
2902 * context still needs to pass scalar context on to $a's bool overload) */
2912 DEBUG_o(Perl_deb(aTHX_
2913 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2915 method+assignshift==off? "" :
2917 method+assignshift==off? "" :
2918 AMG_id2name(method+assignshift),
2919 method+assignshift==off? "" : "\")",
2920 flags & AMGf_unary? "" :
2921 lr==1 ? " for right argument": " for left argument",
2922 flags & AMGf_unary? " for argument" : "",
2923 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2924 fl? ",\n\tassignment variant used": "") );
2927 /* Since we use shallow copy during assignment, we need
2928 * to dublicate the contents, probably calling user-supplied
2929 * version of copy operator
2931 /* We need to copy in following cases:
2932 * a) Assignment form was called.
2933 * assignshift==1, assign==T, method + 1 == off
2934 * b) Increment or decrement, called directly.
2935 * assignshift==0, assign==0, method + 0 == off
2936 * c) Increment or decrement, translated to assignment add/subtr.
2937 * assignshift==0, assign==T,
2939 * d) Increment or decrement, translated to nomethod.
2940 * assignshift==0, assign==0,
2942 * e) Assignment form translated to nomethod.
2943 * assignshift==1, assign==T, method + 1 != off
2946 /* off is method, method+assignshift, or a result of opcode substitution.
2947 * In the latter case assignshift==0, so only notfound case is important.
2949 if ( (lr == -1) && ( ( (method + assignshift == off)
2950 && (assign || (method == inc_amg) || (method == dec_amg)))
2953 /* newSVsv does not behave as advertised, so we copy missing
2954 * information by hand */
2955 SV *tmpRef = SvRV(left);
2957 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2958 SvRV_set(left, rv_copy);
2960 SvREFCNT_dec(tmpRef);
2968 const bool oldcatch = CATCH_GET;
2970 int gimme = force_scalar ? G_SCALAR : GIMME_V;
2973 Zero(&myop, 1, BINOP);
2974 myop.op_last = (OP *) &myop;
2975 myop.op_next = NULL;
2976 myop.op_flags = OPf_STACKED;
2980 myop.op_flags |= OPf_WANT_VOID;
2983 if (flags & AMGf_want_list) {
2984 myop.op_flags |= OPf_WANT_LIST;
2989 myop.op_flags |= OPf_WANT_SCALAR;
2993 PUSHSTACKi(PERLSI_OVERLOAD);
2996 PL_op = (OP *) &myop;
2997 if (PERLDB_SUB && PL_curstash != PL_debstash)
2998 PL_op->op_private |= OPpENTERSUB_DB;
3000 Perl_pp_pushmark(aTHX);
3002 EXTEND(SP, notfound + 5);
3003 PUSHs(lr>0? right: left);
3004 PUSHs(lr>0? left: right);
3005 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3007 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3008 AMG_id2namelen(method + assignshift), SVs_TEMP));
3010 PUSHs(MUTABLE_SV(cv));
3014 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3018 nret = SP - (PL_stack_base + oldmark);
3022 /* returning NULL has another meaning, and we check the context
3023 * at the call site too, so this can be differentiated from the
3026 SP = PL_stack_base + oldmark;
3029 if (flags & AMGf_want_list) {
3030 res = sv_2mortal((SV *)newAV());
3031 av_extend((AV *)res, nret);
3033 av_store((AV *)res, nret, POPs);
3045 CATCH_SET(oldcatch);
3052 ans=SvIV(res)<=0; break;
3055 ans=SvIV(res)<0; break;
3058 ans=SvIV(res)>=0; break;
3061 ans=SvIV(res)>0; break;
3064 ans=SvIV(res)==0; break;
3067 ans=SvIV(res)!=0; break;
3070 SvSetSV(left,res); return left;
3072 ans=!SvTRUE(res); break;
3077 } else if (method==copy_amg) {
3079 Perl_croak(aTHX_ "Copy method did not return a reference");
3081 return SvREFCNT_inc(SvRV(res));
3089 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3094 PERL_ARGS_ASSERT_GV_NAME_SET;
3097 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3099 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3100 unshare_hek(GvNAME_HEK(gv));
3103 PERL_HASH(hash, name, len);
3104 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3108 =for apidoc gv_try_downgrade
3110 If the typeglob C<gv> can be expressed more succinctly, by having
3111 something other than a real GV in its place in the stash, replace it
3112 with the optimised form. Basic requirements for this are that C<gv>
3113 is a real typeglob, is sufficiently ordinary, and is only referenced
3114 from its package. This function is meant to be used when a GV has been
3115 looked up in part to see what was there, causing upgrading, but based
3116 on what was found it turns out that the real GV isn't required after all.
3118 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3120 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3121 sub, the typeglob is replaced with a scalar-reference placeholder that
3122 more compactly represents the same thing.
3128 Perl_gv_try_downgrade(pTHX_ GV *gv)
3134 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3136 /* XXX Why and where does this leave dangling pointers during global
3138 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3140 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3141 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3142 isGV_with_GP(gv) && GvGP(gv) &&
3143 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3144 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3145 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3147 if (SvMAGICAL(gv)) {
3149 /* only backref magic is allowed */
3150 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3152 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3153 if (mg->mg_type != PERL_MAGIC_backref)
3159 HEK *gvnhek = GvNAME_HEK(gv);
3160 (void)hv_delete(stash, HEK_KEY(gvnhek),
3161 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3162 } else if (GvMULTI(gv) && cv &&
3163 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3164 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3165 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3166 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3167 (namehek = GvNAME_HEK(gv)) &&
3168 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3169 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3171 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3175 SvFLAGS(gv) = SVt_IV|SVf_ROK;
3176 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3177 STRUCT_OFFSET(XPVIV, xiv_iv));
3178 SvRV_set(gv, value);
3185 core_xsub(pTHX_ CV* cv)
3188 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3194 * c-indentation-style: bsd
3196 * indent-tabs-mode: nil
3199 * ex: set ts=8 sts=4 sw=4 et: