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.
41 static const char S_autoload[] = "AUTOLOAD";
42 static const STRLEN S_autolen = sizeof(S_autoload)-1;
45 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
52 SvTYPE((const SV *)gv) != SVt_PVGV
53 && SvTYPE((const SV *)gv) != SVt_PVLV
57 if (type == SVt_PVIO) {
59 * if it walks like a dirhandle, then let's assume that
60 * this is a dirhandle.
62 what = OP_IS_DIRHOP(PL_op->op_type) ?
63 "dirhandle" : "filehandle";
64 /* diag_listed_as: Bad symbol for filehandle */
65 } else if (type == SVt_PVHV) {
68 what = type == SVt_PVAV ? "array" : "scalar";
70 Perl_croak(aTHX_ "Bad symbol for %s", what);
73 if (type == SVt_PVHV) {
74 where = (SV **)&GvHV(gv);
75 } else if (type == SVt_PVAV) {
76 where = (SV **)&GvAV(gv);
77 } else if (type == SVt_PVIO) {
78 where = (SV **)&GvIOp(gv);
84 *where = newSV_type(type);
89 Perl_gv_fetchfile(pTHX_ const char *name)
91 PERL_ARGS_ASSERT_GV_FETCHFILE;
92 return gv_fetchfile_flags(name, strlen(name), 0);
96 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
102 const STRLEN tmplen = namelen + 2;
105 PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
106 PERL_UNUSED_ARG(flags);
111 if (tmplen <= sizeof smallbuf)
114 Newx(tmpbuf, tmplen, char);
115 /* This is where the debugger's %{"::_<$filename"} hash is created */
118 memcpy(tmpbuf + 2, name, namelen);
119 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
121 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
122 #ifdef PERL_DONT_CREATE_GVSV
123 GvSV(gv) = newSVpvn(name, namelen);
125 sv_setpvn(GvSV(gv), name, namelen);
128 if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
129 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
130 if (tmpbuf != smallbuf)
136 =for apidoc gv_const_sv
138 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
139 inlining, or C<gv> is a placeholder reference that would be promoted to such
140 a typeglob, then returns the value returned by the sub. Otherwise, returns
147 Perl_gv_const_sv(pTHX_ GV *gv)
149 PERL_ARGS_ASSERT_GV_CONST_SV;
151 if (SvTYPE(gv) == SVt_PVGV)
152 return cv_const_sv(GvCVu(gv));
153 return SvROK(gv) ? SvRV(gv) : NULL;
157 Perl_newGP(pTHX_ GV *const gv)
162 const char *const file
163 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
164 const STRLEN len = strlen(file);
166 SV *const temp_sv = CopFILESV(PL_curcop);
170 PERL_ARGS_ASSERT_NEWGP;
173 file = SvPVX(temp_sv);
174 len = SvCUR(temp_sv);
181 PERL_HASH(hash, file, len);
185 #ifndef PERL_DONT_CREATE_GVSV
186 gp->gp_sv = newSV(0);
189 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
190 /* XXX Ideally this cast would be replaced with a change to const char*
192 gp->gp_file_hek = share_hek(file, len, hash);
199 /* Assign CvGV(cv) = gv, handling weak references.
200 * See also S_anonymise_cv_maybe */
203 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
205 GV * const oldgv = CvGV(cv);
206 PERL_ARGS_ASSERT_CVGV_SET;
217 sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
221 SvANY(cv)->xcv_gv = gv;
222 assert(!CvCVGV_RC(cv));
227 if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
228 Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
231 SvREFCNT_inc_simple_void_NN(gv);
235 /* Assign CvSTASH(cv) = st, handling weak references. */
238 Perl_cvstash_set(pTHX_ CV *cv, HV *st)
240 HV *oldst = CvSTASH(cv);
241 PERL_ARGS_ASSERT_CVSTASH_SET;
245 sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv));
246 SvANY(cv)->xcv_stash = st;
248 Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv));
252 =for apidoc gv_init_pvn
254 Converts a scalar into a typeglob. This is an incoercible typeglob;
255 assigning a reference to it will assign to one of its slots, instead of
256 overwriting it as happens with typeglobs created by SvSetSV. Converting
257 any scalar that is SvOK() may produce unpredictable results and is reserved
258 for perl's internal use.
260 C<gv> is the scalar to be converted.
262 C<stash> is the parent stash/package, if any.
264 C<name> and C<len> give the name. The name must be unqualified;
265 that is, it must not include the package name. If C<gv> is a
266 stash element, it is the caller's responsibility to ensure that the name
267 passed to this function matches the name of the element. If it does not
268 match, perl's internal bookkeeping will get out of sync.
270 C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
271 the return value of SvUTF8(sv). It can also take the
272 GV_ADDMULTI flag, which means to pretend that the GV has been
273 seen before (i.e., suppress "Used once" warnings).
277 The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
278 has no flags parameter. If the C<multi> parameter is set, the
279 GV_ADDMULTI flag will be passed to gv_init_pvn().
281 =for apidoc gv_init_pv
283 Same as gv_init_pvn(), but takes a nul-terminated string for the name
284 instead of separate char * and length parameters.
286 =for apidoc gv_init_sv
288 Same as gv_init_pvn(), but takes an SV * for the name instead of separate
289 char * and length parameters. C<flags> is currently unused.
295 Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags)
299 PERL_ARGS_ASSERT_GV_INIT_SV;
300 namepv = SvPV(namesv, namelen);
303 gv_init_pvn(gv, stash, namepv, namelen, flags);
307 Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
309 PERL_ARGS_ASSERT_GV_INIT_PV;
310 gv_init_pvn(gv, stash, name, strlen(name), flags);
314 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
317 const U32 old_type = SvTYPE(gv);
318 const bool doproto = old_type > SVt_NULL;
319 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
320 const STRLEN protolen = proto ? SvCUR(gv) : 0;
321 const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
322 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
323 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
325 PERL_ARGS_ASSERT_GV_INIT_PVN;
326 assert (!(proto && has_constant));
329 /* The constant has to be a simple scalar type. */
330 switch (SvTYPE(has_constant)) {
336 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
337 sv_reftype(has_constant, 0));
345 if (old_type < SVt_PVGV) {
346 if (old_type >= SVt_PV)
348 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
356 Safefree(SvPVX_mutable(gv));
361 GvGP_set(gv, Perl_newGP(aTHX_ gv));
364 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
365 gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
366 if (flags & GV_ADDMULTI || doproto) /* doproto means it */
367 GvMULTI_on(gv); /* _was_ mentioned */
368 if (doproto) { /* Replicate part of newSUB here. */
374 /* newCONSTSUB doesn't take a len arg, so make sure we
375 * give it a \0-terminated string */
376 name0 = savepvn(name,len);
378 /* newCONSTSUB takes ownership of the reference from us. */
379 cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant);
380 /* In case op.c:S_process_special_blocks stole it: */
382 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
383 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
386 /* If this reference was a copy of another, then the subroutine
387 must have been "imported", by a Perl space assignment to a GV
388 from a reference to CV. */
389 if (exported_constant)
390 GvIMPORTED_CV_on(gv);
392 (void) start_subparse(0,0); /* Create empty CV in compcv. */
398 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
400 CvFILE_set_from_cop(cv, PL_curcop);
401 CvSTASH_set(cv, PL_curstash);
403 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
404 SV_HAS_TRAILING_NUL);
405 if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
411 S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
413 PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
425 #ifdef PERL_DONT_CREATE_GVSV
433 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
434 If we just cast GvSVn(gv) to void, it ignores evaluating it for
441 static void core_xsub(pTHX_ CV* cv);
444 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
445 const char * const name, const STRLEN len,
446 const char * const fullname, STRLEN const fullen)
448 const int code = keyword(name, len, 1);
449 static const char file[] = __FILE__;
450 CV *cv, *oldcompcv = NULL;
453 bool ampable = TRUE; /* &{}-able */
454 COP *oldcurcop = NULL;
455 yy_parser *oldparser = NULL;
456 I32 oldsavestack_ix = 0;
460 assert(stash || fullname);
462 if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
464 inlining newATTRSUB */
465 if (code >= 0) return NULL; /* not overridable */
467 /* no support for \&CORE::infix;
468 no support for funcs that take labels, as their parsing is
470 case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
471 case KEY_eq: case KEY_ge:
472 case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
473 case KEY_or: case KEY_x: case KEY_xor:
476 case KEY_chomp: case KEY_chop:
477 case KEY_each: case KEY_eof: case KEY_exec:
486 case KEY_truncate: case KEY_unlink:
493 gv_init(gv, stash, name, len, TRUE);
497 oldcurcop = PL_curcop;
498 oldparser = PL_parser;
499 lex_start(NULL, NULL, 0);
500 oldcompcv = PL_compcv;
501 PL_compcv = NULL; /* Prevent start_subparse from setting
503 oldsavestack_ix = start_subparse(FALSE,0);
507 /* Avoid calling newXS, as it calls us, and things start to
509 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
512 mro_method_changed_in(GvSTASH(gv));
514 CvXSUB(cv) = core_xsub;
516 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
518 (void)gv_fetchfile(file);
519 CvFILE(cv) = (char *)file;
520 /* XXX This is inefficient, as doing things this order causes
521 a prototype check in newATTRSUB. But we have to do
522 it this order as we need an op number before calling
524 (void)core_prototype((SV *)cv, name, code, &opnum);
525 if (stash && (fullname || !fullen))
526 (void)hv_store(stash,name,len,(SV *)gv,0);
531 tmpstr = newSVhek(HvENAME_HEK(stash));
532 sv_catpvs(tmpstr, "::");
533 sv_catpvn(tmpstr,name,len);
535 else tmpstr = newSVpvn_share(fullname,fullen,0);
536 newATTRSUB(oldsavestack_ix,
537 newSVOP(OP_CONST, 0, tmpstr),
542 : newSVpvn(name,len),
546 assert(GvCV(gv) == cv);
547 if (opnum != OP_VEC && opnum != OP_SUBSTR)
548 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
550 PL_parser = oldparser;
551 PL_curcop = oldcurcop;
552 PL_compcv = oldcompcv;
554 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
556 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
558 SvREFCNT_dec(opnumsv);
563 =for apidoc gv_fetchmeth
565 Like L</gv_fetchmeth_pvn>, but lacks a flags parameter.
567 =for apidoc gv_fetchmeth_sv
569 Exactly like L</gv_fetchmeth_pvn>, but takes the name string in the form
570 of an SV instead of a string/length pair.
576 Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
580 PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
581 namepv = SvPV(namesv, namelen);
584 return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
588 =for apidoc gv_fetchmeth_pv
590 Exactly like L</gv_fetchmeth_pvn>, but takes a nul-terminated string
591 instead of a string/length pair.
597 Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
599 PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
600 return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
604 =for apidoc gv_fetchmeth_pvn
606 Returns the glob with the given C<name> and a defined subroutine or
607 C<NULL>. The glob lives in the given C<stash>, or in the stashes
608 accessible via @ISA and UNIVERSAL::.
610 The argument C<level> should be either 0 or -1. If C<level==0>, as a
611 side-effect creates a glob with the given C<name> in the given C<stash>
612 which in the case of success contains an alias for the subroutine, and sets
613 up caching info for this glob.
615 Currently, the only significant value for C<flags> is SVf_UTF8.
617 This function grants C<"SUPER"> token as a postfix of the stash name. The
618 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
619 visible to Perl code. So when calling C<call_sv>, you should not use
620 the GV directly; instead, you should use the method's CV, which can be
621 obtained from the GV with the C<GvCV> macro.
626 /* NOTE: No support for tied ISA */
629 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
637 GV* candidate = NULL;
641 I32 create = (level >= 0) ? 1 : 0;
645 U32 is_utf8 = flags & SVf_UTF8;
647 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
649 /* UNIVERSAL methods should be callable without a stash */
651 create = 0; /* probably appropriate */
652 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
658 hvname = HvNAME_get(stash);
660 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
665 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
667 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
669 /* check locally for a real method or a cache entry */
670 gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
675 if (SvTYPE(topgv) != SVt_PVGV)
676 gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
677 if ((cand_cv = GvCV(topgv))) {
678 /* If genuine method or valid cache entry, use it */
679 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
683 /* stale cache entry, junk it and move on */
684 SvREFCNT_dec(cand_cv);
685 GvCV_set(topgv, NULL);
690 else if (GvCVGEN(topgv) == topgen_cmp) {
691 /* cache indicates no such method definitively */
694 else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
695 && strnEQ(hvname, "CORE", 4)
696 && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
700 packlen = HvNAMELEN_get(stash);
701 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
704 basestash = gv_stashpvn(hvname, packlen,
705 GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
706 linear_av = mro_get_linear_isa(basestash);
709 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
712 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
713 items = AvFILLp(linear_av); /* no +1, to skip over self */
715 linear_sv = *linear_svp++;
717 cstash = gv_stashsv(linear_sv, 0);
720 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
721 "Can't locate package %"SVf" for @%"HEKf"::ISA",
723 HEKfARG(HvNAME_HEK(stash)));
729 gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
731 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
732 const char *hvname = HvNAME(cstash); assert(hvname);
733 if (strnEQ(hvname, "CORE", 4)
735 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
741 else candidate = *gvp;
744 if (SvTYPE(candidate) != SVt_PVGV)
745 gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8);
746 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
748 * Found real method, cache method in topgv if:
749 * 1. topgv has no synonyms (else inheritance crosses wires)
750 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
752 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
753 CV *old_cv = GvCV(topgv);
754 SvREFCNT_dec(old_cv);
755 SvREFCNT_inc_simple_void_NN(cand_cv);
756 GvCV_set(topgv, cand_cv);
757 GvCVGEN(topgv) = topgen_cmp;
763 /* Check UNIVERSAL without caching */
764 if(level == 0 || level == -1) {
765 candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags);
767 cand_cv = GvCV(candidate);
768 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
769 CV *old_cv = GvCV(topgv);
770 SvREFCNT_dec(old_cv);
771 SvREFCNT_inc_simple_void_NN(cand_cv);
772 GvCV_set(topgv, cand_cv);
773 GvCVGEN(topgv) = topgen_cmp;
779 if (topgv && GvREFCNT(topgv) == 1) {
780 /* cache the fact that the method is not defined */
781 GvCVGEN(topgv) = topgen_cmp;
788 =for apidoc gv_fetchmeth_autoload
790 This is the old form of L</gv_fetchmeth_pvn_autoload>, which has no flags
793 =for apidoc gv_fetchmeth_sv_autoload
795 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes the name string in the form
796 of an SV instead of a string/length pair.
802 Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
806 PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD;
807 namepv = SvPV(namesv, namelen);
810 return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags);
814 =for apidoc gv_fetchmeth_pv_autoload
816 Exactly like L</gv_fetchmeth_pvn_autoload>, but takes a nul-terminated string
817 instead of a string/length pair.
823 Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
825 PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD;
826 return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags);
830 =for apidoc gv_fetchmeth_pvn_autoload
832 Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
833 Returns a glob for the subroutine.
835 For an autoloaded subroutine without a GV, will create a GV even
836 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
837 of the result may be zero.
839 Currently, the only significant value for C<flags> is SVf_UTF8.
845 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
847 GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
849 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
856 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
857 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
859 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags)))
862 if (!(CvROOT(cv) || CvXSUB(cv)))
864 /* Have an autoload */
865 if (level < 0) /* Cannot do without a stub */
866 gv_fetchmeth_pvn(stash, name, len, 0, flags);
867 gvp = (GV**)hv_fetch(stash, name,
868 (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
877 =for apidoc gv_fetchmethod_autoload
879 Returns the glob which contains the subroutine to call to invoke the method
880 on the C<stash>. In fact in the presence of autoloading this may be the
881 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
884 The third parameter of C<gv_fetchmethod_autoload> determines whether
885 AUTOLOAD lookup is performed if the given method is not present: non-zero
886 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
887 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
888 with a non-zero C<autoload> parameter.
890 These functions grant C<"SUPER"> token as a prefix of the method name. Note
891 that if you want to keep the returned glob for a long time, you need to
892 check for it being "AUTOLOAD", since at the later time the call may load a
893 different subroutine due to $AUTOLOAD changing its value. Use the glob
894 created via a side effect to do this.
896 These functions have the same side-effects and as C<gv_fetchmeth> with
897 C<level==0>. C<name> should be writable if contains C<':'> or C<'
898 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
899 C<call_sv> apply equally to these functions.
905 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
912 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
914 stash = gv_stashpvn(name, namelen, flags);
915 if(stash) return stash;
917 /* If we must create it, give it an @ISA array containing
918 the real package this SUPER is for, so that it's tied
919 into the cache invalidation code correctly */
920 stash = gv_stashpvn(name, namelen, GV_ADD | flags);
921 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
923 gv_init(gv, stash, "ISA", 3, TRUE);
924 superisa = GvAVn(gv);
926 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
928 av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
929 strlen(CopSTASHPV(PL_curcop)),
930 CopSTASH_flags(PL_curcop)
933 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
934 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
941 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
943 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
945 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
949 Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags)
953 PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS;
954 namepv = SvPV(namesv, namelen);
957 return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags);
961 Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
963 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS;
964 return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags);
967 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
970 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
973 register const char *nend;
974 const char *nsplit = NULL;
977 const char * const origname = name;
978 SV *const error_report = MUTABLE_SV(stash);
979 const U32 autoload = flags & GV_AUTOLOAD;
980 const U32 do_croak = flags & GV_CROAK;
981 const U32 is_utf8 = flags & SVf_UTF8;
983 PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
985 if (SvTYPE(stash) < SVt_PVHV)
988 /* The only way stash can become NULL later on is if nsplit is set,
989 which in turn means that there is no need for a SVt_PVHV case
990 the error reporting code. */
993 for (nend = name; *nend || nend != (origname + len); nend++) {
998 else if (*nend == ':' && *(nend + 1) == ':') {
1004 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
1005 /* ->SUPER::method should really be looked up in original stash */
1006 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
1008 HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
1010 /* __PACKAGE__::SUPER stash should be autovivified */
1011 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
1012 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
1013 origname, HvNAME_get(stash), name) );
1016 /* don't autovifify if ->NoSuchStash::method */
1017 stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
1019 /* however, explicit calls to Pkg::SUPER::method may
1020 happen, and may require autovivification to work */
1021 if (!stash && (nsplit - origname) >= 7 &&
1022 strnEQ(nsplit - 7, "::SUPER", 7) &&
1023 gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
1024 stash = gv_get_super_pkg(origname, nsplit - origname, flags);
1029 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1031 if (strEQ(name,"import") || strEQ(name,"unimport"))
1032 gv = MUTABLE_GV(&PL_sv_yes);
1034 gv = gv_autoload_pvn(
1035 ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
1037 if (!gv && do_croak) {
1038 /* Right now this is exclusively for the benefit of S_method_common
1041 /* If we can't find an IO::File method, it might be a call on
1042 * a filehandle. If IO:File has not been loaded, try to
1043 * require it first instead of croaking */
1044 const char *stash_name = HvNAME_get(stash);
1045 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
1046 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
1047 STR_WITH_LEN("IO/File.pm"), 0,
1048 HV_FETCH_ISEXISTS, NULL, 0)
1050 require_pv("IO/File.pm");
1051 gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
1056 "Can't locate object method \"%"SVf
1057 "\" via package \"%"HEKf"\"",
1058 SVfARG(newSVpvn_flags(name, nend - name,
1059 SVs_TEMP | is_utf8)),
1060 HEKfARG(HvNAME_HEK(stash)));
1066 packnamesv = newSVpvn_flags(origname, nsplit - origname,
1067 SVs_TEMP | is_utf8);
1069 packnamesv = sv_2mortal(newSVsv(error_report));
1073 "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
1074 " (perhaps you forgot to load \"%"SVf"\"?)",
1075 SVfARG(newSVpvn_flags(name, nend - name,
1076 SVs_TEMP | is_utf8)),
1077 SVfARG(packnamesv), SVfARG(packnamesv));
1081 else if (autoload) {
1082 CV* const cv = GvCV(gv);
1083 if (!CvROOT(cv) && !CvXSUB(cv)) {
1091 if (GvCV(stubgv) != cv) /* orphaned import */
1094 autogv = gv_autoload_pvn(GvSTASH(stubgv),
1095 GvNAME(stubgv), GvNAMELEN(stubgv),
1096 GV_AUTOLOAD_ISMETHOD
1097 | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
1107 Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags)
1111 PERL_ARGS_ASSERT_GV_AUTOLOAD_SV;
1112 namepv = SvPV(namesv, namelen);
1115 return gv_autoload_pvn(stash, namepv, namelen, flags);
1119 Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
1121 PERL_ARGS_ASSERT_GV_AUTOLOAD_PV;
1122 return gv_autoload_pvn(stash, namepv, strlen(namepv), flags);
1126 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
1134 SV *packname = NULL;
1135 U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
1137 PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
1139 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
1142 if (SvTYPE(stash) < SVt_PVHV) {
1143 STRLEN packname_len = 0;
1144 const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
1145 packname = newSVpvn_flags(packname_ptr, packname_len,
1146 SVs_TEMP | SvUTF8(stash));
1150 packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
1152 if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
1156 if (!(CvROOT(cv) || CvXSUB(cv)))
1160 * Inheriting AUTOLOAD for non-methods works ... for now.
1163 !(flags & GV_AUTOLOAD_ISMETHOD)
1164 && (GvCVGEN(gv) || GvSTASH(gv) != stash)
1166 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1167 "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
1169 SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1172 /* rather than lookup/init $AUTOLOAD here
1173 * only to have the XSUB do another lookup for $AUTOLOAD
1174 * and split that value on the last '::',
1175 * pass along the same data via some unused fields in the CV
1177 CvSTASH_set(cv, stash);
1178 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
1186 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
1187 * The subroutine's original name may not be "AUTOLOAD", so we don't
1188 * use that, but for lack of anything better we will use the sub's
1189 * original package to look up $AUTOLOAD.
1191 varstash = GvSTASH(CvGV(cv));
1192 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
1196 gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0);
1197 #ifdef PERL_DONT_CREATE_GVSV
1198 GvSV(vargv) = newSV(0);
1202 varsv = GvSVn(vargv);
1203 sv_setsv(varsv, packname);
1204 sv_catpvs(varsv, "::");
1205 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
1206 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
1207 sv_catpvn_mg(varsv, name, len);
1214 /* require_tie_mod() internal routine for requiring a module
1215 * that implements the logic of automatic ties like %! and %-
1217 * The "gv" parameter should be the glob.
1218 * "varpv" holds the name of the var, used for error messages.
1219 * "namesv" holds the module name. Its refcount will be decremented.
1220 * "methpv" holds the method name to test for to check that things
1221 * are working reasonably close to as expected.
1222 * "flags": if flag & 1 then save the scalar before loading.
1223 * For the protection of $! to work (it is set by this routine)
1224 * the sv slot must already be magicalized.
1227 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1230 HV* stash = gv_stashsv(namesv, 0);
1232 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1234 if (!stash || !(gv_fetchmethod(stash, methpv))) {
1235 SV *module = newSVsv(namesv);
1236 char varname = *varpv; /* varpv might be clobbered by load_module,
1237 so save it. For the moment it's always
1243 PUSHSTACKi(PERLSI_MAGIC);
1244 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1248 stash = gv_stashsv(namesv, 0);
1250 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1251 varname, SVfARG(namesv));
1252 else if (!gv_fetchmethod(stash, methpv))
1253 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1254 varname, SVfARG(namesv), methpv);
1256 SvREFCNT_dec(namesv);
1261 =for apidoc gv_stashpv
1263 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1264 determine the length of C<name>, then calls C<gv_stashpvn()>.
1270 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1272 PERL_ARGS_ASSERT_GV_STASHPV;
1273 return gv_stashpvn(name, strlen(name), create);
1277 =for apidoc gv_stashpvn
1279 Returns a pointer to the stash for a specified package. The C<namelen>
1280 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1281 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1282 created if it does not already exist. If the package does not exist and
1283 C<flags> is 0 (or any other setting that does not create packages) then NULL
1291 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1297 U32 tmplen = namelen + 2;
1299 PERL_ARGS_ASSERT_GV_STASHPVN;
1301 if (tmplen <= sizeof smallbuf)
1304 Newx(tmpbuf, tmplen, char);
1305 Copy(name, tmpbuf, namelen, char);
1306 tmpbuf[namelen] = ':';
1307 tmpbuf[namelen+1] = ':';
1308 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1309 if (tmpbuf != smallbuf)
1313 stash = GvHV(tmpgv);
1314 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1316 if (!HvNAME_get(stash)) {
1317 hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 );
1319 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1320 /* If the containing stash has multiple effective
1321 names, see that this one gets them, too. */
1322 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1323 mro_package_moved(stash, NULL, tmpgv, 1);
1329 =for apidoc gv_stashsv
1331 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
1337 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1340 const char * const ptr = SvPV_const(sv,len);
1342 PERL_ARGS_ASSERT_GV_STASHSV;
1344 return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
1349 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1350 PERL_ARGS_ASSERT_GV_FETCHPV;
1351 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1355 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1357 const char * const nambeg =
1358 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1359 PERL_ARGS_ASSERT_GV_FETCHSV;
1360 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1364 S_gv_magicalize_isa(pTHX_ GV *gv)
1368 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1372 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1377 S_gv_magicalize_overload(pTHX_ GV *gv)
1381 PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1385 hv_magic(hv, NULL, PERL_MAGIC_overload);
1389 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1390 const svtype sv_type)
1393 register const char *name = nambeg;
1394 register GV *gv = NULL;
1397 register const char *name_cursor;
1399 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1400 const I32 no_expand = flags & GV_NOEXPAND;
1401 const I32 add = flags & ~GV_NOADD_MASK;
1402 const U32 is_utf8 = flags & SVf_UTF8;
1403 bool addmg = !!(flags & GV_ADDMG);
1404 const char *const name_end = nambeg + full_len;
1405 const char *const name_em1 = name_end - 1;
1408 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1410 if (flags & GV_NOTQUAL) {
1411 /* Caller promised that there is no stash, so we can skip the check. */
1416 if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
1417 /* accidental stringify on a GV? */
1421 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1422 if (name_cursor < name_em1 &&
1423 ((*name_cursor == ':'
1424 && name_cursor[1] == ':')
1425 || *name_cursor == '\''))
1428 stash = PL_defstash;
1429 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1432 len = name_cursor - name;
1433 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1435 if (*name_cursor == ':') {
1440 Newx(tmpbuf, len+2, char);
1441 Copy(name, tmpbuf, len, char);
1442 tmpbuf[len++] = ':';
1443 tmpbuf[len++] = ':';
1446 gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
1447 gv = gvp ? *gvp : NULL;
1448 if (gv && gv != (const GV *)&PL_sv_undef) {
1449 if (SvTYPE(gv) != SVt_PVGV)
1450 gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
1456 if (!gv || gv == (const GV *)&PL_sv_undef)
1459 if (!(stash = GvHV(gv)))
1461 stash = GvHV(gv) = newHV();
1462 if (!HvNAME_get(stash)) {
1463 if (GvSTASH(gv) == PL_defstash && len == 6
1464 && strnEQ(name, "CORE", 4))
1465 hv_name_set(stash, "CORE", 4, 0);
1468 stash, nambeg, name_cursor-nambeg, is_utf8
1470 /* If the containing stash has multiple effective
1471 names, see that this one gets them, too. */
1472 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1473 mro_package_moved(stash, NULL, gv, 1);
1476 else if (!HvNAME_get(stash))
1477 hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
1480 if (*name_cursor == ':')
1482 name = name_cursor+1;
1483 if (name == name_end)
1485 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1488 len = name_cursor - name;
1490 /* No stash in name, so see how we can default */
1494 if (len && isIDFIRST_lazy(name)) {
1495 bool global = FALSE;
1503 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1504 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1505 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1509 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1514 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1515 && name[3] == 'I' && name[4] == 'N')
1519 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1520 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1521 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1525 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1526 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1533 stash = PL_defstash;
1534 else if (IN_PERL_COMPILETIME) {
1535 stash = PL_curstash;
1536 if (add && (PL_hints & HINT_STRICT_VARS) &&
1537 sv_type != SVt_PVCV &&
1538 sv_type != SVt_PVGV &&
1539 sv_type != SVt_PVFM &&
1540 sv_type != SVt_PVIO &&
1541 !(len == 1 && sv_type == SVt_PV &&
1542 (*name == 'a' || *name == 'b')) )
1544 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
1546 *gvp == (const GV *)&PL_sv_undef ||
1547 SvTYPE(*gvp) != SVt_PVGV)
1551 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1552 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1553 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1555 SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
1556 /* diag_listed_as: Variable "%s" is not imported%s */
1558 aTHX_ packWARN(WARN_MISC),
1559 "Variable \"%c%"SVf"\" is not imported",
1560 sv_type == SVt_PVAV ? '@' :
1561 sv_type == SVt_PVHV ? '%' : '$',
1565 aTHX_ packWARN(WARN_MISC),
1566 "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
1573 stash = CopSTASH(PL_curcop);
1576 stash = PL_defstash;
1579 /* By this point we should have a stash and a name */
1583 SV * const err = Perl_mess(aTHX_
1584 "Global symbol \"%s%"SVf"\" requires explicit package name",
1585 (sv_type == SVt_PV ? "$"
1586 : sv_type == SVt_PVAV ? "@"
1587 : sv_type == SVt_PVHV ? "%"
1588 : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
1590 if (USE_UTF8_IN_NAMES)
1593 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1595 /* symbol table under destruction */
1604 if (!SvREFCNT(stash)) /* symbol table under destruction */
1607 gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
1608 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1609 if (addmg) gv = (GV *)newSV(0);
1612 else gv = *gvp, addmg = 0;
1613 /* From this point on, addmg means gv has not been inserted in the
1616 if (SvTYPE(gv) == SVt_PVGV) {
1619 gv_init_svtype(gv, sv_type);
1620 if (len == 1 && stash == PL_defstash
1621 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1623 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1624 else if (*name == '-' || *name == '+')
1625 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1627 else if (len == 3 && sv_type == SVt_PVAV
1628 && strnEQ(name, "ISA", 3)
1629 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1630 gv_magicalize_isa(gv);
1633 } else if (no_init) {
1636 } else if (no_expand && SvROK(gv)) {
1641 /* Adding a new symbol.
1642 Unless of course there was already something non-GV here, in which case
1643 we want to behave as if there was always a GV here, containing some sort
1645 Otherwise we run the risk of creating things like GvIO, which can cause
1646 subtle bugs. eg the one that tripped up SQL::Translator */
1648 faking_it = SvOK(gv);
1650 if (add & GV_ADDWARN)
1651 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
1652 SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
1653 gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
1655 if ( isIDFIRST_lazy_if(name, is_utf8)
1656 && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
1659 /* set up magic where warranted */
1660 if (stash != PL_defstash) { /* not the main stash */
1661 /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1662 and VERSION. All the others apply only to the main stash or to
1663 CORE (which is checked right after this). */
1665 const char * const name2 = name + 1;
1668 if (strnEQ(name2, "XPORT", 5))
1672 if (strEQ(name2, "SA"))
1673 gv_magicalize_isa(gv);
1676 if (strEQ(name2, "VERLOAD"))
1677 gv_magicalize_overload(gv);
1680 if (strEQ(name2, "ERSION"))
1686 goto add_magical_gv;
1689 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1690 /* Avoid null warning: */
1691 const char * const stashname = HvNAME(stash); assert(stashname);
1692 if (strnEQ(stashname, "CORE", 4)
1693 && S_maybe_add_coresub(aTHX_
1694 addmg ? stash : 0, gv, name, len, nambeg, full_len
1703 /* Nothing else to do.
1704 The compiler will probably turn the switch statement into a
1705 branch table. Make sure we avoid even that small overhead for
1706 the common case of lower case variable names. */
1710 const char * const name2 = name + 1;
1713 if (strEQ(name2, "RGV")) {
1714 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1716 else if (strEQ(name2, "RGVOUT")) {
1721 if (strnEQ(name2, "XPORT", 5))
1725 if (strEQ(name2, "SA")) {
1726 gv_magicalize_isa(gv);
1730 if (strEQ(name2, "VERLOAD")) {
1731 gv_magicalize_overload(gv);
1735 if (strEQ(name2, "IG")) {
1738 if (!PL_psig_name) {
1739 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1740 Newxz(PL_psig_pend, SIG_SIZE, int);
1741 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1743 /* I think that the only way to get here is to re-use an
1744 embedded perl interpreter, where the previous
1745 use didn't clean up fully because
1746 PL_perl_destruct_level was 0. I'm not sure that we
1747 "support" that, in that I suspect in that scenario
1748 there are sufficient other garbage values left in the
1749 interpreter structure that something else will crash
1750 before we get here. I suspect that this is one of
1751 those "doctor, it hurts when I do this" bugs. */
1752 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1753 Zero(PL_psig_pend, SIG_SIZE, int);
1757 hv_magic(hv, NULL, PERL_MAGIC_sig);
1758 for (i = 1; i < SIG_SIZE; i++) {
1759 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1761 sv_setsv(*init, &PL_sv_undef);
1766 if (strEQ(name2, "ERSION"))
1769 case '\003': /* $^CHILD_ERROR_NATIVE */
1770 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1773 case '\005': /* $^ENCODING */
1774 if (strEQ(name2, "NCODING"))
1777 case '\007': /* $^GLOBAL_PHASE */
1778 if (strEQ(name2, "LOBAL_PHASE"))
1781 case '\015': /* $^MATCH */
1782 if (strEQ(name2, "ATCH"))
1784 case '\017': /* $^OPEN */
1785 if (strEQ(name2, "PEN"))
1788 case '\020': /* $^PREMATCH $^POSTMATCH */
1789 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1792 case '\024': /* ${^TAINT} */
1793 if (strEQ(name2, "AINT"))
1796 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1797 if (strEQ(name2, "NICODE"))
1799 if (strEQ(name2, "TF8LOCALE"))
1801 if (strEQ(name2, "TF8CACHE"))
1804 case '\027': /* $^WARNING_BITS */
1805 if (strEQ(name2, "ARNING_BITS"))
1818 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1820 /* This snippet is taken from is_gv_magical */
1821 const char *end = name + len;
1822 while (--end > name) {
1823 if (!isDIGIT(*end)) goto add_magical_gv;
1830 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1831 be case '\0' in this switch statement (ie a default case) */
1837 sv_type == SVt_PVAV ||
1838 sv_type == SVt_PVHV ||
1839 sv_type == SVt_PVCV ||
1840 sv_type == SVt_PVFM ||
1843 PL_sawampersand = TRUE;
1847 sv_setpv(GvSVn(gv),PL_chopset);
1851 #ifdef COMPLEX_STATUS
1852 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1858 /* If %! has been used, automatically load Errno.pm. */
1860 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1862 /* magicalization must be done before require_tie_mod is called */
1863 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1864 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1869 GvMULTI_on(gv); /* no used once warnings here */
1871 AV* const av = GvAVn(gv);
1872 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1874 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1875 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1877 SvREADONLY_on(GvSVn(gv));
1880 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1881 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1887 if (sv_type == SVt_PV)
1888 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1889 "$%c is no longer supported", *name);
1892 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1895 case '\010': /* $^H */
1897 HV *const hv = GvHVn(gv);
1898 hv_magic(hv, NULL, PERL_MAGIC_hints);
1901 case '\023': /* $^S */
1903 SvREADONLY_on(GvSVn(gv));
1928 case '\001': /* $^A */
1929 case '\003': /* $^C */
1930 case '\004': /* $^D */
1931 case '\005': /* $^E */
1932 case '\006': /* $^F */
1933 case '\011': /* $^I, NOT \t in EBCDIC */
1934 case '\016': /* $^N */
1935 case '\017': /* $^O */
1936 case '\020': /* $^P */
1937 case '\024': /* $^T */
1938 case '\027': /* $^W */
1940 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1943 case '\014': /* $^L */
1944 sv_setpvs(GvSVn(gv),"\f");
1945 PL_formfeed = GvSVn(gv);
1948 sv_setpvs(GvSVn(gv),"\034");
1952 SV * const sv = GvSV(gv);
1953 if (!sv_derived_from(PL_patchlevel, "version"))
1954 upg_version(PL_patchlevel, TRUE);
1955 GvSV(gv) = vnumify(PL_patchlevel);
1956 SvREADONLY_on(GvSV(gv));
1960 case '\026': /* $^V */
1962 SV * const sv = GvSV(gv);
1963 GvSV(gv) = new_version(PL_patchlevel);
1964 SvREADONLY_on(GvSV(gv));
1972 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1973 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1975 (void)hv_store(stash,name,len,(SV *)gv,0);
1976 else SvREFCNT_dec(gv), gv = NULL;
1978 if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
1983 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1986 const HV * const hv = GvSTASH(gv);
1988 PERL_ARGS_ASSERT_GV_FULLNAME4;
1994 sv_setpv(sv, prefix ? prefix : "");
1996 name = HvNAME_get(hv)
1997 ? sv_2mortal(newSVhek(HvNAME_HEK(hv)))
1998 : newSVpvn_flags( "__ANON__", 8, SVs_TEMP );
2000 if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) {
2004 sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
2008 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
2010 const GV * const egv = GvEGVx(gv);
2012 PERL_ARGS_ASSERT_GV_EFULLNAME4;
2014 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
2018 Perl_gv_check(pTHX_ const HV *stash)
2023 PERL_ARGS_ASSERT_GV_CHECK;
2025 if (!HvARRAY(stash))
2027 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2029 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2032 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
2033 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
2035 if (hv != PL_defstash && hv != stash)
2036 gv_check(hv); /* nested package */
2038 else if ( *HeKEY(entry) != '_'
2039 && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
2041 gv = MUTABLE_GV(HeVAL(entry));
2042 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
2045 CopLINE_set(PL_curcop, GvLINE(gv));
2047 CopFILE(PL_curcop) = (char *)file; /* set for warning */
2049 CopFILEGV(PL_curcop)
2050 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
2052 Perl_warner(aTHX_ packWARN(WARN_ONCE),
2053 "Name \"%"HEKf"::%"HEKf
2054 "\" used only once: possible typo",
2055 HEKfARG(HvNAME_HEK(stash)),
2056 HEKfARG(GvNAME_HEK(gv)));
2063 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
2066 PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
2068 return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
2069 SVfARG(newSVpvn_flags(pack, strlen(pack),
2075 /* hopefully this is only called on local symbol table entries */
2078 Perl_gp_ref(pTHX_ GP *gp)
2086 /* If the GP they asked for a reference to contains
2087 a method cache entry, clear it first, so that we
2088 don't infect them with our cached entry */
2089 SvREFCNT_dec(gp->gp_cv);
2098 Perl_gp_free(pTHX_ GV *gv)
2104 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
2106 if (gp->gp_refcnt == 0) {
2107 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2108 "Attempt to free unreferenced glob pointers"
2109 pTHX__FORMAT pTHX__VALUE);
2112 if (--gp->gp_refcnt > 0) {
2113 if (gp->gp_egv == gv)
2120 /* Copy and null out all the glob slots, so destructors do not see
2122 HEK * const file_hek = gp->gp_file_hek;
2123 SV * const sv = gp->gp_sv;
2124 AV * const av = gp->gp_av;
2125 HV * const hv = gp->gp_hv;
2126 IO * const io = gp->gp_io;
2127 CV * const cv = gp->gp_cv;
2128 CV * const form = gp->gp_form;
2130 gp->gp_file_hek = NULL;
2139 unshare_hek(file_hek);
2143 /* FIXME - another reference loop GV -> symtab -> GV ?
2144 Somehow gp->gp_hv can end up pointing at freed garbage. */
2145 if (hv && SvTYPE(hv) == SVt_PVHV) {
2146 const HEK *hvname_hek = HvNAME_HEK(hv);
2147 if (PL_stashcache && hvname_hek)
2148 (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
2149 (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
2157 if (!gp->gp_file_hek
2163 && !gp->gp_form) break;
2165 if (--attempts == 0) {
2167 "panic: gp_free failed to free glob pointer - "
2168 "something is repeatedly re-creating entries"
2178 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
2180 AMT * const amtp = (AMT*)mg->mg_ptr;
2181 PERL_UNUSED_ARG(sv);
2183 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
2185 if (amtp && AMT_AMAGIC(amtp)) {
2187 for (i = 1; i < NofAMmeth; i++) {
2188 CV * const cv = amtp->table[i];
2190 SvREFCNT_dec(MUTABLE_SV(cv));
2191 amtp->table[i] = NULL;
2198 /* Updates and caches the CV's */
2200 * 1 on success and there is some overload
2201 * 0 if there is no overload
2202 * -1 if some error occurred and it couldn't croak
2206 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
2209 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2211 const struct mro_meta* stash_meta = HvMROMETA(stash);
2214 PERL_ARGS_ASSERT_GV_AMUPDATE;
2216 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2218 const AMT * const amtp = (AMT*)mg->mg_ptr;
2219 if (amtp->was_ok_am == PL_amagic_generation
2220 && amtp->was_ok_sub == newgen) {
2221 return AMT_OVERLOADED(amtp) ? 1 : 0;
2223 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2226 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2229 amt.was_ok_am = PL_amagic_generation;
2230 amt.was_ok_sub = newgen;
2231 amt.fallback = AMGfallNO;
2235 int filled = 0, have_ovl = 0;
2238 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2240 /* Try to find via inheritance. */
2241 GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
2242 SV * const sv = gv ? GvSV(gv) : NULL;
2246 lim = DESTROY_amg; /* Skip overloading entries. */
2247 #ifdef PERL_DONT_CREATE_GVSV
2249 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2252 else if (SvTRUE(sv))
2253 amt.fallback=AMGfallYES;
2255 amt.fallback=AMGfallNEVER;
2257 for (i = 1; i < lim; i++)
2258 amt.table[i] = NULL;
2259 for (; i < NofAMmeth; i++) {
2260 const char * const cooky = PL_AMG_names[i];
2261 /* Human-readable form, for debugging: */
2262 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2263 const STRLEN l = PL_AMG_namelens[i];
2265 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2266 cp, HvNAME_get(stash)) );
2267 /* don't fill the cache while looking up!
2268 Creation of inheritance stubs in intermediate packages may
2269 conflict with the logic of runtime method substitution.
2270 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2271 then we could have created stubs for "(+0" in A and C too.
2272 But if B overloads "bool", we may want to use it for
2273 numifying instead of C's "+0". */
2274 if (i >= DESTROY_amg)
2275 gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0);
2276 else /* Autoload taken care of below */
2277 gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
2279 if (gv && (cv = GvCV(gv))) {
2280 if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
2281 const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
2282 if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
2283 && strEQ(hvname, "overload")) {
2284 /* This is a hack to support autoloading..., while
2285 knowing *which* methods were declared as overloaded. */
2286 /* GvSV contains the name of the method. */
2288 SV *gvsv = GvSV(gv);
2290 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2291 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2292 (void*)GvSV(gv), cp, HvNAME(stash)) );
2293 if (!gvsv || !SvPOK(gvsv)
2294 || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0)))
2296 /* Can be an import stub (created by "can"). */
2301 const SV * const name = (gvsv && SvPOK(gvsv))
2303 : newSVpvs_flags("???", SVs_TEMP);
2304 Perl_croak(aTHX_ "%s method \"%"SVf256
2305 "\" overloading \"%s\" "\
2306 "in package \"%"HEKf256"\"",
2307 (GvCVGEN(gv) ? "Stub found while resolving"
2315 cv = GvCV(gv = ngv);
2318 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2319 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2320 GvNAME(CvGV(cv))) );
2322 if (i < DESTROY_amg)
2324 } else if (gv) { /* Autoloaded... */
2325 cv = MUTABLE_CV(gv);
2328 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2331 AMT_AMAGIC_on(&amt);
2333 AMT_OVERLOADED_on(&amt);
2334 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2335 (char*)&amt, sizeof(AMT));
2339 /* Here we have no table: */
2341 AMT_AMAGIC_off(&amt);
2342 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2343 (char*)&amt, sizeof(AMTS));
2349 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2355 struct mro_meta* stash_meta;
2357 if (!stash || !HvNAME_get(stash))
2360 stash_meta = HvMROMETA(stash);
2361 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2363 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2366 /* If we're looking up a destructor to invoke, we must avoid
2367 * that Gv_AMupdate croaks, because we might be dying already */
2368 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2369 /* and if it didn't found a destructor, we fall back
2370 * to a simpler method that will only look for the
2371 * destructor instead of the whole magic */
2372 if (id == DESTROY_amg) {
2373 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2379 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2382 amtp = (AMT*)mg->mg_ptr;
2383 if ( amtp->was_ok_am != PL_amagic_generation
2384 || amtp->was_ok_sub != newgen )
2386 if (AMT_AMAGIC(amtp)) {
2387 CV * const ret = amtp->table[id];
2388 if (ret && isGV(ret)) { /* Autoloading stab */
2389 /* Passing it through may have resulted in a warning
2390 "Inherited AUTOLOAD for a non-method deprecated", since
2391 our caller is going through a function call, not a method call.
2392 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2393 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2405 /* Implement tryAMAGICun_MG macro.
2406 Do get magic, then see if the stack arg is overloaded and if so call it.
2408 AMGf_set return the arg using SETs rather than assigning to
2410 AMGf_numeric apply sv_2num to the stack arg.
2414 Perl_try_amagic_un(pTHX_ int method, int flags) {
2418 SV* const arg = TOPs;
2422 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2423 AMGf_noright | AMGf_unary))) {
2424 if (flags & AMGf_set) {
2429 if (SvPADMY(TARG)) {
2430 sv_setsv(TARG, tmpsv);
2440 if ((flags & AMGf_numeric) && SvROK(arg))
2446 /* Implement tryAMAGICbin_MG macro.
2447 Do get magic, then see if the two stack args are overloaded and if so
2450 AMGf_set return the arg using SETs rather than assigning to
2452 AMGf_assign op may be called as mutator (eg +=)
2453 AMGf_numeric apply sv_2num to the stack arg.
2457 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2460 SV* const left = TOPm1s;
2461 SV* const right = TOPs;
2467 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2468 SV * const tmpsv = amagic_call(left, right, method,
2469 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2471 if (flags & AMGf_set) {
2478 if (opASSIGN || SvPADMY(TARG)) {
2479 sv_setsv(TARG, tmpsv);
2489 if(left==right && SvGMAGICAL(left)) {
2490 SV * const left = sv_newmortal();
2492 /* Print the uninitialized warning now, so it includes the vari-
2495 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2496 sv_setsv_flags(left, &PL_sv_no, 0);
2498 else sv_setsv_flags(left, right, 0);
2501 if (flags & AMGf_numeric) {
2503 *(sp-1) = sv_2num(TOPm1s);
2505 *sp = sv_2num(right);
2511 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2514 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2516 while (SvAMAGIC(ref) &&
2517 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2518 AMGf_noright | AMGf_unary))) {
2520 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2521 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2522 /* Bail out if it returns us the same reference. */
2527 return tmpsv ? tmpsv : ref;
2531 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2536 CV **cvp=NULL, **ocvp=NULL;
2537 AMT *amtp=NULL, *oamtp=NULL;
2538 int off = 0, off1, lr = 0, notfound = 0;
2539 int postpr = 0, force_cpy = 0;
2540 int assign = AMGf_assign & flags;
2541 const int assignshift = assign ? 1 : 0;
2542 int use_default_op = 0;
2548 PERL_ARGS_ASSERT_AMAGIC_CALL;
2550 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2551 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2553 if ( !lex_mask || !SvOK(lex_mask) )
2554 /* overloading lexically disabled */
2556 else if ( lex_mask && SvPOK(lex_mask) ) {
2557 /* we have an entry in the hints hash, check if method has been
2558 * masked by overloading.pm */
2560 const int offset = method / 8;
2561 const int bit = method % 8;
2562 char *pv = SvPV(lex_mask, len);
2564 /* Bit set, so this overloading operator is disabled */
2565 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2570 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2571 && (stash = SvSTASH(SvRV(left)))
2572 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2573 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2574 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2576 && ((cv = cvp[off=method+assignshift])
2577 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2583 cv = cvp[off=method])))) {
2584 lr = -1; /* Call method for left argument */
2586 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2589 /* look for substituted methods */
2590 /* In all the covered cases we should be called with assign==0. */
2594 if ((cv = cvp[off=add_ass_amg])
2595 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2596 right = &PL_sv_yes; lr = -1; assign = 1;
2601 if ((cv = cvp[off = subtr_ass_amg])
2602 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2603 right = &PL_sv_yes; lr = -1; assign = 1;
2607 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2610 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2613 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2616 (void)((cv = cvp[off=bool__amg])
2617 || (cv = cvp[off=numer_amg])
2618 || (cv = cvp[off=string_amg]));
2625 * SV* ref causes confusion with the interpreter variable of
2628 SV* const tmpRef=SvRV(left);
2629 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2631 * Just to be extra cautious. Maybe in some
2632 * additional cases sv_setsv is safe, too.
2634 SV* const newref = newSVsv(tmpRef);
2635 SvOBJECT_on(newref);
2636 /* As a bit of a source compatibility hack, SvAMAGIC() and
2637 friends dereference an RV, to behave the same was as when
2638 overloading was stored on the reference, not the referant.
2639 Hence we can't use SvAMAGIC_on()
2641 SvFLAGS(newref) |= SVf_AMAGIC;
2642 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2648 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2649 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2650 SV* const nullsv=sv_2mortal(newSViv(0));
2652 SV* const lessp = amagic_call(left,nullsv,
2653 lt_amg,AMGf_noright);
2654 logic = SvTRUE(lessp);
2656 SV* const lessp = amagic_call(left,nullsv,
2657 ncmp_amg,AMGf_noright);
2658 logic = (SvNV(lessp) < 0);
2661 if (off==subtr_amg) {
2672 if ((cv = cvp[off=subtr_amg])) {
2674 left = sv_2mortal(newSViv(0));
2679 case iter_amg: /* XXXX Eventually should do to_gv. */
2680 case ftest_amg: /* XXXX Eventually should do to_gv. */
2683 return NULL; /* Delegate operation to standard mechanisms. */
2691 return left; /* Delegate operation to standard mechanisms. */
2696 if (!cv) goto not_found;
2697 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2698 && (stash = SvSTASH(SvRV(right)))
2699 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2700 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2701 ? (amtp = (AMT*)mg->mg_ptr)->table
2703 && (cv = cvp[off=method])) { /* Method for right
2706 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2707 || (ocvp && oamtp->fallback > AMGfallNEVER))
2708 && !(flags & AMGf_unary)) {
2709 /* We look for substitution for
2710 * comparison operations and
2712 if (method==concat_amg || method==concat_ass_amg
2713 || method==repeat_amg || method==repeat_ass_amg) {
2714 return NULL; /* Delegate operation to string conversion */
2736 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2740 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2750 not_found: /* No method found, either report or croak */
2758 return left; /* Delegate operation to standard mechanisms. */
2761 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2762 notfound = 1; lr = -1;
2763 } else if (cvp && (cv=cvp[nomethod_amg])) {
2764 notfound = 1; lr = 1;
2765 } else if ((use_default_op =
2766 (!ocvp || oamtp->fallback >= AMGfallYES)
2767 && (!cvp || amtp->fallback >= AMGfallYES))
2769 /* Skip generating the "no method found" message. */
2773 if (off==-1) off=method;
2774 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2775 "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
2776 AMG_id2name(method + assignshift),
2777 (flags & AMGf_unary ? " " : "\n\tleft "),
2779 "in overloaded package ":
2780 "has no overloaded magic",
2782 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
2785 ",\n\tright argument in overloaded package ":
2788 : ",\n\tright argument has no overloaded magic"),
2790 SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
2791 SVfARG(&PL_sv_no)));
2792 if (use_default_op) {
2793 DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
2795 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2799 force_cpy = force_cpy || assign;
2804 DEBUG_o(Perl_deb(aTHX_
2805 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n",
2807 method+assignshift==off? "" :
2809 method+assignshift==off? "" :
2810 AMG_id2name(method+assignshift),
2811 method+assignshift==off? "" : "\")",
2812 flags & AMGf_unary? "" :
2813 lr==1 ? " for right argument": " for left argument",
2814 flags & AMGf_unary? " for argument" : "",
2815 stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
2816 fl? ",\n\tassignment variant used": "") );
2819 /* Since we use shallow copy during assignment, we need
2820 * to dublicate the contents, probably calling user-supplied
2821 * version of copy operator
2823 /* We need to copy in following cases:
2824 * a) Assignment form was called.
2825 * assignshift==1, assign==T, method + 1 == off
2826 * b) Increment or decrement, called directly.
2827 * assignshift==0, assign==0, method + 0 == off
2828 * c) Increment or decrement, translated to assignment add/subtr.
2829 * assignshift==0, assign==T,
2831 * d) Increment or decrement, translated to nomethod.
2832 * assignshift==0, assign==0,
2834 * e) Assignment form translated to nomethod.
2835 * assignshift==1, assign==T, method + 1 != off
2838 /* off is method, method+assignshift, or a result of opcode substitution.
2839 * In the latter case assignshift==0, so only notfound case is important.
2841 if (( (method + assignshift == off)
2842 && (assign || (method == inc_amg) || (method == dec_amg)))
2845 /* newSVsv does not behave as advertised, so we copy missing
2846 * information by hand */
2847 SV *tmpRef = SvRV(left);
2849 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2850 SvRV_set(left, rv_copy);
2852 SvREFCNT_dec(tmpRef);
2860 const bool oldcatch = CATCH_GET;
2863 Zero(&myop, 1, BINOP);
2864 myop.op_last = (OP *) &myop;
2865 myop.op_next = NULL;
2866 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2868 PUSHSTACKi(PERLSI_OVERLOAD);
2871 PL_op = (OP *) &myop;
2872 if (PERLDB_SUB && PL_curstash != PL_debstash)
2873 PL_op->op_private |= OPpENTERSUB_DB;
2875 Perl_pp_pushmark(aTHX);
2877 EXTEND(SP, notfound + 5);
2878 PUSHs(lr>0? right: left);
2879 PUSHs(lr>0? left: right);
2880 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2882 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2883 AMG_id2namelen(method + assignshift), SVs_TEMP));
2885 PUSHs(MUTABLE_SV(cv));
2888 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2896 CATCH_SET(oldcatch);
2903 ans=SvIV(res)<=0; break;
2906 ans=SvIV(res)<0; break;
2909 ans=SvIV(res)>=0; break;
2912 ans=SvIV(res)>0; break;
2915 ans=SvIV(res)==0; break;
2918 ans=SvIV(res)!=0; break;
2921 SvSetSV(left,res); return left;
2923 ans=!SvTRUE(res); break;
2928 } else if (method==copy_amg) {
2930 Perl_croak(aTHX_ "Copy method did not return a reference");
2932 return SvREFCNT_inc(SvRV(res));
2940 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2945 PERL_ARGS_ASSERT_GV_NAME_SET;
2948 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2950 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2951 unshare_hek(GvNAME_HEK(gv));
2954 PERL_HASH(hash, name, len);
2955 GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2959 =for apidoc gv_try_downgrade
2961 If the typeglob C<gv> can be expressed more succinctly, by having
2962 something other than a real GV in its place in the stash, replace it
2963 with the optimised form. Basic requirements for this are that C<gv>
2964 is a real typeglob, is sufficiently ordinary, and is only referenced
2965 from its package. This function is meant to be used when a GV has been
2966 looked up in part to see what was there, causing upgrading, but based
2967 on what was found it turns out that the real GV isn't required after all.
2969 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2971 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2972 sub, the typeglob is replaced with a scalar-reference placeholder that
2973 more compactly represents the same thing.
2979 Perl_gv_try_downgrade(pTHX_ GV *gv)
2985 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2987 /* XXX Why and where does this leave dangling pointers during global
2989 if (PL_phase == PERL_PHASE_DESTRUCT) return;
2991 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2992 !SvOBJECT(gv) && !SvREADONLY(gv) &&
2993 isGV_with_GP(gv) && GvGP(gv) &&
2994 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2995 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2996 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2998 if (SvMAGICAL(gv)) {
3000 /* only backref magic is allowed */
3001 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
3003 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
3004 if (mg->mg_type != PERL_MAGIC_backref)
3010 HEK *gvnhek = GvNAME_HEK(gv);
3011 (void)hv_delete(stash, HEK_KEY(gvnhek),
3012 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
3013 } else if (GvMULTI(gv) && cv &&
3014 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
3015 CvSTASH(cv) == stash && CvGV(cv) == gv &&
3016 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
3017 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
3018 (namehek = GvNAME_HEK(gv)) &&
3019 (gvp = hv_fetch(stash, HEK_KEY(namehek),
3020 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
3022 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
3026 SvFLAGS(gv) = SVt_IV|SVf_ROK;
3027 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
3028 STRUCT_OFFSET(XPVIV, xiv_iv));
3029 SvRV_set(gv, value);
3036 core_xsub(pTHX_ CV* cv)
3039 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
3045 * c-indentation-style: bsd
3047 * indent-tabs-mode: t
3050 * ex: set ts=8 sts=4 sw=4 noet: