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) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
161 Perl_newGP(pTHX_ GV *const gv)
172 PERL_ARGS_ASSERT_NEWGP;
174 gp->gp_egv = gv; /* allow compiler to reuse gv after this */
175 #ifndef PERL_DONT_CREATE_GVSV
176 gp->gp_sv = newSV(0);
179 /* PL_curcop should never be null here. */
181 /* But for non-debugging builds play it safe */
183 gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
185 if (CopFILE(PL_curcop)) {
186 file = CopFILE(PL_curcop);
190 filegv = CopFILEGV(PL_curcop);
192 file = GvNAME(filegv)+2;
193 len = GvNAMELEN(filegv)-2;
204 PERL_HASH(hash, file, len);
205 gp->gp_file_hek = share_hek(file, len, hash);
211 /* Assign CvGV(cv) = gv, handling weak references.
212 * See also S_anonymise_cv_maybe */
215 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
217 GV * const oldgv = CvGV(cv);
219 PERL_ARGS_ASSERT_CVGV_SET;
226 SvREFCNT_dec_NN(oldgv);
230 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
233 else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
235 SvANY(cv)->xcv_gv_u.xcv_gv = gv;
236 assert(!CvCVGV_RC(cv));
241 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
242 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
245 SvREFCNT_inc_simple_void_NN(gv);
249 /* Assign CvSTASH(cv) = st, handling weak references. */
252 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
254 HV *oldst = CvSTASH(cv);
255 PERL_ARGS_ASSERT_CVSTASH_SET;
259 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
260 SvANY(cv)->xcv_stash = st;
262 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
266 =for apidoc gv_init_pvn
268 Converts a scalar into a typeglob. This is an incoercible typeglob;
269 assigning a reference to it will assign to one of its slots, instead of
270 overwriting it as happens with typeglobs created by SvSetSV. Converting
271 any scalar that is SvOK() may produce unpredictable results and is reserved
272 for perl's internal use.
274 C<gv> is the scalar to be converted.
276 C<stash> is the parent stash/package, if any.
278 C<name> and C<len> give the name. The name must be unqualified;
279 that is, it must not include the package name. If C<gv> is a
280 stash element, it is the caller's responsibility to ensure that the name
281 passed to this function matches the name of the element. If it does not
282 match, perl's internal bookkeeping will get out of sync.
284 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
285 the return value of SvUTF8(sv). It can also take the
286 GV_ADDMULTI flag, which means to pretend that the GV has been
287 seen before (i.e., suppress "Used once" warnings).
291 The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
292 has no flags parameter. If the C<multi> parameter is set, the
293 GV_ADDMULTI flag will be passed to gv_init_pvn().
295 =for apidoc gv_init_pv
297 Same as gv_init_pvn(), but takes a nul-terminated string for the name
298 instead of separate char * and length parameters.
300 =for apidoc gv_init_sv
302 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
303 char * and length parameters. C<flags> is currently unused.
309 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
313 PERL_ARGS_ASSERT_GV_INIT_SV;
314 namepv = SvPV(namesv, namelen);
317 gv_init_pvn(gv, stash, namepv, namelen, flags);
321 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
323 PERL_ARGS_ASSERT_GV_INIT_PV;
324 gv_init_pvn(gv, stash, name, strlen(name), flags);
328 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
331 const U32 old_type = SvTYPE(gv);
332 const bool doproto = old_type > SVt_NULL;
333 char * const proto = (doproto && SvPOK(gv))
334 ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
336 const STRLEN protolen = proto ? SvCUR(gv) : 0;
337 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
338 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
339 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
341 PERL_ARGS_ASSERT_GV_INIT_PVN;
342 assert (!(proto && has_constant));
345 /* The constant has to be a simple scalar type. */
346 switch (SvTYPE(has_constant)) {
351 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
352 sv_reftype(has_constant, 0));
360 if (old_type < SVt_PVGV) {
361 if (old_type >= SVt_PV)
363 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
371 Safefree(SvPVX_mutable(gv));
376 GvGP_set(gv, Perl_newGP(aTHX_ gv));
379 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
380 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
381 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
382 GvMULTI_on(gv); /* _was_ mentioned */
386 /* newCONSTSUB takes ownership of the reference from us. */
387 cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
388 /* In case op.c:S_process_special_blocks stole it: */
390 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
391 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
392 /* If this reference was a copy of another, then the subroutine
393 must have been "imported", by a Perl space assignment to a GV
394 from a reference to CV. */
395 if (exported_constant)
396 GvIMPORTED_CV_on(gv);
397 CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */
402 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
403 SV_HAS_TRAILING_NUL);
404 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
410 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
412 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
424 #ifdef PERL_DONT_CREATE_GVSV
432 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
433 If we just cast GvSVn(gv) to void, it ignores evaluating it for
440 static void core_xsub(pTHX_ CV* cv);
443 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
444 const char * const name, const STRLEN len)
446 const int code = keyword(name, len, 1);
447 static const char file[] = __FILE__;
448 CV *cv, *oldcompcv = NULL;
450 bool ampable = TRUE; /* &{}-able */
451 COP *oldcurcop = NULL;
452 yy_parser *oldparser = NULL;
453 I32 oldsavestack_ix = 0;
458 if (!code) return NULL; /* Not a keyword */
459 switch (code < 0 ? -code : code) {
460 /* no support for \&CORE::infix;
461 no support for funcs that do not parse like funcs */
462 case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
463 case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
464 case KEY_default : case KEY_DESTROY:
465 case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
466 case KEY_END : case KEY_eq : case KEY_eval :
467 case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
468 case KEY_given : case KEY_goto : case KEY_grep :
469 case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
470 case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
471 case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
472 case KEY_package: case KEY_print: case KEY_printf:
473 case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
474 case KEY_qx : case KEY_redo : case KEY_require: case KEY_return:
475 case KEY_s : case KEY_say : case KEY_sort :
476 case KEY_state: case KEY_sub :
477 case KEY_tr : case KEY_UNITCHECK: case KEY_unless:
478 case KEY_until: case KEY_use : case KEY_when : case KEY_while :
479 case KEY_x : case KEY_xor : case KEY_y :
482 case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete:
483 case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists:
489 case KEY_splice: case KEY_split:
492 case KEY_truncate: case KEY_unlink:
499 gv_init(gv, stash, name, len, TRUE);
504 oldcurcop = PL_curcop;
505 oldparser = PL_parser;
506 lex_start(NULL, NULL, 0);
507 oldcompcv = PL_compcv;
508 PL_compcv = NULL; /* Prevent start_subparse from setting
510 oldsavestack_ix = start_subparse(FALSE,0);
514 /* Avoid calling newXS, as it calls us, and things start to
516 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
519 mro_method_changed_in(GvSTASH(gv));
521 CvXSUB(cv) = core_xsub;
523 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
525 (void)gv_fetchfile(file);
526 CvFILE(cv) = (char *)file;
527 /* XXX This is inefficient, as doing things this order causes
528 a prototype check in newATTRSUB. But we have to do
529 it this order as we need an op number before calling
531 (void)core_prototype((SV *)cv, name, code, &opnum);
533 (void)hv_store(stash,name,len,(SV *)gv,0);
539 /* newATTRSUB will free the CV and return NULL if we're still
540 compiling after a syntax error */
541 if ((cv = newATTRSUB_flags(
542 oldsavestack_ix, (OP *)gv,
547 : newSVpvn(name,len),
552 assert(GvCV(gv) == orig_cv);
553 if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
554 && opnum != OP_UNDEF)
555 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
558 PL_parser = oldparser;
559 PL_curcop = oldcurcop;
560 PL_compcv = oldcompcv;
563 SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
565 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
567 SvREFCNT_dec(opnumsv);
574 =for apidoc gv_fetchmeth
576 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
578 =for apidoc gv_fetchmeth_sv
580 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
581 of an SV instead of a string/length pair.
587 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
591 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
592 namepv = SvPV(namesv, namelen);
595 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
599 =for apidoc gv_fetchmeth_pv
601 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
602 instead of a string/length pair.
608 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
610 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
611 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
615 =for apidoc gv_fetchmeth_pvn
617 Returns the glob with the given C<name> and a defined subroutine or
618 C<NULL>. The glob lives in the given C<stash>, or in the stashes
619 accessible via @ISA and UNIVERSAL::.
621 The argument C<level> should be either 0 or -1. If C<level==0>, as a
622 side-effect creates a glob with the given C<name> in the given C<stash>
623 which in the case of success contains an alias for the subroutine, and sets
624 up caching info for this glob.
626 The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
628 GV_SUPER indicates that we want to look up the method in the superclasses
632 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
633 visible to Perl code. So when calling C<call_sv>, you should not use
634 the GV directly; instead, you should use the method's CV, which can be
635 obtained from the GV with the C<GvCV> macro.
640 /* NOTE: No support for tied ISA */
643 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
650 HV* cstash, *cachestash;
651 GV* candidate = NULL;
655 I32 create = (level >= 0) ? 1 : 0;
658 U32 is_utf8 = flags & SVf_UTF8;
660 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
662 /* UNIVERSAL methods should be callable without a stash */
664 create = 0; /* probably appropriate */
665 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
671 hvname = HvNAME_get(stash);
673 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
678 DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
679 flags & GV_SUPER ? "SUPER " : "",name,hvname) );
681 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
683 if (flags & GV_SUPER) {
684 if (!HvAUX(stash)->xhv_mro_meta->super)
685 HvAUX(stash)->xhv_mro_meta->super = newHV();
686 cachestash = HvAUX(stash)->xhv_mro_meta->super;
688 else cachestash = stash;
690 /* check locally for a real method or a cache entry */
691 gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
697 if (SvTYPE(topgv) != SVt_PVGV)
698 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
699 if ((cand_cv = GvCV(topgv))) {
700 /* If genuine method or valid cache entry, use it */
701 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
705 /* stale cache entry, junk it and move on */
706 SvREFCNT_dec_NN(cand_cv);
707 GvCV_set(topgv, NULL);
712 else if (GvCVGEN(topgv) == topgen_cmp) {
713 /* cache indicates no such method definitively */
716 else if (stash == cachestash
717 && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
718 && strnEQ(hvname, "CORE", 4)
719 && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
723 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
724 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
725 items = AvFILLp(linear_av); /* no +1, to skip over self */
727 linear_sv = *linear_svp++;
729 cstash = gv_stashsv(linear_sv, 0);
732 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
733 "Can't locate package %"SVf" for @%"HEKf"::ISA",
735 HEKfARG(HvNAME_HEK(stash)));
741 gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
743 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
744 const char *hvname = HvNAME(cstash); assert(hvname);
745 if (strnEQ(hvname, "CORE", 4)
747 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
753 else candidate = *gvp;
756 if (SvTYPE(candidate) != SVt_PVGV)
757 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
758 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
760 * Found real method, cache method in topgv if:
761 * 1. topgv has no synonyms (else inheritance crosses wires)
762 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
764 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
765 CV *old_cv = GvCV(topgv);
766 SvREFCNT_dec(old_cv);
767 SvREFCNT_inc_simple_void_NN(cand_cv);
768 GvCV_set(topgv, cand_cv);
769 GvCVGEN(topgv) = topgen_cmp;
775 /* Check UNIVERSAL without caching */
776 if(level == 0 || level == -1) {
777 candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
779 cand_cv = GvCV(candidate);
780 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
781 CV *old_cv = GvCV(topgv);
782 SvREFCNT_dec(old_cv);
783 SvREFCNT_inc_simple_void_NN(cand_cv);
784 GvCV_set(topgv, cand_cv);
785 GvCVGEN(topgv) = topgen_cmp;
791 if (topgv && GvREFCNT(topgv) == 1) {
792 /* cache the fact that the method is not defined */
793 GvCVGEN(topgv) = topgen_cmp;
800 =for apidoc gv_fetchmeth_autoload
802 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
805 =for apidoc gv_fetchmeth_sv_autoload
807 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
808 of an SV instead of a string/length pair.
814 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
818 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
819 namepv = SvPV(namesv, namelen);
822 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
826 =for apidoc gv_fetchmeth_pv_autoload
828 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
829 instead of a string/length pair.
835 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
837 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
838 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
842 =for apidoc gv_fetchmeth_pvn_autoload
844 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
845 Returns a glob for the subroutine.
847 For an autoloaded subroutine without a GV, will create a GV even
848 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
849 of the result may be zero.
851 Currently, the only significant value for C<flags> is SVf_UTF8.
857 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
859 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
861 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
868 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
869 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
871 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
874 if (!(CvROOT(cv) || CvXSUB(cv)))
876 /* Have an autoload */
877 if (level < 0) /* Cannot do without a stub */
878 gv_fetchmeth_pvn(stash, name, len, 0, flags);
879 gvp = (GV**)hv_fetch(stash, name,
880 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
889 =for apidoc gv_fetchmethod_autoload
891 Returns the glob which contains the subroutine to call to invoke the method
892 on the C<stash>. In fact in the presence of autoloading this may be the
893 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
896 The third parameter of C<gv_fetchmethod_autoload> determines whether
897 AUTOLOAD lookup is performed if the given method is not present: non-zero
898 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
899 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
900 with a non-zero C<autoload> parameter.
902 These functions grant C<"SUPER"> token as a prefix of the method name. Note
903 that if you want to keep the returned glob for a long time, you need to
904 check for it being "AUTOLOAD", since at the later time the call may load a
905 different subroutine due to $AUTOLOAD changing its value. Use the glob
906 created via a side effect to do this.
908 These functions have the same side-effects and as C<gv_fetchmeth> with
909 C<level==0>. C<name> should be writable if contains C<':'> or C<'
910 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
911 C<call_sv> apply equally to these functions.
917 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
919 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
921 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
925 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
929 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
930 namepv = SvPV(namesv, namelen);
933 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
937 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
939 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
940 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
943 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
946 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
950 const char *nsplit = NULL;
953 const char * const origname = name;
954 SV *const error_report = MUTABLE_SV(stash);
955 const U32 autoload = flags & GV_AUTOLOAD;
956 const U32 do_croak = flags & GV_CROAK;
957 const U32 is_utf8 = flags & SVf_UTF8;
959 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
961 if (SvTYPE(stash) < SVt_PVHV)
964 /* The only way stash can become NULL later on is if nsplit is set,
965 which in turn means that there is no need for a SVt_PVHV case
966 the error reporting code. */
969 for (nend = name; *nend || nend != (origname + len); nend++) {
974 else if (*nend == ':' && *(nend + 1) == ':') {
980 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
981 /* ->SUPER::method should really be looked up in original stash */
982 stash = CopSTASH(PL_curcop);
984 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
985 origname, HvENAME_get(stash), name) );
987 else if ((nsplit - origname) >= 7 &&
988 strnEQ(nsplit - 7, "::SUPER", 7)) {
989 /* don't autovifify if ->NoSuchStash::SUPER::method */
990 stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
991 if (stash) flags |= GV_SUPER;
994 /* don't autovifify if ->NoSuchStash::method */
995 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1000 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1002 if (strEQ(name,"import") || strEQ(name,"unimport"))
1003 gv = MUTABLE_GV(&PL_sv_yes);
1005 gv = gv_autoload_pvn(
1006 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1008 if (!gv && do_croak) {
1009 /* Right now this is exclusively for the benefit of S_method_common
1012 /* If we can't find an IO::File method, it might be a call on
1013 * a filehandle. If IO:File has not been loaded, try to
1014 * require it first instead of croaking */
1015 const char *stash_name = HvNAME_get(stash);
1016 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1017 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1018 STR_WITH_LEN("IO/File.pm"), 0,
1019 HV_FETCH_ISEXISTS, NULL, 0)
1021 require_pv("IO/File.pm");
1022 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1027 "Can't locate object method \"%"UTF8f
1028 "\" via package \"%"HEKf"\"",
1029 UTF8fARG(is_utf8, nend - name, name),
1030 HEKfARG(HvNAME_HEK(stash)));
1036 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1037 SVs_TEMP | is_utf8);
1039 packnamesv = error_report;
1043 "Can't locate object method \"%"UTF8f
1044 "\" via package \"%"SVf"\""
1045 " (perhaps you forgot to load \"%"SVf"\"?)",
1046 UTF8fARG(is_utf8, nend - name, name),
1047 SVfARG(packnamesv), SVfARG(packnamesv));
1051 else if (autoload) {
1052 CV* const cv = GvCV(gv);
1053 if (!CvROOT(cv) && !CvXSUB(cv)) {
1061 if (GvCV(stubgv) != cv) /* orphaned import */
1064 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1065 GvNAME(stubgv), GvNAMELEN(stubgv),
1066 GV_AUTOLOAD_ISMETHOD
1067 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1077 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1081 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1082 namepv = SvPV(namesv, namelen);
1085 return gv_autoload_pvn(stash, namepv, namelen, flags);
1089 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1091 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1092 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1096 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1104 SV *packname = NULL;
1105 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1107 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1109 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1112 if (SvTYPE(stash) < SVt_PVHV) {
1113 STRLEN packname_len = 0;
1114 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1115 packname = newSVpvn_flags(packname_ptr, packname_len,
1116 SVs_TEMP | SvUTF8(stash));
1120 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1121 if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
1123 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1127 if (!(CvROOT(cv) || CvXSUB(cv)))
1131 * Inheriting AUTOLOAD for non-methods works ... for now.
1134 !(flags & GV_AUTOLOAD_ISMETHOD)
1135 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1137 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1138 "Use of inherited AUTOLOAD for non-method %"SVf
1139 "::%"UTF8f"() is deprecated",
1141 UTF8fARG(is_utf8, len, name));
1144 /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
1145 * and split that value on the last '::', pass along the same data
1146 * via the SvPVX field in the CV, and the stash in CvSTASH.
1148 * Due to an unfortunate accident of history, the SvPVX field
1149 * serves two purposes. It is also used for the subroutine's pro-
1150 * type. Since SvPVX has been documented as returning the sub name
1151 * for a long time, but not as returning the prototype, we have
1152 * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
1155 * We put the prototype in the same allocated buffer, but after
1156 * the sub name. The SvPOK flag indicates the presence of a proto-
1157 * type. The CvAUTOLOAD flag indicates the presence of a sub name.
1158 * If both flags are on, then SvLEN is used to indicate the end of
1159 * the prototype (artificially lower than what is actually allo-
1160 * cated), at the risk of having to reallocate a few bytes unneces-
1161 * sarily--but that should happen very rarely, if ever.
1163 * We use SvUTF8 for both prototypes and sub names, so if one is
1164 * UTF8, the other must be upgraded.
1166 CvSTASH_set(cv, stash);
1167 if (SvPOK(cv)) { /* Ouch! */
1168 SV * const tmpsv = newSVpvn_flags(name, len, is_utf8);
1170 const char *proto = CvPROTO(cv);
1173 sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
1174 ulen = SvCUR(tmpsv);
1175 SvCUR(tmpsv)++; /* include null in string */
1177 tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
1179 SvTEMP_on(tmpsv); /* Allow theft */
1180 sv_setsv_nomg((SV *)cv, tmpsv);
1182 SvREFCNT_dec_NN(tmpsv);
1183 SvLEN(cv) = SvCUR(cv) + 1;
1187 sv_setpvn((SV *)cv, name, len);
1191 else SvUTF8_off(cv);
1197 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1198 * The subroutine's original name may not be "AUTOLOAD", so we don't
1199 * use that, but for lack of anything better we will use the sub's
1200 * original package to look up $AUTOLOAD.
1202 varstash = GvSTASH(CvGV(cv));
1203 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1207 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1208 #ifdef PERL_DONT_CREATE_GVSV
1209 GvSV(vargv) = newSV(0);
1213 varsv = GvSVn(vargv);
1214 SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
1215 /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
1216 sv_setsv(varsv, packname);
1217 sv_catpvs(varsv, "::");
1218 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1219 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1222 SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
1230 /* require_tie_mod() internal routine for requiring a module
1231 * that implements the logic of automatic ties like %! and %-
1233 * The "gv" parameter should be the glob.
1234 * "varpv" holds the name of the var, used for error messages.
1235 * "namesv" holds the module name. Its refcount will be decremented.
1236 * "methpv" holds the method name to test for to check that things
1237 * are working reasonably close to as expected.
1238 * "flags": if flag & 1 then save the scalar before loading.
1239 * For the protection of $! to work (it is set by this routine)
1240 * the sv slot must already be magicalized.
1243 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1246 HV* stash = gv_stashsv(namesv, 0);
1248 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1250 if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
1251 SV *module = newSVsv(namesv);
1252 char varname = *varpv; /* varpv might be clobbered by load_module,
1253 so save it. For the moment it's always
1255 const char type = varname == '[' ? '$' : '%';
1261 PUSHSTACKi(PERLSI_MAGIC);
1262 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1264 stash = gv_stashsv(namesv, 0);
1266 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
1267 type, varname, SVfARG(namesv));
1268 else if (!gv_fetchmethod(stash, methpv))
1269 Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
1270 type, varname, SVfARG(namesv), methpv);
1273 else SvREFCNT_dec_NN(namesv);
1278 =for apidoc gv_stashpv
1280 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1281 determine the length of C<name>, then calls C<gv_stashpvn()>.
1287 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1289 PERL_ARGS_ASSERT_GV_STASHPV;
1290 return gv_stashpvn(name, strlen(name), create);
1294 =for apidoc gv_stashpvn
1296 Returns a pointer to the stash for a specified package. The C<namelen>
1297 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1298 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1299 created if it does not already exist. If the package does not exist and
1300 C<flags> is 0 (or any other setting that does not create packages) then NULL
1303 Flags may be one of:
1312 The most important of which are probably GV_ADD and SVf_UTF8.
1318 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1324 U32 tmplen = namelen + 2;
1326 PERL_ARGS_ASSERT_GV_STASHPVN;
1328 if (tmplen <= sizeof smallbuf)
1331 Newx(tmpbuf, tmplen, char);
1332 Copy(name, tmpbuf, namelen, char);
1333 tmpbuf[namelen] = ':';
1334 tmpbuf[namelen+1] = ':';
1335 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1336 if (tmpbuf != smallbuf)
1340 stash = GvHV(tmpgv);
1341 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1343 if (!HvNAME_get(stash)) {
1344 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1346 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1347 /* If the containing stash has multiple effective
1348 names, see that this one gets them, too. */
1349 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1350 mro_package_moved(stash, NULL, tmpgv, 1);
1356 =for apidoc gv_stashsv
1358 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
1364 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1367 const char * const ptr = SvPV_const(sv,len);
1369 PERL_ARGS_ASSERT_GV_STASHSV;
1371 return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1376 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1377 PERL_ARGS_ASSERT_GV_FETCHPV;
1378 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1382 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1384 const char * const nambeg =
1385 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1386 PERL_ARGS_ASSERT_GV_FETCHSV;
1387 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1391 S_gv_magicalize_isa(pTHX_ GV *gv)
1395 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1399 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1404 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1405 const svtype sv_type)
1408 const char *name = nambeg;
1412 const char *name_cursor;
1414 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1415 const I32 no_expand = flags & GV_NOEXPAND;
1416 const I32 add = flags & ~GV_NOADD_MASK;
1417 const U32 is_utf8 = flags & SVf_UTF8;
1418 bool addmg = !!(flags & GV_ADDMG);
1419 const char *const name_end = nambeg + full_len;
1420 const char *const name_em1 = name_end - 1;
1423 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1425 if (flags & GV_NOTQUAL) {
1426 /* Caller promised that there is no stash, so we can skip the check. */
1431 if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1432 /* accidental stringify on a GV? */
1436 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1437 if (name_cursor < name_em1 &&
1438 ((*name_cursor == ':'
1439 && name_cursor[1] == ':')
1440 || *name_cursor == '\''))
1443 stash = PL_defstash;
1444 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1447 len = name_cursor - name;
1448 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1450 if (*name_cursor == ':') {
1455 Newx(tmpbuf, len+2, char);
1456 Copy(name, tmpbuf, len, char);
1457 tmpbuf[len++] = ':';
1458 tmpbuf[len++] = ':';
1461 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1462 gv = gvp ? *gvp : NULL;
1463 if (gv && gv != (const GV *)&PL_sv_undef) {
1464 if (SvTYPE(gv) != SVt_PVGV)
1465 gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1471 if (!gv || gv == (const GV *)&PL_sv_undef)
1474 if (!(stash = GvHV(gv)))
1476 stash = GvHV(gv) = newHV();
1477 if (!HvNAME_get(stash)) {
1478 if (GvSTASH(gv) == PL_defstash && len == 6
1479 && strnEQ(name, "CORE", 4))
1480 hv_name_set(stash, "CORE", 4, 0);
1483 stash, nambeg, name_cursor-nambeg, is_utf8
1485 /* If the containing stash has multiple effective
1486 names, see that this one gets them, too. */
1487 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1488 mro_package_moved(stash, NULL, gv, 1);
1491 else if (!HvNAME_get(stash))
1492 hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1495 if (*name_cursor == ':')
1497 name = name_cursor+1;
1498 if (name == name_end)
1500 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1503 len = name_cursor - name;
1505 /* No stash in name, so see how we can default */
1509 if (len && isIDFIRST_lazy_if(name, is_utf8)) {
1510 bool global = FALSE;
1518 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1519 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1520 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1524 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1529 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1530 && name[3] == 'I' && name[4] == 'N')
1534 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1535 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1536 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1540 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1541 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1548 stash = PL_defstash;
1549 else if (IN_PERL_COMPILETIME) {
1550 stash = PL_curstash;
1551 if (add && (PL_hints & HINT_STRICT_VARS) &&
1552 sv_type != SVt_PVCV &&
1553 sv_type != SVt_PVGV &&
1554 sv_type != SVt_PVFM &&
1555 sv_type != SVt_PVIO &&
1556 !(len == 1 && sv_type == SVt_PV &&
1557 (*name == 'a' || *name == 'b')) )
1559 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1561 *gvp == (const GV *)&PL_sv_undef ||
1562 SvTYPE(*gvp) != SVt_PVGV)
1566 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1567 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1568 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1570 /* diag_listed_as: Variable "%s" is not imported%s */
1572 aTHX_ packWARN(WARN_MISC),
1573 "Variable \"%c%"UTF8f"\" is not imported",
1574 sv_type == SVt_PVAV ? '@' :
1575 sv_type == SVt_PVHV ? '%' : '$',
1576 UTF8fARG(is_utf8, len, name));
1579 aTHX_ packWARN(WARN_MISC),
1580 "\t(Did you mean &%"UTF8f" instead?)\n",
1581 UTF8fARG(is_utf8, len, name)
1588 stash = CopSTASH(PL_curcop);
1591 stash = PL_defstash;
1594 /* By this point we should have a stash and a name */
1597 if (add && !PL_in_clean_all) {
1598 SV * const err = Perl_mess(aTHX_
1599 "Global symbol \"%s%"UTF8f
1600 "\" requires explicit package name",
1601 (sv_type == SVt_PV ? "$"
1602 : sv_type == SVt_PVAV ? "@"
1603 : sv_type == SVt_PVHV ? "%"
1604 : ""), UTF8fARG(is_utf8, len, name));
1609 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1611 /* symbol table under destruction */
1620 if (!SvREFCNT(stash)) /* symbol table under destruction */
1623 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1624 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1625 if (addmg) gv = (GV *)newSV(0);
1628 else gv = *gvp, addmg = 0;
1629 /* From this point on, addmg means gv has not been inserted in the
1632 if (SvTYPE(gv) == SVt_PVGV) {
1635 gv_init_svtype(gv, sv_type);
1636 /* You reach this path once the typeglob has already been created,
1637 either by the same or a different sigil. If this path didn't
1638 exist, then (say) referencing $! first, and %! second would
1639 mean that %! was not handled correctly. */
1640 if (len == 1 && stash == PL_defstash) {
1641 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
1643 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1644 else if (*name == '-' || *name == '+')
1645 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1646 } else if (sv_type == SVt_PV) {
1647 if (*name == '*' || *name == '#') {
1648 /* diag_listed_as: $* is no longer supported */
1649 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
1651 "$%c is no longer supported", *name);
1654 if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
1657 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1659 #ifdef PERL_SAWAMPERSAND
1661 PL_sawampersand |= SAWAMPERSAND_LEFT;
1665 PL_sawampersand |= SAWAMPERSAND_MIDDLE;
1669 PL_sawampersand |= SAWAMPERSAND_RIGHT;
1676 else if (len == 3 && sv_type == SVt_PVAV
1677 && strnEQ(name, "ISA", 3)
1678 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1679 gv_magicalize_isa(gv);
1682 } else if (no_init) {
1685 } else if (no_expand && SvROK(gv)) {
1690 /* Adding a new symbol.
1691 Unless of course there was already something non-GV here, in which case
1692 we want to behave as if there was always a GV here, containing some sort
1694 Otherwise we run the risk of creating things like GvIO, which can cause
1695 subtle bugs. eg the one that tripped up SQL::Translator */
1697 faking_it = SvOK(gv);
1699 if (add & GV_ADDWARN)
1700 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1701 "Had to create %"UTF8f" unexpectedly",
1702 UTF8fARG(is_utf8, name_end-nambeg, nambeg));
1703 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1705 if ( isIDFIRST_lazy_if(name, is_utf8)
1706 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1709 /* set up magic where warranted */
1710 if (stash != PL_defstash) { /* not the main stash */
1711 /* We only have to check for three names here: EXPORT, ISA
1712 and VERSION. All the others apply only to the main stash or to
1713 CORE (which is checked right after this). */
1715 const char * const name2 = name + 1;
1718 if (strnEQ(name2, "XPORT", 5))
1722 if (strEQ(name2, "SA"))
1723 gv_magicalize_isa(gv);
1726 if (strEQ(name2, "ERSION"))
1732 goto add_magical_gv;
1735 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1736 /* Avoid null warning: */
1737 const char * const stashname = HvNAME(stash); assert(stashname);
1738 if (strnEQ(stashname, "CORE", 4))
1739 S_maybe_add_coresub(aTHX_ 0, gv, name, len);
1746 /* Nothing else to do.
1747 The compiler will probably turn the switch statement into a
1748 branch table. Make sure we avoid even that small overhead for
1749 the common case of lower case variable names. */
1753 const char * const name2 = name + 1;
1756 if (strEQ(name2, "RGV")) {
1757 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1759 else if (strEQ(name2, "RGVOUT")) {
1764 if (strnEQ(name2, "XPORT", 5))
1768 if (strEQ(name2, "SA")) {
1769 gv_magicalize_isa(gv);
1773 if (strEQ(name2, "IG")) {
1776 if (!PL_psig_name) {
1777 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1778 Newxz(PL_psig_pend, SIG_SIZE, int);
1779 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1781 /* I think that the only way to get here is to re-use an
1782 embedded perl interpreter, where the previous
1783 use didn't clean up fully because
1784 PL_perl_destruct_level was 0. I'm not sure that we
1785 "support" that, in that I suspect in that scenario
1786 there are sufficient other garbage values left in the
1787 interpreter structure that something else will crash
1788 before we get here. I suspect that this is one of
1789 those "doctor, it hurts when I do this" bugs. */
1790 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1791 Zero(PL_psig_pend, SIG_SIZE, int);
1795 hv_magic(hv, NULL, PERL_MAGIC_sig);
1796 for (i = 1; i < SIG_SIZE; i++) {
1797 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1799 sv_setsv(*init, &PL_sv_undef);
1804 if (strEQ(name2, "ERSION"))
1807 case '\003': /* $^CHILD_ERROR_NATIVE */
1808 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1811 case '\005': /* $^ENCODING */
1812 if (strEQ(name2, "NCODING"))
1815 case '\007': /* $^GLOBAL_PHASE */
1816 if (strEQ(name2, "LOBAL_PHASE"))
1819 case '\014': /* $^LAST_FH */
1820 if (strEQ(name2, "AST_FH"))
1823 case '\015': /* $^MATCH */
1824 if (strEQ(name2, "ATCH"))
1827 case '\017': /* $^OPEN */
1828 if (strEQ(name2, "PEN"))
1831 case '\020': /* $^PREMATCH $^POSTMATCH */
1832 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1835 case '\024': /* ${^TAINT} */
1836 if (strEQ(name2, "AINT"))
1839 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1840 if (strEQ(name2, "NICODE"))
1842 if (strEQ(name2, "TF8LOCALE"))
1844 if (strEQ(name2, "TF8CACHE"))
1847 case '\027': /* $^WARNING_BITS */
1848 if (strEQ(name2, "ARNING_BITS"))
1861 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1863 /* This snippet is taken from is_gv_magical */
1864 const char *end = name + len;
1865 while (--end > name) {
1866 if (!isDIGIT(*end)) goto add_magical_gv;
1873 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1874 be case '\0' in this switch statement (ie a default case) */
1879 #ifdef PERL_SAWAMPERSAND
1881 sv_type == SVt_PVAV ||
1882 sv_type == SVt_PVHV ||
1883 sv_type == SVt_PVCV ||
1884 sv_type == SVt_PVFM ||
1886 )) { PL_sawampersand |=
1890 ? SAWAMPERSAND_MIDDLE
1891 : SAWAMPERSAND_RIGHT;
1897 sv_setpv(GvSVn(gv),PL_chopset);
1901 #ifdef COMPLEX_STATUS
1902 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1908 /* If %! has been used, automatically load Errno.pm. */
1910 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1912 /* magicalization must be done before require_tie_mod is called */
1913 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1915 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1917 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1923 GvMULTI_on(gv); /* no used once warnings here */
1925 AV* const av = GvAVn(gv);
1926 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1928 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1929 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1931 SvREADONLY_on(GvSVn(gv));
1934 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1936 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1938 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1945 if (sv_type == SVt_PV)
1946 /* diag_listed_as: $* is no longer supported */
1947 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1948 "$%c is no longer supported", *name);
1950 case '\010': /* $^H */
1952 HV *const hv = GvHVn(gv);
1953 hv_magic(hv, NULL, PERL_MAGIC_hints);
1957 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1958 && FEATURE_ARYBASE_IS_ENABLED) {
1959 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1960 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1963 else goto magicalize;
1965 case '\023': /* $^S */
1967 SvREADONLY_on(GvSVn(gv));
1992 case '\001': /* $^A */
1993 case '\003': /* $^C */
1994 case '\004': /* $^D */
1995 case '\005': /* $^E */
1996 case '\006': /* $^F */
1997 case '\011': /* $^I, NOT \t in EBCDIC */
1998 case '\016': /* $^N */
1999 case '\017': /* $^O */
2000 case '\020': /* $^P */
2001 case '\024': /* $^T */
2002 case '\027': /* $^W */
2004 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2007 case '\014': /* $^L */
2008 sv_setpvs(GvSVn(gv),"\f");
2011 sv_setpvs(GvSVn(gv),"\034");
2015 SV * const sv = GvSV(gv);
2016 if (!sv_derived_from(PL_patchlevel, "version"))
2017 upg_version(PL_patchlevel, TRUE);
2018 GvSV(gv) = vnumify(PL_patchlevel);
2019 SvREADONLY_on(GvSV(gv));
2023 case '\026': /* $^V */
2025 SV * const sv = GvSV(gv);
2026 GvSV(gv) = new_version(PL_patchlevel);
2027 SvREADONLY_on(GvSV(gv));
2035 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2036 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2038 (void)hv_store(stash,name,len,(SV *)gv,0);
2039 else SvREFCNT_dec_NN(gv), gv = NULL;
2041 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2046 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2049 const HV * const hv = GvSTASH(gv);
2051 PERL_ARGS_ASSERT_GV_FULLNAME4;
2053 sv_setpv(sv, prefix ? prefix : "");
2055 if (hv && (name = HvNAME(hv))) {
2056 const STRLEN len = HvNAMELEN(hv);
2057 if (keepmain || strnNE(name, "main", len)) {
2058 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2062 else sv_catpvs(sv,"__ANON__::");
2063 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2067 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2069 const GV * const egv = GvEGVx(gv);
2071 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2073 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2077 Perl_gv_check(pTHX_ HV *stash)
2082 PERL_ARGS_ASSERT_GV_CHECK;
2084 if (!HvARRAY(stash))
2086 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2088 /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
2089 are currently searching through recursively. */
2091 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2094 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2095 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2097 if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
2098 gv_check(hv); /* nested package */
2100 else if ( *HeKEY(entry) != '_'
2101 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2103 gv = MUTABLE_GV(HeVAL(entry));
2104 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2107 CopLINE_set(PL_curcop, GvLINE(gv));
2109 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2111 CopFILEGV(PL_curcop)
2112 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2114 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2115 "Name \"%"HEKf"::%"HEKf
2116 "\" used only once: possible typo",
2117 HEKfARG(HvNAME_HEK(stash)),
2118 HEKfARG(GvNAME_HEK(gv)));
2126 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2129 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2130 assert(!(flags & ~SVf_UTF8));
2132 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2133 UTF8fARG(flags, strlen(pack), pack),
2138 /* hopefully this is only called on local symbol table entries */
2141 Perl_gp_ref(pTHX_ GP *gp)
2149 /* If the GP they asked for a reference to contains
2150 a method cache entry, clear it first, so that we
2151 don't infect them with our cached entry */
2152 SvREFCNT_dec_NN(gp->gp_cv);
2161 Perl_gp_free(pTHX_ GV *gv)
2167 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2169 if (gp->gp_refcnt == 0) {
2170 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2171 "Attempt to free unreferenced glob pointers"
2172 pTHX__FORMAT pTHX__VALUE);
2175 if (--gp->gp_refcnt > 0) {
2176 if (gp->gp_egv == gv)
2183 /* Copy and null out all the glob slots, so destructors do not see
2185 HEK * const file_hek = gp->gp_file_hek;
2186 SV * const sv = gp->gp_sv;
2187 AV * const av = gp->gp_av;
2188 HV * const hv = gp->gp_hv;
2189 IO * const io = gp->gp_io;
2190 CV * const cv = gp->gp_cv;
2191 CV * const form = gp->gp_form;
2193 gp->gp_file_hek = NULL;
2202 unshare_hek(file_hek);
2206 /* FIXME - another reference loop GV -> symtab -> GV ?
2207 Somehow gp->gp_hv can end up pointing at freed garbage. */
2208 if (hv && SvTYPE(hv) == SVt_PVHV) {
2209 const HEK *hvname_hek = HvNAME_HEK(hv);
2210 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2211 if (PL_stashcache && hvname_hek)
2212 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2213 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2221 if (!gp->gp_file_hek
2227 && !gp->gp_form) break;
2229 if (--attempts == 0) {
2231 "panic: gp_free failed to free glob pointer - "
2232 "something is repeatedly re-creating entries"
2242 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2244 AMT * const amtp = (AMT*)mg->mg_ptr;
2245 PERL_UNUSED_ARG(sv);
2247 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2249 if (amtp && AMT_AMAGIC(amtp)) {
2251 for (i = 1; i < NofAMmeth; i++) {
2252 CV * const cv = amtp->table[i];
2254 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2255 amtp->table[i] = NULL;
2262 /* Updates and caches the CV's */
2264 * 1 on success and there is some overload
2265 * 0 if there is no overload
2266 * -1 if some error occurred and it couldn't croak
2270 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2273 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2275 const struct mro_meta* stash_meta = HvMROMETA(stash);
2278 PERL_ARGS_ASSERT_GV_AMUPDATE;
2280 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2282 const AMT * const amtp = (AMT*)mg->mg_ptr;
2283 if (amtp->was_ok_sub == newgen) {
2284 return AMT_AMAGIC(amtp) ? 1 : 0;
2286 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2289 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2292 amt.was_ok_sub = newgen;
2293 amt.fallback = AMGfallNO;
2300 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2302 /* Try to find via inheritance. */
2303 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2304 SV * const sv = gv ? GvSV(gv) : NULL;
2309 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2312 #ifdef PERL_DONT_CREATE_GVSV
2314 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2317 else if (SvTRUE(sv))
2318 /* don't need to set overloading here because fallback => 1
2319 * is the default setting for classes without overloading */
2320 amt.fallback=AMGfallYES;
2321 else if (SvOK(sv)) {
2322 amt.fallback=AMGfallNEVER;
2329 for (i = 1; i < NofAMmeth; i++) {
2330 const char * const cooky = PL_AMG_names[i];
2331 /* Human-readable form, for debugging: */
2332 const char * const cp = AMG_id2name(i);
2333 const STRLEN l = PL_AMG_namelens[i];
2335 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2336 cp, HvNAME_get(stash)) );
2337 /* don't fill the cache while looking up!
2338 Creation of inheritance stubs in intermediate packages may
2339 conflict with the logic of runtime method substitution.
2340 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2341 then we could have created stubs for "(+0" in A and C too.
2342 But if B overloads "bool", we may want to use it for
2343 numifying instead of C's "+0". */
2344 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2346 if (gv && (cv = GvCV(gv))) {
2347 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2348 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2349 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2350 && strEQ(hvname, "overload")) {
2351 /* This is a hack to support autoloading..., while
2352 knowing *which* methods were declared as overloaded. */
2353 /* GvSV contains the name of the method. */
2355 SV *gvsv = GvSV(gv);
2357 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2358 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2359 (void*)GvSV(gv), cp, HvNAME(stash)) );
2360 if (!gvsv || !SvPOK(gvsv)
2361 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2363 /* Can be an import stub (created by "can"). */
2368 const SV * const name = (gvsv && SvPOK(gvsv))
2370 : newSVpvs_flags("???", SVs_TEMP);
2371 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2372 Perl_croak(aTHX_ "%s method \"%"SVf256
2373 "\" overloading \"%s\" "\
2374 "in package \"%"HEKf256"\"",
2375 (GvCVGEN(gv) ? "Stub found while resolving"
2383 cv = GvCV(gv = ngv);
2386 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2387 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2388 GvNAME(CvGV(cv))) );
2390 } else if (gv) { /* Autoloaded... */
2391 cv = MUTABLE_CV(gv);
2394 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2397 AMT_AMAGIC_on(&amt);
2398 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2399 (char*)&amt, sizeof(AMT));
2403 /* Here we have no table: */
2405 AMT_AMAGIC_off(&amt);
2406 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2407 (char*)&amt, sizeof(AMTS));
2413 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2419 struct mro_meta* stash_meta;
2421 if (!stash || !HvNAME_get(stash))
2424 stash_meta = HvMROMETA(stash);
2425 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2427 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2430 if (Gv_AMupdate(stash, 0) == -1)
2432 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2435 amtp = (AMT*)mg->mg_ptr;
2436 if ( amtp->was_ok_sub != newgen )
2438 if (AMT_AMAGIC(amtp)) {
2439 CV * const ret = amtp->table[id];
2440 if (ret && isGV(ret)) { /* Autoloading stab */
2441 /* Passing it through may have resulted in a warning
2442 "Inherited AUTOLOAD for a non-method deprecated", since
2443 our caller is going through a function call, not a method call.
2444 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2445 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2457 /* Implement tryAMAGICun_MG macro.
2458 Do get magic, then see if the stack arg is overloaded and if so call it.
2460 AMGf_set return the arg using SETs rather than assigning to
2462 AMGf_numeric apply sv_2num to the stack arg.
2466 Perl_try_amagic_un(pTHX_ int method, int flags) {
2470 SV* const arg = TOPs;
2474 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2475 AMGf_noright | AMGf_unary))) {
2476 if (flags & AMGf_set) {
2481 if (SvPADMY(TARG)) {
2482 sv_setsv(TARG, tmpsv);
2492 if ((flags & AMGf_numeric) && SvROK(arg))
2498 /* Implement tryAMAGICbin_MG macro.
2499 Do get magic, then see if the two stack args are overloaded and if so
2502 AMGf_set return the arg using SETs rather than assigning to
2504 AMGf_assign op may be called as mutator (eg +=)
2505 AMGf_numeric apply sv_2num to the stack arg.
2509 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2512 SV* const left = TOPm1s;
2513 SV* const right = TOPs;
2519 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2520 SV * const tmpsv = amagic_call(left, right, method,
2521 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2523 if (flags & AMGf_set) {
2530 if (opASSIGN || SvPADMY(TARG)) {
2531 sv_setsv(TARG, tmpsv);
2541 if(left==right && SvGMAGICAL(left)) {
2542 SV * const left = sv_newmortal();
2544 /* Print the uninitialized warning now, so it includes the vari-
2547 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2548 sv_setsv_flags(left, &PL_sv_no, 0);
2550 else sv_setsv_flags(left, right, 0);
2553 if (flags & AMGf_numeric) {
2555 *(sp-1) = sv_2num(TOPm1s);
2557 *sp = sv_2num(right);
2563 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2566 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2568 while (SvAMAGIC(ref) &&
2569 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2570 AMGf_noright | AMGf_unary))) {
2572 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2573 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2574 /* Bail out if it returns us the same reference. */
2579 return tmpsv ? tmpsv : ref;
2583 Perl_amagic_is_enabled(pTHX_ int method)
2585 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2587 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2589 if ( !lex_mask || !SvOK(lex_mask) )
2590 /* overloading lexically disabled */
2592 else if ( lex_mask && SvPOK(lex_mask) ) {
2593 /* we have an entry in the hints hash, check if method has been
2594 * masked by overloading.pm */
2596 const int offset = method / 8;
2597 const int bit = method % 8;
2598 char *pv = SvPV(lex_mask, len);
2600 /* Bit set, so this overloading operator is disabled */
2601 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2608 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2613 CV **cvp=NULL, **ocvp=NULL;
2614 AMT *amtp=NULL, *oamtp=NULL;
2615 int off = 0, off1, lr = 0, notfound = 0;
2616 int postpr = 0, force_cpy = 0;
2617 int assign = AMGf_assign & flags;
2618 const int assignshift = assign ? 1 : 0;
2619 int use_default_op = 0;
2620 int force_scalar = 0;
2626 PERL_ARGS_ASSERT_AMAGIC_CALL;
2628 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2629 if (!amagic_is_enabled(method)) return NULL;
2632 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2633 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2634 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2635 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2636 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2638 && ((cv = cvp[off=method+assignshift])
2639 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2645 cv = cvp[off=method])))) {
2646 lr = -1; /* Call method for left argument */
2648 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2651 /* look for substituted methods */
2652 /* In all the covered cases we should be called with assign==0. */
2656 if ((cv = cvp[off=add_ass_amg])
2657 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2658 right = &PL_sv_yes; lr = -1; assign = 1;
2663 if ((cv = cvp[off = subtr_ass_amg])
2664 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2665 right = &PL_sv_yes; lr = -1; assign = 1;
2669 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2672 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2675 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2678 (void)((cv = cvp[off=bool__amg])
2679 || (cv = cvp[off=numer_amg])
2680 || (cv = cvp[off=string_amg]));
2687 * SV* ref causes confusion with the interpreter variable of
2690 SV* const tmpRef=SvRV(left);
2691 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2693 * Just to be extra cautious. Maybe in some
2694 * additional cases sv_setsv is safe, too.
2696 SV* const newref = newSVsv(tmpRef);
2697 SvOBJECT_on(newref);
2698 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2699 delegate to the stash. */
2700 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2706 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2707 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2708 SV* const nullsv=sv_2mortal(newSViv(0));
2710 SV* const lessp = amagic_call(left,nullsv,
2711 lt_amg,AMGf_noright);
2712 logic = SvTRUE(lessp);
2714 SV* const lessp = amagic_call(left,nullsv,
2715 ncmp_amg,AMGf_noright);
2716 logic = (SvNV(lessp) < 0);
2719 if (off==subtr_amg) {
2730 if ((cv = cvp[off=subtr_amg])) {
2732 left = sv_2mortal(newSViv(0));
2737 case iter_amg: /* XXXX Eventually should do to_gv. */
2738 case ftest_amg: /* XXXX Eventually should do to_gv. */
2741 return NULL; /* Delegate operation to standard mechanisms. */
2749 return left; /* Delegate operation to standard mechanisms. */
2754 if (!cv) goto not_found;
2755 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2756 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2757 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2758 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2759 ? (amtp = (AMT*)mg->mg_ptr)->table
2761 && (cv = cvp[off=method])) { /* Method for right
2764 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2765 || (ocvp && oamtp->fallback > AMGfallNEVER))
2766 && !(flags & AMGf_unary)) {
2767 /* We look for substitution for
2768 * comparison operations and
2770 if (method==concat_amg || method==concat_ass_amg
2771 || method==repeat_amg || method==repeat_ass_amg) {
2772 return NULL; /* Delegate operation to string conversion */
2794 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2798 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2808 not_found: /* No method found, either report or croak */
2816 return left; /* Delegate operation to standard mechanisms. */
2819 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2820 notfound = 1; lr = -1;
2821 } else if (cvp && (cv=cvp[nomethod_amg])) {
2822 notfound = 1; lr = 1;
2823 } else if ((use_default_op =
2824 (!ocvp || oamtp->fallback >= AMGfallYES)
2825 && (!cvp || amtp->fallback >= AMGfallYES))
2827 /* Skip generating the "no method found" message. */
2831 if (off==-1) off=method;
2832 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2833 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2834 AMG_id2name(method + assignshift),
2835 (flags & AMGf_unary ? " " : "\n\tleft "),
2837 "in overloaded package ":
2838 "has no overloaded magic",
2840 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2843 ",\n\tright argument in overloaded package ":
2846 : ",\n\tright argument has no overloaded magic"),
2848 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2849 SVfARG(&PL_sv_no)));
2850 if (use_default_op) {
2851 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2853 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2857 force_cpy = force_cpy || assign;
2862 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2863 * operation. we need this to return a value, so that it can be assigned
2864 * later on, in the postpr block (case inc_amg/dec_amg), even if the
2865 * increment or decrement was itself called in void context */
2871 if (off == subtr_amg)
2874 /* in these cases, we're calling an assignment variant of an operator
2875 * (+= rather than +, for instance). regardless of whether it's a
2876 * fallback or not, it always has to return a value, which will be
2877 * assigned to the proper variable later */
2894 /* the copy constructor always needs to return a value */
2898 /* because of the way these are implemented (they don't perform the
2899 * dereferencing themselves, they return a reference that perl then
2900 * dereferences later), they always have to be in scalar context */
2908 /* these don't have an op of their own; they're triggered by their parent
2909 * op, so the context there isn't meaningful ('$a and foo()' in void
2910 * context still needs to pass scalar context on to $a's bool overload) */
2920 DEBUG_o(Perl_deb(aTHX_
2921 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2923 method+assignshift==off? "" :
2925 method+assignshift==off? "" :
2926 AMG_id2name(method+assignshift),
2927 method+assignshift==off? "" : "\")",
2928 flags & AMGf_unary? "" :
2929 lr==1 ? " for right argument": " for left argument",
2930 flags & AMGf_unary? " for argument" : "",
2931 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2932 fl? ",\n\tassignment variant used": "") );
2935 /* Since we use shallow copy during assignment, we need
2936 * to dublicate the contents, probably calling user-supplied
2937 * version of copy operator
2939 /* We need to copy in following cases:
2940 * a) Assignment form was called.
2941 * assignshift==1, assign==T, method + 1 == off
2942 * b) Increment or decrement, called directly.
2943 * assignshift==0, assign==0, method + 0 == off
2944 * c) Increment or decrement, translated to assignment add/subtr.
2945 * assignshift==0, assign==T,
2947 * d) Increment or decrement, translated to nomethod.
2948 * assignshift==0, assign==0,
2950 * e) Assignment form translated to nomethod.
2951 * assignshift==1, assign==T, method + 1 != off
2954 /* off is method, method+assignshift, or a result of opcode substitution.
2955 * In the latter case assignshift==0, so only notfound case is important.
2957 if ( (lr == -1) && ( ( (method + assignshift == off)
2958 && (assign || (method == inc_amg) || (method == dec_amg)))
2961 /* newSVsv does not behave as advertised, so we copy missing
2962 * information by hand */
2963 SV *tmpRef = SvRV(left);
2965 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2966 SvRV_set(left, rv_copy);
2968 SvREFCNT_dec_NN(tmpRef);
2976 const bool oldcatch = CATCH_GET;
2978 int gimme = force_scalar ? G_SCALAR : GIMME_V;
2981 Zero(&myop, 1, BINOP);
2982 myop.op_last = (OP *) &myop;
2983 myop.op_next = NULL;
2984 myop.op_flags = OPf_STACKED;
2988 myop.op_flags |= OPf_WANT_VOID;
2991 if (flags & AMGf_want_list) {
2992 myop.op_flags |= OPf_WANT_LIST;
2997 myop.op_flags |= OPf_WANT_SCALAR;
3001 PUSHSTACKi(PERLSI_OVERLOAD);
3004 PL_op = (OP *) &myop;
3005 if (PERLDB_SUB && PL_curstash != PL_debstash)
3006 PL_op->op_private |= OPpENTERSUB_DB;
3008 Perl_pp_pushmark(aTHX);
3010 EXTEND(SP, notfound + 5);
3011 PUSHs(lr>0? right: left);
3012 PUSHs(lr>0? left: right);
3013 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3015 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3016 AMG_id2namelen(method + assignshift), SVs_TEMP));
3018 PUSHs(MUTABLE_SV(cv));
3022 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3026 nret = SP - (PL_stack_base + oldmark);
3030 /* returning NULL has another meaning, and we check the context
3031 * at the call site too, so this can be differentiated from the
3034 SP = PL_stack_base + oldmark;
3037 if (flags & AMGf_want_list) {
3038 res = sv_2mortal((SV *)newAV());
3039 av_extend((AV *)res, nret);
3041 av_store((AV *)res, nret, POPs);
3053 CATCH_SET(oldcatch);
3060 ans=SvIV(res)<=0; break;
3063 ans=SvIV(res)<0; break;
3066 ans=SvIV(res)>=0; break;
3069 ans=SvIV(res)>0; break;
3072 ans=SvIV(res)==0; break;
3075 ans=SvIV(res)!=0; break;
3078 SvSetSV(left,res); return left;
3080 ans=!SvTRUE(res); break;
3085 } else if (method==copy_amg) {
3087 Perl_croak(aTHX_ "Copy method did not return a reference");
3089 return SvREFCNT_inc(SvRV(res));
3097 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3102 PERL_ARGS_ASSERT_GV_NAME_SET;
3105 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3107 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3108 unshare_hek(GvNAME_HEK(gv));
3111 PERL_HASH(hash, name, len);
3112 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3116 =for apidoc gv_try_downgrade
3118 If the typeglob C<gv> can be expressed more succinctly, by having
3119 something other than a real GV in its place in the stash, replace it
3120 with the optimised form. Basic requirements for this are that C<gv>
3121 is a real typeglob, is sufficiently ordinary, and is only referenced
3122 from its package. This function is meant to be used when a GV has been
3123 looked up in part to see what was there, causing upgrading, but based
3124 on what was found it turns out that the real GV isn't required after all.
3126 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3128 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3129 sub, the typeglob is replaced with a scalar-reference placeholder that
3130 more compactly represents the same thing.
3136 Perl_gv_try_downgrade(pTHX_ GV *gv)
3142 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3144 /* XXX Why and where does this leave dangling pointers during global
3146 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3148 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3149 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3150 isGV_with_GP(gv) && GvGP(gv) &&
3151 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3152 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3153 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3155 if (SvMAGICAL(gv)) {
3157 /* only backref magic is allowed */
3158 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3160 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3161 if (mg->mg_type != PERL_MAGIC_backref)
3167 HEK *gvnhek = GvNAME_HEK(gv);
3168 (void)hv_delete(stash, HEK_KEY(gvnhek),
3169 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3170 } else if (GvMULTI(gv) && cv &&
3171 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3172 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3173 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3174 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3175 (namehek = GvNAME_HEK(gv)) &&
3176 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3177 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3179 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3180 const bool imported = !!GvIMPORTED_CV(gv);
3184 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3185 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3186 STRUCT_OFFSET(XPVIV, xiv_iv));
3187 SvRV_set(gv, value);
3194 core_xsub(pTHX_ CV* cv)
3197 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3203 * c-indentation-style: bsd
3205 * indent-tabs-mode: nil
3208 * ex: set ts=8 sts=4 sw=4 et: