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. (On EBCDIC
1750 platforms, we can't just do:
1751 if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) {
1752 because cases like '\027' in the switch statement below are
1753 C1 (non-ASCII) controls on those platforms, so the remapping
1754 would make them larger than 'V')
1759 const char * const name2 = name + 1;
1762 if (strEQ(name2, "RGV")) {
1763 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1765 else if (strEQ(name2, "RGVOUT")) {
1770 if (strnEQ(name2, "XPORT", 5))
1774 if (strEQ(name2, "SA")) {
1775 gv_magicalize_isa(gv);
1779 if (strEQ(name2, "IG")) {
1782 if (!PL_psig_name) {
1783 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1784 Newxz(PL_psig_pend, SIG_SIZE, int);
1785 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1787 /* I think that the only way to get here is to re-use an
1788 embedded perl interpreter, where the previous
1789 use didn't clean up fully because
1790 PL_perl_destruct_level was 0. I'm not sure that we
1791 "support" that, in that I suspect in that scenario
1792 there are sufficient other garbage values left in the
1793 interpreter structure that something else will crash
1794 before we get here. I suspect that this is one of
1795 those "doctor, it hurts when I do this" bugs. */
1796 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1797 Zero(PL_psig_pend, SIG_SIZE, int);
1801 hv_magic(hv, NULL, PERL_MAGIC_sig);
1802 for (i = 1; i < SIG_SIZE; i++) {
1803 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1805 sv_setsv(*init, &PL_sv_undef);
1810 if (strEQ(name2, "ERSION"))
1813 case '\003': /* $^CHILD_ERROR_NATIVE */
1814 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1817 case '\005': /* $^ENCODING */
1818 if (strEQ(name2, "NCODING"))
1821 case '\007': /* $^GLOBAL_PHASE */
1822 if (strEQ(name2, "LOBAL_PHASE"))
1825 case '\014': /* $^LAST_FH */
1826 if (strEQ(name2, "AST_FH"))
1829 case '\015': /* $^MATCH */
1830 if (strEQ(name2, "ATCH"))
1833 case '\017': /* $^OPEN */
1834 if (strEQ(name2, "PEN"))
1837 case '\020': /* $^PREMATCH $^POSTMATCH */
1838 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1841 case '\024': /* ${^TAINT} */
1842 if (strEQ(name2, "AINT"))
1845 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1846 if (strEQ(name2, "NICODE"))
1848 if (strEQ(name2, "TF8LOCALE"))
1850 if (strEQ(name2, "TF8CACHE"))
1853 case '\027': /* $^WARNING_BITS */
1854 if (strEQ(name2, "ARNING_BITS"))
1867 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1869 /* This snippet is taken from is_gv_magical */
1870 const char *end = name + len;
1871 while (--end > name) {
1872 if (!isDIGIT(*end)) goto add_magical_gv;
1879 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1880 be case '\0' in this switch statement (ie a default case) */
1885 #ifdef PERL_SAWAMPERSAND
1887 sv_type == SVt_PVAV ||
1888 sv_type == SVt_PVHV ||
1889 sv_type == SVt_PVCV ||
1890 sv_type == SVt_PVFM ||
1892 )) { PL_sawampersand |=
1896 ? SAWAMPERSAND_MIDDLE
1897 : SAWAMPERSAND_RIGHT;
1903 sv_setpv(GvSVn(gv),PL_chopset);
1907 #ifdef COMPLEX_STATUS
1908 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1914 /* If %! has been used, automatically load Errno.pm. */
1916 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1918 /* magicalization must be done before require_tie_mod is called */
1919 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1921 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1923 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1929 GvMULTI_on(gv); /* no used once warnings here */
1931 AV* const av = GvAVn(gv);
1932 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1934 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1935 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1937 SvREADONLY_on(GvSVn(gv));
1940 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1942 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1944 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1951 if (sv_type == SVt_PV)
1952 /* diag_listed_as: $* is no longer supported */
1953 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1954 "$%c is no longer supported", *name);
1956 case '\010': /* $^H */
1958 HV *const hv = GvHVn(gv);
1959 hv_magic(hv, NULL, PERL_MAGIC_hints);
1963 if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
1964 && FEATURE_ARYBASE_IS_ENABLED) {
1965 if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
1966 require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
1969 else goto magicalize;
1971 case '\023': /* $^S */
1973 SvREADONLY_on(GvSVn(gv));
1998 case '\001': /* $^A */
1999 case '\003': /* $^C */
2000 case '\004': /* $^D */
2001 case '\005': /* $^E */
2002 case '\006': /* $^F */
2003 case '\011': /* $^I, NOT \t in EBCDIC */
2004 case '\016': /* $^N */
2005 case '\017': /* $^O */
2006 case '\020': /* $^P */
2007 case '\024': /* $^T */
2008 case '\027': /* $^W */
2010 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
2013 case '\014': /* $^L */
2014 sv_setpvs(GvSVn(gv),"\f");
2017 sv_setpvs(GvSVn(gv),"\034");
2021 SV * const sv = GvSV(gv);
2022 if (!sv_derived_from(PL_patchlevel, "version"))
2023 upg_version(PL_patchlevel, TRUE);
2024 GvSV(gv) = vnumify(PL_patchlevel);
2025 SvREADONLY_on(GvSV(gv));
2029 case '\026': /* $^V */
2031 SV * const sv = GvSV(gv);
2032 GvSV(gv) = new_version(PL_patchlevel);
2033 SvREADONLY_on(GvSV(gv));
2041 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
2042 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
2044 (void)hv_store(stash,name,len,(SV *)gv,0);
2045 else SvREFCNT_dec_NN(gv), gv = NULL;
2047 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
2052 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2055 const HV * const hv = GvSTASH(gv);
2057 PERL_ARGS_ASSERT_GV_FULLNAME4;
2059 sv_setpv(sv, prefix ? prefix : "");
2061 if (hv && (name = HvNAME(hv))) {
2062 const STRLEN len = HvNAMELEN(hv);
2063 if (keepmain || strnNE(name, "main", len)) {
2064 sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
2068 else sv_catpvs(sv,"__ANON__::");
2069 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2073 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2075 const GV * const egv = GvEGVx(gv);
2077 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2079 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2083 Perl_gv_check(pTHX_ HV *stash)
2088 PERL_ARGS_ASSERT_GV_CHECK;
2090 if (!HvARRAY(stash))
2092 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2094 /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
2095 are currently searching through recursively. */
2097 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2100 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2101 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2103 if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
2104 gv_check(hv); /* nested package */
2106 else if ( *HeKEY(entry) != '_'
2107 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2109 gv = MUTABLE_GV(HeVAL(entry));
2110 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2113 CopLINE_set(PL_curcop, GvLINE(gv));
2115 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2117 CopFILEGV(PL_curcop)
2118 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2120 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2121 "Name \"%"HEKf"::%"HEKf
2122 "\" used only once: possible typo",
2123 HEKfARG(HvNAME_HEK(stash)),
2124 HEKfARG(GvNAME_HEK(gv)));
2132 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2135 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2136 assert(!(flags & ~SVf_UTF8));
2138 return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
2139 UTF8fARG(flags, strlen(pack), pack),
2144 /* hopefully this is only called on local symbol table entries */
2147 Perl_gp_ref(pTHX_ GP *gp)
2155 /* If the GP they asked for a reference to contains
2156 a method cache entry, clear it first, so that we
2157 don't infect them with our cached entry */
2158 SvREFCNT_dec_NN(gp->gp_cv);
2167 Perl_gp_free(pTHX_ GV *gv)
2173 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2175 if (gp->gp_refcnt == 0) {
2176 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2177 "Attempt to free unreferenced glob pointers"
2178 pTHX__FORMAT pTHX__VALUE);
2181 if (--gp->gp_refcnt > 0) {
2182 if (gp->gp_egv == gv)
2189 /* Copy and null out all the glob slots, so destructors do not see
2191 HEK * const file_hek = gp->gp_file_hek;
2192 SV * const sv = gp->gp_sv;
2193 AV * const av = gp->gp_av;
2194 HV * const hv = gp->gp_hv;
2195 IO * const io = gp->gp_io;
2196 CV * const cv = gp->gp_cv;
2197 CV * const form = gp->gp_form;
2199 gp->gp_file_hek = NULL;
2208 unshare_hek(file_hek);
2212 /* FIXME - another reference loop GV -> symtab -> GV ?
2213 Somehow gp->gp_hv can end up pointing at freed garbage. */
2214 if (hv && SvTYPE(hv) == SVt_PVHV) {
2215 const HEK *hvname_hek = HvNAME_HEK(hv);
2216 DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
2217 if (PL_stashcache && hvname_hek)
2218 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2219 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2227 if (!gp->gp_file_hek
2233 && !gp->gp_form) break;
2235 if (--attempts == 0) {
2237 "panic: gp_free failed to free glob pointer - "
2238 "something is repeatedly re-creating entries"
2248 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2250 AMT * const amtp = (AMT*)mg->mg_ptr;
2251 PERL_UNUSED_ARG(sv);
2253 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2255 if (amtp && AMT_AMAGIC(amtp)) {
2257 for (i = 1; i < NofAMmeth; i++) {
2258 CV * const cv = amtp->table[i];
2260 SvREFCNT_dec_NN(MUTABLE_SV(cv));
2261 amtp->table[i] = NULL;
2268 /* Updates and caches the CV's */
2270 * 1 on success and there is some overload
2271 * 0 if there is no overload
2272 * -1 if some error occurred and it couldn't croak
2276 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2279 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2281 const struct mro_meta* stash_meta = HvMROMETA(stash);
2284 PERL_ARGS_ASSERT_GV_AMUPDATE;
2286 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2288 const AMT * const amtp = (AMT*)mg->mg_ptr;
2289 if (amtp->was_ok_sub == newgen) {
2290 return AMT_AMAGIC(amtp) ? 1 : 0;
2292 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2295 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2298 amt.was_ok_sub = newgen;
2299 amt.fallback = AMGfallNO;
2306 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2308 /* Try to find via inheritance. */
2309 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2310 SV * const sv = gv ? GvSV(gv) : NULL;
2315 if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0))
2318 #ifdef PERL_DONT_CREATE_GVSV
2320 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2323 else if (SvTRUE(sv))
2324 /* don't need to set overloading here because fallback => 1
2325 * is the default setting for classes without overloading */
2326 amt.fallback=AMGfallYES;
2327 else if (SvOK(sv)) {
2328 amt.fallback=AMGfallNEVER;
2335 for (i = 1; i < NofAMmeth; i++) {
2336 const char * const cooky = PL_AMG_names[i];
2337 /* Human-readable form, for debugging: */
2338 const char * const cp = AMG_id2name(i);
2339 const STRLEN l = PL_AMG_namelens[i];
2341 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2342 cp, HvNAME_get(stash)) );
2343 /* don't fill the cache while looking up!
2344 Creation of inheritance stubs in intermediate packages may
2345 conflict with the logic of runtime method substitution.
2346 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2347 then we could have created stubs for "(+0" in A and C too.
2348 But if B overloads "bool", we may want to use it for
2349 numifying instead of C's "+0". */
2350 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2352 if (gv && (cv = GvCV(gv))) {
2353 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2354 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2355 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2356 && strEQ(hvname, "overload")) {
2357 /* This is a hack to support autoloading..., while
2358 knowing *which* methods were declared as overloaded. */
2359 /* GvSV contains the name of the method. */
2361 SV *gvsv = GvSV(gv);
2363 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2364 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2365 (void*)GvSV(gv), cp, HvNAME(stash)) );
2366 if (!gvsv || !SvPOK(gvsv)
2367 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2369 /* Can be an import stub (created by "can"). */
2374 const SV * const name = (gvsv && SvPOK(gvsv))
2376 : newSVpvs_flags("???", SVs_TEMP);
2377 /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
2378 Perl_croak(aTHX_ "%s method \"%"SVf256
2379 "\" overloading \"%s\" "\
2380 "in package \"%"HEKf256"\"",
2381 (GvCVGEN(gv) ? "Stub found while resolving"
2389 cv = GvCV(gv = ngv);
2392 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2393 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2394 GvNAME(CvGV(cv))) );
2396 } else if (gv) { /* Autoloaded... */
2397 cv = MUTABLE_CV(gv);
2400 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2403 AMT_AMAGIC_on(&amt);
2404 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2405 (char*)&amt, sizeof(AMT));
2409 /* Here we have no table: */
2411 AMT_AMAGIC_off(&amt);
2412 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2413 (char*)&amt, sizeof(AMTS));
2419 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2425 struct mro_meta* stash_meta;
2427 if (!stash || !HvNAME_get(stash))
2430 stash_meta = HvMROMETA(stash);
2431 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2433 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2436 if (Gv_AMupdate(stash, 0) == -1)
2438 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2441 amtp = (AMT*)mg->mg_ptr;
2442 if ( amtp->was_ok_sub != newgen )
2444 if (AMT_AMAGIC(amtp)) {
2445 CV * const ret = amtp->table[id];
2446 if (ret && isGV(ret)) { /* Autoloading stab */
2447 /* Passing it through may have resulted in a warning
2448 "Inherited AUTOLOAD for a non-method deprecated", since
2449 our caller is going through a function call, not a method call.
2450 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2451 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2463 /* Implement tryAMAGICun_MG macro.
2464 Do get magic, then see if the stack arg is overloaded and if so call it.
2466 AMGf_set return the arg using SETs rather than assigning to
2468 AMGf_numeric apply sv_2num to the stack arg.
2472 Perl_try_amagic_un(pTHX_ int method, int flags) {
2476 SV* const arg = TOPs;
2480 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2481 AMGf_noright | AMGf_unary))) {
2482 if (flags & AMGf_set) {
2487 if (SvPADMY(TARG)) {
2488 sv_setsv(TARG, tmpsv);
2498 if ((flags & AMGf_numeric) && SvROK(arg))
2504 /* Implement tryAMAGICbin_MG macro.
2505 Do get magic, then see if the two stack args are overloaded and if so
2508 AMGf_set return the arg using SETs rather than assigning to
2510 AMGf_assign op may be called as mutator (eg +=)
2511 AMGf_numeric apply sv_2num to the stack arg.
2515 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2518 SV* const left = TOPm1s;
2519 SV* const right = TOPs;
2525 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2526 SV * const tmpsv = amagic_call(left, right, method,
2527 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2529 if (flags & AMGf_set) {
2536 if (opASSIGN || SvPADMY(TARG)) {
2537 sv_setsv(TARG, tmpsv);
2547 if(left==right && SvGMAGICAL(left)) {
2548 SV * const left = sv_newmortal();
2550 /* Print the uninitialized warning now, so it includes the vari-
2553 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2554 sv_setsv_flags(left, &PL_sv_no, 0);
2556 else sv_setsv_flags(left, right, 0);
2559 if (flags & AMGf_numeric) {
2561 *(sp-1) = sv_2num(TOPm1s);
2563 *sp = sv_2num(right);
2569 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2572 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2574 while (SvAMAGIC(ref) &&
2575 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2576 AMGf_noright | AMGf_unary))) {
2578 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2579 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2580 /* Bail out if it returns us the same reference. */
2585 return tmpsv ? tmpsv : ref;
2589 Perl_amagic_is_enabled(pTHX_ int method)
2591 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2593 assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
2595 if ( !lex_mask || !SvOK(lex_mask) )
2596 /* overloading lexically disabled */
2598 else if ( lex_mask && SvPOK(lex_mask) ) {
2599 /* we have an entry in the hints hash, check if method has been
2600 * masked by overloading.pm */
2602 const int offset = method / 8;
2603 const int bit = method % 8;
2604 char *pv = SvPV(lex_mask, len);
2606 /* Bit set, so this overloading operator is disabled */
2607 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2614 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2619 CV **cvp=NULL, **ocvp=NULL;
2620 AMT *amtp=NULL, *oamtp=NULL;
2621 int off = 0, off1, lr = 0, notfound = 0;
2622 int postpr = 0, force_cpy = 0;
2623 int assign = AMGf_assign & flags;
2624 const int assignshift = assign ? 1 : 0;
2625 int use_default_op = 0;
2626 int force_scalar = 0;
2632 PERL_ARGS_ASSERT_AMAGIC_CALL;
2634 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2635 if (!amagic_is_enabled(method)) return NULL;
2638 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2639 && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)
2640 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2641 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2642 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2644 && ((cv = cvp[off=method+assignshift])
2645 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2651 cv = cvp[off=method])))) {
2652 lr = -1; /* Call method for left argument */
2654 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2657 /* look for substituted methods */
2658 /* In all the covered cases we should be called with assign==0. */
2662 if ((cv = cvp[off=add_ass_amg])
2663 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2664 right = &PL_sv_yes; lr = -1; assign = 1;
2669 if ((cv = cvp[off = subtr_ass_amg])
2670 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2671 right = &PL_sv_yes; lr = -1; assign = 1;
2675 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2678 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2681 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2684 (void)((cv = cvp[off=bool__amg])
2685 || (cv = cvp[off=numer_amg])
2686 || (cv = cvp[off=string_amg]));
2693 * SV* ref causes confusion with the interpreter variable of
2696 SV* const tmpRef=SvRV(left);
2697 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2699 * Just to be extra cautious. Maybe in some
2700 * additional cases sv_setsv is safe, too.
2702 SV* const newref = newSVsv(tmpRef);
2703 SvOBJECT_on(newref);
2704 /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
2705 delegate to the stash. */
2706 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2712 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2713 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2714 SV* const nullsv=sv_2mortal(newSViv(0));
2716 SV* const lessp = amagic_call(left,nullsv,
2717 lt_amg,AMGf_noright);
2718 logic = SvTRUE(lessp);
2720 SV* const lessp = amagic_call(left,nullsv,
2721 ncmp_amg,AMGf_noright);
2722 logic = (SvNV(lessp) < 0);
2725 if (off==subtr_amg) {
2736 if ((cv = cvp[off=subtr_amg])) {
2738 left = sv_2mortal(newSViv(0));
2743 case iter_amg: /* XXXX Eventually should do to_gv. */
2744 case ftest_amg: /* XXXX Eventually should do to_gv. */
2747 return NULL; /* Delegate operation to standard mechanisms. */
2755 return left; /* Delegate operation to standard mechanisms. */
2760 if (!cv) goto not_found;
2761 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2762 && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)
2763 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2764 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2765 ? (amtp = (AMT*)mg->mg_ptr)->table
2767 && (cv = cvp[off=method])) { /* Method for right
2770 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2771 || (ocvp && oamtp->fallback > AMGfallNEVER))
2772 && !(flags & AMGf_unary)) {
2773 /* We look for substitution for
2774 * comparison operations and
2776 if (method==concat_amg || method==concat_ass_amg
2777 || method==repeat_amg || method==repeat_ass_amg) {
2778 return NULL; /* Delegate operation to string conversion */
2800 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2804 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2814 not_found: /* No method found, either report or croak */
2822 return left; /* Delegate operation to standard mechanisms. */
2825 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2826 notfound = 1; lr = -1;
2827 } else if (cvp && (cv=cvp[nomethod_amg])) {
2828 notfound = 1; lr = 1;
2829 } else if ((use_default_op =
2830 (!ocvp || oamtp->fallback >= AMGfallYES)
2831 && (!cvp || amtp->fallback >= AMGfallYES))
2833 /* Skip generating the "no method found" message. */
2837 if (off==-1) off=method;
2838 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2839 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2840 AMG_id2name(method + assignshift),
2841 (flags & AMGf_unary ? " " : "\n\tleft "),
2843 "in overloaded package ":
2844 "has no overloaded magic",
2846 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2849 ",\n\tright argument in overloaded package ":
2852 : ",\n\tright argument has no overloaded magic"),
2854 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2855 SVfARG(&PL_sv_no)));
2856 if (use_default_op) {
2857 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2859 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2863 force_cpy = force_cpy || assign;
2868 /* in these cases, we're calling '+' or '-' as a fallback for a ++ or --
2869 * operation. we need this to return a value, so that it can be assigned
2870 * later on, in the postpr block (case inc_amg/dec_amg), even if the
2871 * increment or decrement was itself called in void context */
2877 if (off == subtr_amg)
2880 /* in these cases, we're calling an assignment variant of an operator
2881 * (+= rather than +, for instance). regardless of whether it's a
2882 * fallback or not, it always has to return a value, which will be
2883 * assigned to the proper variable later */
2900 /* the copy constructor always needs to return a value */
2904 /* because of the way these are implemented (they don't perform the
2905 * dereferencing themselves, they return a reference that perl then
2906 * dereferences later), they always have to be in scalar context */
2914 /* these don't have an op of their own; they're triggered by their parent
2915 * op, so the context there isn't meaningful ('$a and foo()' in void
2916 * context still needs to pass scalar context on to $a's bool overload) */
2926 DEBUG_o(Perl_deb(aTHX_
2927 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2929 method+assignshift==off? "" :
2931 method+assignshift==off? "" :
2932 AMG_id2name(method+assignshift),
2933 method+assignshift==off? "" : "\")",
2934 flags & AMGf_unary? "" :
2935 lr==1 ? " for right argument": " for left argument",
2936 flags & AMGf_unary? " for argument" : "",
2937 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2938 fl? ",\n\tassignment variant used": "") );
2941 /* Since we use shallow copy during assignment, we need
2942 * to dublicate the contents, probably calling user-supplied
2943 * version of copy operator
2945 /* We need to copy in following cases:
2946 * a) Assignment form was called.
2947 * assignshift==1, assign==T, method + 1 == off
2948 * b) Increment or decrement, called directly.
2949 * assignshift==0, assign==0, method + 0 == off
2950 * c) Increment or decrement, translated to assignment add/subtr.
2951 * assignshift==0, assign==T,
2953 * d) Increment or decrement, translated to nomethod.
2954 * assignshift==0, assign==0,
2956 * e) Assignment form translated to nomethod.
2957 * assignshift==1, assign==T, method + 1 != off
2960 /* off is method, method+assignshift, or a result of opcode substitution.
2961 * In the latter case assignshift==0, so only notfound case is important.
2963 if ( (lr == -1) && ( ( (method + assignshift == off)
2964 && (assign || (method == inc_amg) || (method == dec_amg)))
2967 /* newSVsv does not behave as advertised, so we copy missing
2968 * information by hand */
2969 SV *tmpRef = SvRV(left);
2971 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2972 SvRV_set(left, rv_copy);
2974 SvREFCNT_dec_NN(tmpRef);
2982 const bool oldcatch = CATCH_GET;
2984 int gimme = force_scalar ? G_SCALAR : GIMME_V;
2987 Zero(&myop, 1, BINOP);
2988 myop.op_last = (OP *) &myop;
2989 myop.op_next = NULL;
2990 myop.op_flags = OPf_STACKED;
2994 myop.op_flags |= OPf_WANT_VOID;
2997 if (flags & AMGf_want_list) {
2998 myop.op_flags |= OPf_WANT_LIST;
3003 myop.op_flags |= OPf_WANT_SCALAR;
3007 PUSHSTACKi(PERLSI_OVERLOAD);
3010 PL_op = (OP *) &myop;
3011 if (PERLDB_SUB && PL_curstash != PL_debstash)
3012 PL_op->op_private |= OPpENTERSUB_DB;
3014 Perl_pp_pushmark(aTHX);
3016 EXTEND(SP, notfound + 5);
3017 PUSHs(lr>0? right: left);
3018 PUSHs(lr>0? left: right);
3019 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
3021 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
3022 AMG_id2namelen(method + assignshift), SVs_TEMP));
3024 PUSHs(MUTABLE_SV(cv));
3028 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
3032 nret = SP - (PL_stack_base + oldmark);
3036 /* returning NULL has another meaning, and we check the context
3037 * at the call site too, so this can be differentiated from the
3040 SP = PL_stack_base + oldmark;
3043 if (flags & AMGf_want_list) {
3044 res = sv_2mortal((SV *)newAV());
3045 av_extend((AV *)res, nret);
3047 av_store((AV *)res, nret, POPs);
3059 CATCH_SET(oldcatch);
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 ans=SvIV(res)==0; break;
3081 ans=SvIV(res)!=0; break;
3084 SvSetSV(left,res); return left;
3086 ans=!SvTRUE(res); break;
3091 } else if (method==copy_amg) {
3093 Perl_croak(aTHX_ "Copy method did not return a reference");
3095 return SvREFCNT_inc(SvRV(res));
3103 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
3108 PERL_ARGS_ASSERT_GV_NAME_SET;
3111 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
3113 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
3114 unshare_hek(GvNAME_HEK(gv));
3117 PERL_HASH(hash, name, len);
3118 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
3122 =for apidoc gv_try_downgrade
3124 If the typeglob C<gv> can be expressed more succinctly, by having
3125 something other than a real GV in its place in the stash, replace it
3126 with the optimised form. Basic requirements for this are that C<gv>
3127 is a real typeglob, is sufficiently ordinary, and is only referenced
3128 from its package. This function is meant to be used when a GV has been
3129 looked up in part to see what was there, causing upgrading, but based
3130 on what was found it turns out that the real GV isn't required after all.
3132 If C<gv> is a completely empty typeglob, it is deleted from the stash.
3134 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
3135 sub, the typeglob is replaced with a scalar-reference placeholder that
3136 more compactly represents the same thing.
3142 Perl_gv_try_downgrade(pTHX_ GV *gv)
3148 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
3150 /* XXX Why and where does this leave dangling pointers during global
3152 if (PL_phase == PERL_PHASE_DESTRUCT) return;
3154 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
3155 !SvOBJECT(gv) && !SvREADONLY(gv) &&
3156 isGV_with_GP(gv) && GvGP(gv) &&
3157 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
3158 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
3159 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
3161 if (SvMAGICAL(gv)) {
3163 /* only backref magic is allowed */
3164 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3166 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3167 if (mg->mg_type != PERL_MAGIC_backref)
3173 HEK *gvnhek = GvNAME_HEK(gv);
3174 (void)hv_delete(stash, HEK_KEY(gvnhek),
3175 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3176 } else if (GvMULTI(gv) && cv &&
3177 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3178 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3179 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3180 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3181 (namehek = GvNAME_HEK(gv)) &&
3182 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3183 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3185 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3186 const bool imported = !!GvIMPORTED_CV(gv);
3190 SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
3191 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3192 STRUCT_OFFSET(XPVIV, xiv_iv));
3193 SvRV_set(gv, value);
3200 core_xsub(pTHX_ CV* cv)
3203 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3209 * c-indentation-style: bsd
3211 * indent-tabs-mode: nil
3214 * ex: set ts=8 sts=4 sw=4 et: