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"))
1826 case '\017': /* $^OPEN */
1827 if (strEQ(name2, "PEN"))
1830 case '\020': /* $^PREMATCH $^POSTMATCH */
1831 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1834 case '\024': /* ${^TAINT} */
1835 if (strEQ(name2, "AINT"))
1838 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1839 if (strEQ(name2, "NICODE"))
1841 if (strEQ(name2, "TF8LOCALE"))
1843 if (strEQ(name2, "TF8CACHE"))
1846 case '\027': /* $^WARNING_BITS */
1847 if (strEQ(name2, "ARNING_BITS"))
1860 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1862 /* This snippet is taken from is_gv_magical */
1863 const char *end = name + len;
1864 while (--end > name) {
1865 if (!isDIGIT(*end)) goto add_magical_gv;
1872 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1873 be case '\0' in this switch statement (ie a default case) */
1878 #ifdef PERL_SAWAMPERSAND
1880 sv_type == SVt_PVAV ||
1881 sv_type == SVt_PVHV ||
1882 sv_type == SVt_PVCV ||
1883 sv_type == SVt_PVFM ||
1885 )) { PL_sawampersand |=
1889 ? SAWAMPERSAND_MIDDLE
1890 : SAWAMPERSAND_RIGHT;
1896 sv_setpv(GvSVn(gv),PL_chopset);
1900 #ifdef COMPLEX_STATUS
1901 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1907 /* If %! has been used, automatically load Errno.pm. */
1909 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1911 /* magicalization must be done before require_tie_mod is called */
1912 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1914 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1916 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1922 GvMULTI_on(gv); /* no used once warnings here */
1924 AV* const av = GvAVn(gv);
1925 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1927 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1928 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1930 SvREADONLY_on(GvSVn(gv));
1933 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1935 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1937 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1944 if (sv_type == SVt_PV)
1945 /* diag_listed_as: $* is no longer supported */
1946 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1947 "$%c is no longer supported", *name);
1949 case '\010': /* $^H */
1951 HV *const hv = GvHVn(gv);
1952 hv_magic(hv, NULL, PERL_MAGIC_hints);
1956 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1957 && FEATURE_ARYBASE_IS_ENABLED) {
1958 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1959 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1962 else goto magicalize;
1964 case '\023': /* $^S */
1966 SvREADONLY_on(GvSVn(gv));
1991 case '\001': /* $^A */
1992 case '\003': /* $^C */
1993 case '\004': /* $^D */
1994 case '\005': /* $^E */
1995 case '\006': /* $^F */
1996 case '\011': /* $^I, NOT \t in EBCDIC */
1997 case '\016': /* $^N */
1998 case '\017': /* $^O */
1999 case '\020': /* $^P */
2000 case '\024': /* $^T */
2001 case '\027': /* $^W */
2003 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2006 case '\014': /* $^L */
2007 sv_setpvs(GvSVn(gv),"\f");
2010 sv_setpvs(GvSVn(gv),"\034");
2014 SV * const sv = GvSV(gv);
2015 if (!sv_derived_from(PL_patchlevel, "version"))
2016 upg_version(PL_patchlevel, TRUE);
2017 GvSV(gv) = vnumify(PL_patchlevel);
2018 SvREADONLY_on(GvSV(gv));
2022 case '\026': /* $^V */
2024 SV * const sv = GvSV(gv);
2025 GvSV(gv) = new_version(PL_patchlevel);
2026 SvREADONLY_on(GvSV(gv));
2034 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2035 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2037 (void)hv_store(stash,name,len,(SV *)gv,0);
2038 else SvREFCNT_dec_NN(gv), gv = NULL;
2040 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2045 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2048 const HV * const hv = GvSTASH(gv);
2050 PERL_ARGS_ASSERT_GV_FULLNAME4;
2052 sv_setpv(sv, prefix ? prefix : "");
2054 if (hv && (name = HvNAME(hv))) {
2055 const STRLEN len = HvNAMELEN(hv);
2056 if (keepmain || strnNE(name, "main", len)) {
2057 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2061 else sv_catpvs(sv,"__ANON__::");
2062 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2066 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2068 const GV * const egv = GvEGVx(gv);
2070 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2072 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2076 Perl_gv_check(pTHX_ HV *stash)
2081 PERL_ARGS_ASSERT_GV_CHECK;
2083 if (!HvARRAY(stash))
2085 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2087 /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
2088 are currently searching through recursively. */
2090 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2093 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2094 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2096 if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
2097 gv_check(hv); /* nested package */
2099 else if ( *HeKEY(entry) != '_'
2100 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2102 gv = MUTABLE_GV(HeVAL(entry));
2103 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2106 CopLINE_set(PL_curcop, GvLINE(gv));
2108 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2110 CopFILEGV(PL_curcop)
2111 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2113 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2114 "Name \"%"HEKf"::%"HEKf
2115 "\" used only once: possible typo",
2116 HEKfARG(HvNAME_HEK(stash)),
2117 HEKfARG(GvNAME_HEK(gv)));
2125 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2128 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2129 assert(!(flags & ~SVf_UTF8));
2131 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2132 UTF8fARG(flags, strlen(pack), pack),
2137 /* hopefully this is only called on local symbol table entries */
2140 Perl_gp_ref(pTHX_ GP *gp)
2148 /* If the GP they asked for a reference to contains
2149 a method cache entry, clear it first, so that we
2150 don't infect them with our cached entry */
2151 SvREFCNT_dec_NN(gp->gp_cv);
2160 Perl_gp_free(pTHX_ GV *gv)
2166 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2168 if (gp->gp_refcnt == 0) {
2169 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2170 "Attempt to free unreferenced glob pointers"
2171 pTHX__FORMAT pTHX__VALUE);
2174 if (--gp->gp_refcnt > 0) {
2175 if (gp->gp_egv == gv)
2182 /* Copy and null out all the glob slots, so destructors do not see
2184 HEK * const file_hek = gp->gp_file_hek;
2185 SV * const sv = gp->gp_sv;
2186 AV * const av = gp->gp_av;
2187 HV * const hv = gp->gp_hv;
2188 IO * const io = gp->gp_io;
2189 CV * const cv = gp->gp_cv;
2190 CV * const form = gp->gp_form;
2192 gp->gp_file_hek = NULL;
2201 unshare_hek(file_hek);
2205 /* FIXME - another reference loop GV -> symtab -> GV ?
2206 Somehow gp->gp_hv can end up pointing at freed garbage. */
2207 if (hv && SvTYPE(hv) == SVt_PVHV) {
2208 const HEK *hvname_hek = HvNAME_HEK(hv);
2209 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2210 if (PL_stashcache && hvname_hek)
2211 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2212 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2220 if (!gp->gp_file_hek
2226 && !gp->gp_form) break;
2228 if (--attempts == 0) {
2230 "panic: gp_free failed to free glob pointer - "
2231 "something is repeatedly re-creating entries"
2241 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2243 AMT * const amtp = (AMT*)mg->mg_ptr;
2244 PERL_UNUSED_ARG(sv);
2246 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2248 if (amtp && AMT_AMAGIC(amtp)) {
2250 for (i = 1; i < NofAMmeth; i++) {
2251 CV * const cv = amtp->table[i];
2253 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2254 amtp->table[i] = NULL;
2261 /* Updates and caches the CV's */
2263 * 1 on success and there is some overload
2264 * 0 if there is no overload
2265 * -1 if some error occurred and it couldn't croak
2269 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2272 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2274 const struct mro_meta* stash_meta = HvMROMETA(stash);
2277 PERL_ARGS_ASSERT_GV_AMUPDATE;
2279 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2281 const AMT * const amtp = (AMT*)mg->mg_ptr;
2282 if (amtp->was_ok_sub == newgen) {
2283 return AMT_AMAGIC(amtp) ? 1 : 0;
2285 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2288 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2291 amt.was_ok_sub = newgen;
2292 amt.fallback = AMGfallNO;
2299 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2301 /* Try to find via inheritance. */
2302 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2303 SV * const sv = gv ? GvSV(gv) : NULL;
2308 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2311 #ifdef PERL_DONT_CREATE_GVSV
2313 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2316 else if (SvTRUE(sv))
2317 /* don't need to set overloading here because fallback => 1
2318 * is the default setting for classes without overloading */
2319 amt.fallback=AMGfallYES;
2320 else if (SvOK(sv)) {
2321 amt.fallback=AMGfallNEVER;
2328 for (i = 1; i < NofAMmeth; i++) {
2329 const char * const cooky = PL_AMG_names[i];
2330 /* Human-readable form, for debugging: */
2331 const char * const cp = AMG_id2name(i);
2332 const STRLEN l = PL_AMG_namelens[i];
2334 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2335 cp, HvNAME_get(stash)) );
2336 /* don't fill the cache while looking up!
2337 Creation of inheritance stubs in intermediate packages may
2338 conflict with the logic of runtime method substitution.
2339 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2340 then we could have created stubs for "(+0" in A and C too.
2341 But if B overloads "bool", we may want to use it for
2342 numifying instead of C's "+0". */
2343 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2345 if (gv && (cv = GvCV(gv))) {
2346 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2347 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2348 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2349 && strEQ(hvname, "overload")) {
2350 /* This is a hack to support autoloading..., while
2351 knowing *which* methods were declared as overloaded. */
2352 /* GvSV contains the name of the method. */
2354 SV *gvsv = GvSV(gv);
2356 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2357 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2358 (void*)GvSV(gv), cp, HvNAME(stash)) );
2359 if (!gvsv || !SvPOK(gvsv)
2360 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2362 /* Can be an import stub (created by "can"). */
2367 const SV * const name = (gvsv && SvPOK(gvsv))
2369 : newSVpvs_flags("???", SVs_TEMP);
2370 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2371 Perl_croak(aTHX_ "%s method \"%"SVf256
2372 "\" overloading \"%s\" "\
2373 "in package \"%"HEKf256"\"",
2374 (GvCVGEN(gv) ? "Stub found while resolving"
2382 cv = GvCV(gv = ngv);
2385 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2386 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2387 GvNAME(CvGV(cv))) );
2389 } else if (gv) { /* Autoloaded... */
2390 cv = MUTABLE_CV(gv);
2393 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2396 AMT_AMAGIC_on(&amt);
2397 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2398 (char*)&amt, sizeof(AMT));
2402 /* Here we have no table: */
2404 AMT_AMAGIC_off(&amt);
2405 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2406 (char*)&amt, sizeof(AMTS));
2412 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2418 struct mro_meta* stash_meta;
2420 if (!stash || !HvNAME_get(stash))
2423 stash_meta = HvMROMETA(stash);
2424 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2426 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2429 if (Gv_AMupdate(stash, 0) == -1)
2431 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2434 amtp = (AMT*)mg->mg_ptr;
2435 if ( amtp->was_ok_sub != newgen )
2437 if (AMT_AMAGIC(amtp)) {
2438 CV * const ret = amtp->table[id];
2439 if (ret && isGV(ret)) { /* Autoloading stab */
2440 /* Passing it through may have resulted in a warning
2441 "Inherited AUTOLOAD for a non-method deprecated", since
2442 our caller is going through a function call, not a method call.
2443 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2444 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2456 /* Implement tryAMAGICun_MG macro.
2457 Do get magic, then see if the stack arg is overloaded and if so call it.
2459 AMGf_set return the arg using SETs rather than assigning to
2461 AMGf_numeric apply sv_2num to the stack arg.
2465 Perl_try_amagic_un(pTHX_ int method, int flags) {
2469 SV* const arg = TOPs;
2473 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2474 AMGf_noright | AMGf_unary))) {
2475 if (flags & AMGf_set) {
2480 if (SvPADMY(TARG)) {
2481 sv_setsv(TARG, tmpsv);
2491 if ((flags & AMGf_numeric) && SvROK(arg))
2497 /* Implement tryAMAGICbin_MG macro.
2498 Do get magic, then see if the two stack args are overloaded and if so
2501 AMGf_set return the arg using SETs rather than assigning to
2503 AMGf_assign op may be called as mutator (eg +=)
2504 AMGf_numeric apply sv_2num to the stack arg.
2508 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2511 SV* const left = TOPm1s;
2512 SV* const right = TOPs;
2518 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2519 SV * const tmpsv = amagic_call(left, right, method,
2520 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2522 if (flags & AMGf_set) {
2529 if (opASSIGN || SvPADMY(TARG)) {
2530 sv_setsv(TARG, tmpsv);
2540 if(left==right && SvGMAGICAL(left)) {
2541 SV * const left = sv_newmortal();
2543 /* Print the uninitialized warning now, so it includes the vari-
2546 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2547 sv_setsv_flags(left, &PL_sv_no, 0);
2549 else sv_setsv_flags(left, right, 0);
2552 if (flags & AMGf_numeric) {
2554 *(sp-1) = sv_2num(TOPm1s);
2556 *sp = sv_2num(right);
2562 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2565 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2567 while (SvAMAGIC(ref) &&
2568 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2569 AMGf_noright | AMGf_unary))) {
2571 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2572 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2573 /* Bail out if it returns us the same reference. */
2578 return tmpsv ? tmpsv : ref;
2582 Perl_amagic_is_enabled(pTHX_ int method)
2584 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2586 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2588 if ( !lex_mask || !SvOK(lex_mask) )
2589 /* overloading lexically disabled */
2591 else if ( lex_mask && SvPOK(lex_mask) ) {
2592 /* we have an entry in the hints hash, check if method has been
2593 * masked by overloading.pm */
2595 const int offset = method / 8;
2596 const int bit = method % 8;
2597 char *pv = SvPV(lex_mask, len);
2599 /* Bit set, so this overloading operator is disabled */
2600 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2607 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2612 CV **cvp=NULL, **ocvp=NULL;
2613 AMT *amtp=NULL, *oamtp=NULL;
2614 int off = 0, off1, lr = 0, notfound = 0;
2615 int postpr = 0, force_cpy = 0;
2616 int assign = AMGf_assign & flags;
2617 const int assignshift = assign ? 1 : 0;
2618 int use_default_op = 0;
2619 int force_scalar = 0;
2625 PERL_ARGS_ASSERT_AMAGIC_CALL;
2627 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2628 if (!amagic_is_enabled(method)) return NULL;
2631 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2632 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2633 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2634 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2635 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2637 && ((cv = cvp[off=method+assignshift])
2638 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2644 cv = cvp[off=method])))) {
2645 lr = -1; /* Call method for left argument */
2647 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2650 /* look for substituted methods */
2651 /* In all the covered cases we should be called with assign==0. */
2655 if ((cv = cvp[off=add_ass_amg])
2656 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2657 right = &PL_sv_yes; lr = -1; assign = 1;
2662 if ((cv = cvp[off = subtr_ass_amg])
2663 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2664 right = &PL_sv_yes; lr = -1; assign = 1;
2668 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2671 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2674 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2677 (void)((cv = cvp[off=bool__amg])
2678 || (cv = cvp[off=numer_amg])
2679 || (cv = cvp[off=string_amg]));
2686 * SV* ref causes confusion with the interpreter variable of
2689 SV* const tmpRef=SvRV(left);
2690 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2692 * Just to be extra cautious. Maybe in some
2693 * additional cases sv_setsv is safe, too.
2695 SV* const newref = newSVsv(tmpRef);
2696 SvOBJECT_on(newref);
2697 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2698 delegate to the stash. */
2699 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2705 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2706 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2707 SV* const nullsv=sv_2mortal(newSViv(0));
2709 SV* const lessp = amagic_call(left,nullsv,
2710 lt_amg,AMGf_noright);
2711 logic = SvTRUE(lessp);
2713 SV* const lessp = amagic_call(left,nullsv,
2714 ncmp_amg,AMGf_noright);
2715 logic = (SvNV(lessp) < 0);
2718 if (off==subtr_amg) {
2729 if ((cv = cvp[off=subtr_amg])) {
2731 left = sv_2mortal(newSViv(0));
2736 case iter_amg: /* XXXX Eventually should do to_gv. */
2737 case ftest_amg: /* XXXX Eventually should do to_gv. */
2740 return NULL; /* Delegate operation to standard mechanisms. */
2748 return left; /* Delegate operation to standard mechanisms. */
2753 if (!cv) goto not_found;
2754 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2755 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2756 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2757 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2758 ? (amtp = (AMT*)mg->mg_ptr)->table
2760 && (cv = cvp[off=method])) { /* Method for right
2763 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2764 || (ocvp && oamtp->fallback > AMGfallNEVER))
2765 && !(flags & AMGf_unary)) {
2766 /* We look for substitution for
2767 * comparison operations and
2769 if (method==concat_amg || method==concat_ass_amg
2770 || method==repeat_amg || method==repeat_ass_amg) {
2771 return NULL; /* Delegate operation to string conversion */
2793 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2797 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2807 not_found: /* No method found, either report or croak */
2815 return left; /* Delegate operation to standard mechanisms. */
2818 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2819 notfound = 1; lr = -1;
2820 } else if (cvp && (cv=cvp[nomethod_amg])) {
2821 notfound = 1; lr = 1;
2822 } else if ((use_default_op =
2823 (!ocvp || oamtp->fallback >= AMGfallYES)
2824 && (!cvp || amtp->fallback >= AMGfallYES))
2826 /* Skip generating the "no method found" message. */
2830 if (off==-1) off=method;
2831 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2832 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2833 AMG_id2name(method + assignshift),
2834 (flags & AMGf_unary ? " " : "\n\tleft "),
2836 "in overloaded package ":
2837 "has no overloaded magic",
2839 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2842 ",\n\tright argument in overloaded package ":
2845 : ",\n\tright argument has no overloaded magic"),
2847 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2848 SVfARG(&PL_sv_no)));
2849 if (use_default_op) {
2850 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2852 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2856 force_cpy = force_cpy || assign;
2861 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2862 * operation. we need this to return a value, so that it can be assigned
2863 * later on, in the postpr block (case inc_amg/dec_amg), even if the
2864 * increment or decrement was itself called in void context */
2870 if (off == subtr_amg)
2873 /* in these cases, we're calling an assignment variant of an operator
2874 * (+= rather than +, for instance). regardless of whether it's a
2875 * fallback or not, it always has to return a value, which will be
2876 * assigned to the proper variable later */
2893 /* the copy constructor always needs to return a value */
2897 /* because of the way these are implemented (they don't perform the
2898 * dereferencing themselves, they return a reference that perl then
2899 * dereferences later), they always have to be in scalar context */
2907 /* these don't have an op of their own; they're triggered by their parent
2908 * op, so the context there isn't meaningful ('$a and foo()' in void
2909 * context still needs to pass scalar context on to $a's bool overload) */
2919 DEBUG_o(Perl_deb(aTHX_
2920 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2922 method+assignshift==off? "" :
2924 method+assignshift==off? "" :
2925 AMG_id2name(method+assignshift),
2926 method+assignshift==off? "" : "\")",
2927 flags & AMGf_unary? "" :
2928 lr==1 ? " for right argument": " for left argument",
2929 flags & AMGf_unary? " for argument" : "",
2930 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2931 fl? ",\n\tassignment variant used": "") );
2934 /* Since we use shallow copy during assignment, we need
2935 * to dublicate the contents, probably calling user-supplied
2936 * version of copy operator
2938 /* We need to copy in following cases:
2939 * a) Assignment form was called.
2940 * assignshift==1, assign==T, method + 1 == off
2941 * b) Increment or decrement, called directly.
2942 * assignshift==0, assign==0, method + 0 == off
2943 * c) Increment or decrement, translated to assignment add/subtr.
2944 * assignshift==0, assign==T,
2946 * d) Increment or decrement, translated to nomethod.
2947 * assignshift==0, assign==0,
2949 * e) Assignment form translated to nomethod.
2950 * assignshift==1, assign==T, method + 1 != off
2953 /* off is method, method+assignshift, or a result of opcode substitution.
2954 * In the latter case assignshift==0, so only notfound case is important.
2956 if ( (lr == -1) && ( ( (method + assignshift == off)
2957 && (assign || (method == inc_amg) || (method == dec_amg)))
2960 /* newSVsv does not behave as advertised, so we copy missing
2961 * information by hand */
2962 SV *tmpRef = SvRV(left);
2964 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2965 SvRV_set(left, rv_copy);
2967 SvREFCNT_dec_NN(tmpRef);
2975 const bool oldcatch = CATCH_GET;
2977 int gimme = force_scalar ? G_SCALAR : GIMME_V;
2980 Zero(&myop, 1, BINOP);
2981 myop.op_last = (OP *) &myop;
2982 myop.op_next = NULL;
2983 myop.op_flags = OPf_STACKED;
2987 myop.op_flags |= OPf_WANT_VOID;
2990 if (flags & AMGf_want_list) {
2991 myop.op_flags |= OPf_WANT_LIST;
2996 myop.op_flags |= OPf_WANT_SCALAR;
3000 PUSHSTACKi(PERLSI_OVERLOAD);
3003 PL_op = (OP *) &myop;
3004 if (PERLDB_SUB && PL_curstash != PL_debstash)
3005 PL_op->op_private |= OPpENTERSUB_DB;
3007 Perl_pp_pushmark(aTHX);
3009 EXTEND(SP, notfound + 5);
3010 PUSHs(lr>0? right: left);
3011 PUSHs(lr>0? left: right);
3012 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3014 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3015 AMG_id2namelen(method + assignshift), SVs_TEMP));
3017 PUSHs(MUTABLE_SV(cv));
3021 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3025 nret = SP - (PL_stack_base + oldmark);
3029 /* returning NULL has another meaning, and we check the context
3030 * at the call site too, so this can be differentiated from the
3033 SP = PL_stack_base + oldmark;
3036 if (flags & AMGf_want_list) {
3037 res = sv_2mortal((SV *)newAV());
3038 av_extend((AV *)res, nret);
3040 av_store((AV *)res, nret, POPs);
3052 CATCH_SET(oldcatch);
3059 ans=SvIV(res)<=0; break;
3062 ans=SvIV(res)<0; break;
3065 ans=SvIV(res)>=0; break;
3068 ans=SvIV(res)>0; break;
3071 ans=SvIV(res)==0; break;
3074 ans=SvIV(res)!=0; break;
3077 SvSetSV(left,res); return left;
3079 ans=!SvTRUE(res); break;
3084 } else if (method==copy_amg) {
3086 Perl_croak(aTHX_ "Copy method did not return a reference");
3088 return SvREFCNT_inc(SvRV(res));
3096 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3101 PERL_ARGS_ASSERT_GV_NAME_SET;
3104 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3106 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3107 unshare_hek(GvNAME_HEK(gv));
3110 PERL_HASH(hash, name, len);
3111 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3115 =for apidoc gv_try_downgrade
3117 If the typeglob C<gv> can be expressed more succinctly, by having
3118 something other than a real GV in its place in the stash, replace it
3119 with the optimised form. Basic requirements for this are that C<gv>
3120 is a real typeglob, is sufficiently ordinary, and is only referenced
3121 from its package. This function is meant to be used when a GV has been
3122 looked up in part to see what was there, causing upgrading, but based
3123 on what was found it turns out that the real GV isn't required after all.
3125 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3127 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3128 sub, the typeglob is replaced with a scalar-reference placeholder that
3129 more compactly represents the same thing.
3135 Perl_gv_try_downgrade(pTHX_ GV *gv)
3141 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3143 /* XXX Why and where does this leave dangling pointers during global
3145 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3147 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3148 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3149 isGV_with_GP(gv) && GvGP(gv) &&
3150 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3151 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3152 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3154 if (SvMAGICAL(gv)) {
3156 /* only backref magic is allowed */
3157 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3159 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3160 if (mg->mg_type != PERL_MAGIC_backref)
3166 HEK *gvnhek = GvNAME_HEK(gv);
3167 (void)hv_delete(stash, HEK_KEY(gvnhek),
3168 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3169 } else if (GvMULTI(gv) && cv &&
3170 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3171 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3172 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3173 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3174 (namehek = GvNAME_HEK(gv)) &&
3175 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3176 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3178 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3179 const bool imported = !!GvIMPORTED_CV(gv);
3183 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3184 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3185 STRUCT_OFFSET(XPVIV, xiv_iv));
3186 SvRV_set(gv, value);
3193 core_xsub(pTHX_ CV* cv)
3196 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3202 * c-indentation-style: bsd
3204 * indent-tabs-mode: nil
3207 * ex: set ts=8 sts=4 sw=4 et: