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 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
255 const U32 old_type = SvTYPE(gv);
256 const bool doproto = old_type > SVt_NULL;
257 char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
258 const STRLEN protolen = proto ? SvCUR(gv) : 0;
259 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
260 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
262 PERL_ARGS_ASSERT_GV_INIT;
263 assert (!(proto && has_constant));
266 /* The constant has to be a simple scalar type. */
267 switch (SvTYPE(has_constant)) {
273 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
274 sv_reftype(has_constant, 0));
282 if (old_type < SVt_PVGV) {
283 if (old_type >= SVt_PV)
285 sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
293 Safefree(SvPVX_mutable(gv));
298 GvGP_set(gv, Perl_newGP(aTHX_ gv));
301 Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
302 gv_name_set(gv, name, len, GV_ADD);
303 if (multi || doproto) /* doproto means it _was_ mentioned */
305 if (doproto) { /* Replicate part of newSUB here. */
311 /* newCONSTSUB doesn't take a len arg, so make sure we
312 * give it a \0-terminated string */
313 name0 = savepvn(name,len);
315 /* newCONSTSUB takes ownership of the reference from us. */
316 cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
317 /* In case op.c:S_process_special_blocks stole it: */
319 GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
320 assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
323 /* If this reference was a copy of another, then the subroutine
324 must have been "imported", by a Perl space assignment to a GV
325 from a reference to CV. */
326 if (exported_constant)
327 GvIMPORTED_CV_on(gv);
329 (void) start_subparse(0,0); /* Create empty CV in compcv. */
335 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
337 CvFILE_set_from_cop(cv, PL_curcop);
338 CvSTASH_set(cv, PL_curstash);
340 sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
341 SV_HAS_TRAILING_NUL);
347 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
349 PERL_ARGS_ASSERT_GV_INIT_SV;
361 #ifdef PERL_DONT_CREATE_GVSV
369 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
370 If we just cast GvSVn(gv) to void, it ignores evaluating it for
377 static void core_xsub(pTHX_ CV* cv);
380 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
381 const char * const name, const STRLEN len,
382 const char * const fullname, STRLEN const fullen)
384 const int code = keyword(name, len, 1);
385 static const char file[] = __FILE__;
389 bool ampable = TRUE; /* &{}-able */
391 yy_parser *oldparser;
396 assert(stash || fullname);
398 if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
400 inlining newATTRSUB */
401 if (code >= 0) return NULL; /* not overridable */
403 /* no support for \&CORE::infix;
404 no support for funcs that take labels, as their parsing is
406 case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
407 case KEY_eq: case KEY_ge:
408 case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
409 case KEY_or: case KEY_x: case KEY_xor:
412 case KEY_chomp: case KEY_chop:
413 case KEY_each: case KEY_eof: case KEY_exec:
422 case KEY_truncate: case KEY_unlink:
429 gv_init(gv, stash, name, len, TRUE);
433 oldcurcop = PL_curcop;
434 oldparser = PL_parser;
435 lex_start(NULL, NULL, 0);
436 oldcompcv = PL_compcv;
437 PL_compcv = NULL; /* Prevent start_subparse from setting
439 oldsavestack_ix = start_subparse(FALSE,0);
443 /* Avoid calling newXS, as it calls us, and things start to
445 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
448 mro_method_changed_in(GvSTASH(gv));
450 CvXSUB(cv) = core_xsub;
452 CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
454 (void)gv_fetchfile(file);
455 CvFILE(cv) = (char *)file;
456 /* XXX This is inefficient, as doing things this order causes
457 a prototype check in newATTRSUB. But we have to do
458 it this order as we need an op number before calling
460 (void)core_prototype((SV *)cv, name, code, &opnum);
461 if (stash && (fullname || !fullen))
462 (void)hv_store(stash,name,len,(SV *)gv,0);
467 tmpstr = newSVhek(HvENAME_HEK(stash));
468 sv_catpvs(tmpstr, "::");
469 sv_catpvn(tmpstr,name,len);
471 else tmpstr = newSVpvn_share(fullname,fullen,0);
472 newATTRSUB(oldsavestack_ix,
473 newSVOP(OP_CONST, 0, tmpstr),
478 : newSVpvn(name,len),
482 assert(GvCV(gv) == cv);
483 if (opnum != OP_VEC && opnum != OP_SUBSTR)
484 CvLVALUE_off(cv); /* Now *that* was a neat trick. */
486 PL_parser = oldparser;
487 PL_curcop = oldcurcop;
488 PL_compcv = oldcompcv;
490 opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
492 cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
494 SvREFCNT_dec(opnumsv);
499 =for apidoc gv_fetchmeth
501 Returns the glob with the given C<name> and a defined subroutine or
502 C<NULL>. The glob lives in the given C<stash>, or in the stashes
503 accessible via @ISA and UNIVERSAL::.
505 The argument C<level> should be either 0 or -1. If C<level==0>, as a
506 side-effect creates a glob with the given C<name> in the given C<stash>
507 which in the case of success contains an alias for the subroutine, and sets
508 up caching info for this glob.
510 This function grants C<"SUPER"> token as a postfix of the stash name. The
511 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
512 visible to Perl code. So when calling C<call_sv>, you should not use
513 the GV directly; instead, you should use the method's CV, which can be
514 obtained from the GV with the C<GvCV> macro.
519 /* NOTE: No support for tied ISA */
522 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
530 GV* candidate = NULL;
534 I32 create = (level >= 0) ? 1 : 0;
539 PERL_ARGS_ASSERT_GV_FETCHMETH;
541 /* UNIVERSAL methods should be callable without a stash */
543 create = 0; /* probably appropriate */
544 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
550 hvname = HvNAME_get(stash);
552 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
557 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
559 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
561 /* check locally for a real method or a cache entry */
562 gvp = (GV**)hv_fetch(stash, name, len, create);
567 if (SvTYPE(topgv) != SVt_PVGV)
568 gv_init(topgv, stash, name, len, TRUE);
569 if ((cand_cv = GvCV(topgv))) {
570 /* If genuine method or valid cache entry, use it */
571 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
575 /* stale cache entry, junk it and move on */
576 SvREFCNT_dec(cand_cv);
577 GvCV_set(topgv, NULL);
582 else if (GvCVGEN(topgv) == topgen_cmp) {
583 /* cache indicates no such method definitively */
586 else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
587 && strnEQ(hvname, "CORE", 4)
588 && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
592 packlen = HvNAMELEN_get(stash);
593 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
596 basestash = gv_stashpvn(hvname, packlen, GV_ADD);
597 linear_av = mro_get_linear_isa(basestash);
600 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
603 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
604 items = AvFILLp(linear_av); /* no +1, to skip over self */
606 linear_sv = *linear_svp++;
608 cstash = gv_stashsv(linear_sv, 0);
611 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
612 SVfARG(linear_sv), hvname);
618 gvp = (GV**)hv_fetch(cstash, name, len, 0);
620 if (len > 1 && HvNAMELEN_get(cstash) == 4) {
621 const char *hvname = HvNAME(cstash); assert(hvname);
622 if (strnEQ(hvname, "CORE", 4)
624 S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
630 else candidate = *gvp;
633 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
634 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
636 * Found real method, cache method in topgv if:
637 * 1. topgv has no synonyms (else inheritance crosses wires)
638 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
640 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
641 CV *old_cv = GvCV(topgv);
642 SvREFCNT_dec(old_cv);
643 SvREFCNT_inc_simple_void_NN(cand_cv);
644 GvCV_set(topgv, cand_cv);
645 GvCVGEN(topgv) = topgen_cmp;
651 /* Check UNIVERSAL without caching */
652 if(level == 0 || level == -1) {
653 candidate = gv_fetchmeth(NULL, name, len, 1);
655 cand_cv = GvCV(candidate);
656 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
657 CV *old_cv = GvCV(topgv);
658 SvREFCNT_dec(old_cv);
659 SvREFCNT_inc_simple_void_NN(cand_cv);
660 GvCV_set(topgv, cand_cv);
661 GvCVGEN(topgv) = topgen_cmp;
667 if (topgv && GvREFCNT(topgv) == 1) {
668 /* cache the fact that the method is not defined */
669 GvCVGEN(topgv) = topgen_cmp;
676 =for apidoc gv_fetchmeth_autoload
678 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
679 Returns a glob for the subroutine.
681 For an autoloaded subroutine without a GV, will create a GV even
682 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
683 of the result may be zero.
689 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
691 GV *gv = gv_fetchmeth(stash, name, len, level);
693 PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
700 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
701 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
703 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
706 if (!(CvROOT(cv) || CvXSUB(cv)))
708 /* Have an autoload */
709 if (level < 0) /* Cannot do without a stub */
710 gv_fetchmeth(stash, name, len, 0);
711 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
720 =for apidoc gv_fetchmethod_autoload
722 Returns the glob which contains the subroutine to call to invoke the method
723 on the C<stash>. In fact in the presence of autoloading this may be the
724 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
727 The third parameter of C<gv_fetchmethod_autoload> determines whether
728 AUTOLOAD lookup is performed if the given method is not present: non-zero
729 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
730 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
731 with a non-zero C<autoload> parameter.
733 These functions grant C<"SUPER"> token as a prefix of the method name. Note
734 that if you want to keep the returned glob for a long time, you need to
735 check for it being "AUTOLOAD", since at the later time the call may load a
736 different subroutine due to $AUTOLOAD changing its value. Use the glob
737 created via a side effect to do this.
739 These functions have the same side-effects and as C<gv_fetchmeth> with
740 C<level==0>. C<name> should be writable if contains C<':'> or C<'
741 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
742 C<call_sv> apply equally to these functions.
748 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
755 PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
757 stash = gv_stashpvn(name, namelen, 0);
758 if(stash) return stash;
760 /* If we must create it, give it an @ISA array containing
761 the real package this SUPER is for, so that it's tied
762 into the cache invalidation code correctly */
763 stash = gv_stashpvn(name, namelen, GV_ADD);
764 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
766 gv_init(gv, stash, "ISA", 3, TRUE);
767 superisa = GvAVn(gv);
769 sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
771 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
773 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
774 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
781 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
783 PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
785 return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
788 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
791 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
794 register const char *nend;
795 const char *nsplit = NULL;
798 const char * const origname = name;
799 SV *const error_report = MUTABLE_SV(stash);
800 const U32 autoload = flags & GV_AUTOLOAD;
801 const U32 do_croak = flags & GV_CROAK;
803 PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
805 if (SvTYPE(stash) < SVt_PVHV)
808 /* The only way stash can become NULL later on is if nsplit is set,
809 which in turn means that there is no need for a SVt_PVHV case
810 the error reporting code. */
813 for (nend = name; *nend; nend++) {
818 else if (*nend == ':' && *(nend + 1) == ':') {
824 if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
825 /* ->SUPER::method should really be looked up in original stash */
826 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
827 CopSTASHPV(PL_curcop)));
828 /* __PACKAGE__::SUPER stash should be autovivified */
829 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
830 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
831 origname, HvNAME_get(stash), name) );
834 /* don't autovifify if ->NoSuchStash::method */
835 stash = gv_stashpvn(origname, nsplit - origname, 0);
837 /* however, explicit calls to Pkg::SUPER::method may
838 happen, and may require autovivification to work */
839 if (!stash && (nsplit - origname) >= 7 &&
840 strnEQ(nsplit - 7, "::SUPER", 7) &&
841 gv_stashpvn(origname, nsplit - origname - 7, 0))
842 stash = gv_get_super_pkg(origname, nsplit - origname);
847 gv = gv_fetchmeth(stash, name, nend - name, 0);
849 if (strEQ(name,"import") || strEQ(name,"unimport"))
850 gv = MUTABLE_GV(&PL_sv_yes);
852 gv = gv_autoload4(ostash, name, nend - name, TRUE);
853 if (!gv && do_croak) {
854 /* Right now this is exclusively for the benefit of S_method_common
857 /* If we can't find an IO::File method, it might be a call on
858 * a filehandle. If IO:File has not been loaded, try to
859 * require it first instead of croaking */
860 const char *stash_name = HvNAME_get(stash);
861 if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
862 && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
863 STR_WITH_LEN("IO/File.pm"), 0,
864 HV_FETCH_ISEXISTS, NULL, 0)
866 require_pv("IO/File.pm");
867 gv = gv_fetchmeth(stash, name, nend - name, 0);
872 "Can't locate object method \"%s\" via package \"%.*s\"",
873 name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
877 const char *packname;
880 packlen = nsplit - origname;
883 packname = SvPV_const(error_report, packlen);
887 "Can't locate object method \"%s\" via package \"%.*s\""
888 " (perhaps you forgot to load \"%.*s\"?)",
889 name, (int)packlen, packname, (int)packlen, packname);
894 CV* const cv = GvCV(gv);
895 if (!CvROOT(cv) && !CvXSUB(cv)) {
903 if (GvCV(stubgv) != cv) /* orphaned import */
906 autogv = gv_autoload4(GvSTASH(stubgv),
907 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
917 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
925 const char *packname = "";
926 STRLEN packname_len = 0;
928 PERL_ARGS_ASSERT_GV_AUTOLOAD4;
930 if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
933 if (SvTYPE(stash) < SVt_PVHV) {
934 packname = SvPV_const(MUTABLE_SV(stash), packname_len);
938 packname = HvNAME_get(stash);
939 packname_len = HvNAMELEN_get(stash);
942 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
946 if (!(CvROOT(cv) || CvXSUB(cv)))
950 * Inheriting AUTOLOAD for non-methods works ... for now.
952 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
954 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
955 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
956 packname, (int)len, name);
959 /* rather than lookup/init $AUTOLOAD here
960 * only to have the XSUB do another lookup for $AUTOLOAD
961 * and split that value on the last '::',
962 * pass along the same data via some unused fields in the CV
964 CvSTASH_set(cv, stash);
965 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
971 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
972 * The subroutine's original name may not be "AUTOLOAD", so we don't
973 * use that, but for lack of anything better we will use the sub's
974 * original package to look up $AUTOLOAD.
976 varstash = GvSTASH(CvGV(cv));
977 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
981 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
982 #ifdef PERL_DONT_CREATE_GVSV
983 GvSV(vargv) = newSV(0);
987 varsv = GvSVn(vargv);
988 sv_setpvn(varsv, packname, packname_len);
989 sv_catpvs(varsv, "::");
990 /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
991 tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
992 sv_catpvn_mg(varsv, name, len);
997 /* require_tie_mod() internal routine for requiring a module
998 * that implements the logic of automatic ties like %! and %-
1000 * The "gv" parameter should be the glob.
1001 * "varpv" holds the name of the var, used for error messages.
1002 * "namesv" holds the module name. Its refcount will be decremented.
1003 * "methpv" holds the method name to test for to check that things
1004 * are working reasonably close to as expected.
1005 * "flags": if flag & 1 then save the scalar before loading.
1006 * For the protection of $! to work (it is set by this routine)
1007 * the sv slot must already be magicalized.
1010 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
1013 HV* stash = gv_stashsv(namesv, 0);
1015 PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
1017 if (!stash || !(gv_fetchmethod(stash, methpv))) {
1018 SV *module = newSVsv(namesv);
1019 char varname = *varpv; /* varpv might be clobbered by load_module,
1020 so save it. For the moment it's always
1026 PUSHSTACKi(PERLSI_MAGIC);
1027 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
1031 stash = gv_stashsv(namesv, 0);
1033 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
1034 varname, SVfARG(namesv));
1035 else if (!gv_fetchmethod(stash, methpv))
1036 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
1037 varname, SVfARG(namesv), methpv);
1039 SvREFCNT_dec(namesv);
1044 =for apidoc gv_stashpv
1046 Returns a pointer to the stash for a specified package. Uses C<strlen> to
1047 determine the length of C<name>, then calls C<gv_stashpvn()>.
1053 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
1055 PERL_ARGS_ASSERT_GV_STASHPV;
1056 return gv_stashpvn(name, strlen(name), create);
1060 =for apidoc gv_stashpvn
1062 Returns a pointer to the stash for a specified package. The C<namelen>
1063 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
1064 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
1065 created if it does not already exist. If the package does not exist and
1066 C<flags> is 0 (or any other setting that does not create packages) then NULL
1074 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
1080 U32 tmplen = namelen + 2;
1082 PERL_ARGS_ASSERT_GV_STASHPVN;
1084 if (tmplen <= sizeof smallbuf)
1087 Newx(tmpbuf, tmplen, char);
1088 Copy(name, tmpbuf, namelen, char);
1089 tmpbuf[namelen] = ':';
1090 tmpbuf[namelen+1] = ':';
1091 tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
1092 if (tmpbuf != smallbuf)
1096 stash = GvHV(tmpgv);
1097 if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
1099 if (!HvNAME_get(stash)) {
1100 hv_name_set(stash, name, namelen, 0);
1102 /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
1103 /* If the containing stash has multiple effective
1104 names, see that this one gets them, too. */
1105 if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
1106 mro_package_moved(stash, NULL, tmpgv, 1);
1112 =for apidoc gv_stashsv
1114 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
1120 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
1123 const char * const ptr = SvPV_const(sv,len);
1125 PERL_ARGS_ASSERT_GV_STASHSV;
1127 return gv_stashpvn(ptr, len, flags);
1132 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
1133 PERL_ARGS_ASSERT_GV_FETCHPV;
1134 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
1138 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
1140 const char * const nambeg =
1141 SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
1142 PERL_ARGS_ASSERT_GV_FETCHSV;
1143 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
1147 S_gv_magicalize_isa(pTHX_ GV *gv)
1151 PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
1155 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
1160 S_gv_magicalize_overload(pTHX_ GV *gv)
1164 PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1168 hv_magic(hv, NULL, PERL_MAGIC_overload);
1172 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1173 const svtype sv_type)
1176 register const char *name = nambeg;
1177 register GV *gv = NULL;
1180 register const char *name_cursor;
1182 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1183 const I32 no_expand = flags & GV_NOEXPAND;
1184 const I32 add = flags & ~GV_NOADD_MASK;
1185 bool addmg = !!(flags & GV_ADDMG);
1186 const char *const name_end = nambeg + full_len;
1187 const char *const name_em1 = name_end - 1;
1190 PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1192 if (flags & GV_NOTQUAL) {
1193 /* Caller promised that there is no stash, so we can skip the check. */
1198 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1199 /* accidental stringify on a GV? */
1203 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1204 if (name_cursor < name_em1 &&
1205 ((*name_cursor == ':'
1206 && name_cursor[1] == ':')
1207 || *name_cursor == '\''))
1210 stash = PL_defstash;
1211 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1214 len = name_cursor - name;
1215 if (name_cursor > nambeg) { /* Skip for initial :: or ' */
1217 if (*name_cursor == ':') {
1222 Newx(tmpbuf, len+2, char);
1223 Copy(name, tmpbuf, len, char);
1224 tmpbuf[len++] = ':';
1225 tmpbuf[len++] = ':';
1228 gvp = (GV**)hv_fetch(stash, key, len, add);
1229 gv = gvp ? *gvp : NULL;
1230 if (gv && gv != (const GV *)&PL_sv_undef) {
1231 if (SvTYPE(gv) != SVt_PVGV)
1232 gv_init(gv, stash, key, len, (add & GV_ADDMULTI));
1238 if (!gv || gv == (const GV *)&PL_sv_undef)
1241 if (!(stash = GvHV(gv)))
1243 stash = GvHV(gv) = newHV();
1244 if (!HvNAME_get(stash)) {
1245 if (GvSTASH(gv) == PL_defstash && len == 6
1246 && strnEQ(name, "CORE", 4))
1247 hv_name_set(stash, "CORE", 4, 0);
1250 stash, nambeg, name_cursor-nambeg, 0
1252 /* If the containing stash has multiple effective
1253 names, see that this one gets them, too. */
1254 if (HvAUX(GvSTASH(gv))->xhv_name_count)
1255 mro_package_moved(stash, NULL, gv, 1);
1258 else if (!HvNAME_get(stash))
1259 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1262 if (*name_cursor == ':')
1264 name = name_cursor+1;
1265 if (name == name_end)
1267 ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1270 len = name_cursor - name;
1272 /* No stash in name, so see how we can default */
1276 if (len && isIDFIRST_lazy(name)) {
1277 bool global = FALSE;
1285 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1286 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1287 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1291 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1296 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1297 && name[3] == 'I' && name[4] == 'N')
1301 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1302 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1303 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1307 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1308 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1315 stash = PL_defstash;
1316 else if (IN_PERL_COMPILETIME) {
1317 stash = PL_curstash;
1318 if (add && (PL_hints & HINT_STRICT_VARS) &&
1319 sv_type != SVt_PVCV &&
1320 sv_type != SVt_PVGV &&
1321 sv_type != SVt_PVFM &&
1322 sv_type != SVt_PVIO &&
1323 !(len == 1 && sv_type == SVt_PV &&
1324 (*name == 'a' || *name == 'b')) )
1326 gvp = (GV**)hv_fetch(stash,name,len,0);
1328 *gvp == (const GV *)&PL_sv_undef ||
1329 SvTYPE(*gvp) != SVt_PVGV)
1333 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1334 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1335 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1337 /* diag_listed_as: Variable "%s" is not imported%s */
1339 aTHX_ packWARN(WARN_MISC),
1340 "Variable \"%c%s\" is not imported",
1341 sv_type == SVt_PVAV ? '@' :
1342 sv_type == SVt_PVHV ? '%' : '$',
1346 aTHX_ packWARN(WARN_MISC),
1347 "\t(Did you mean &%s instead?)\n", name
1354 stash = CopSTASH(PL_curcop);
1357 stash = PL_defstash;
1360 /* By this point we should have a stash and a name */
1364 SV * const err = Perl_mess(aTHX_
1365 "Global symbol \"%s%s\" requires explicit package name",
1366 (sv_type == SVt_PV ? "$"
1367 : sv_type == SVt_PVAV ? "@"
1368 : sv_type == SVt_PVHV ? "%"
1371 if (USE_UTF8_IN_NAMES)
1374 gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1376 /* symbol table under destruction */
1385 if (!SvREFCNT(stash)) /* symbol table under destruction */
1388 gvp = (GV**)hv_fetch(stash,name,len,add);
1389 if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
1390 if (addmg) gv = (GV *)newSV(0);
1393 else gv = *gvp, addmg = 0;
1394 /* From this point on, addmg means gv has not been inserted in the
1397 if (SvTYPE(gv) == SVt_PVGV) {
1400 gv_init_sv(gv, sv_type);
1401 if (len == 1 && stash == PL_defstash
1402 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1404 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1405 else if (*name == '-' || *name == '+')
1406 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1408 else if (len == 3 && sv_type == SVt_PVAV
1409 && strnEQ(name, "ISA", 3)
1410 && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
1411 gv_magicalize_isa(gv);
1414 } else if (no_init) {
1417 } else if (no_expand && SvROK(gv)) {
1422 /* Adding a new symbol.
1423 Unless of course there was already something non-GV here, in which case
1424 we want to behave as if there was always a GV here, containing some sort
1426 Otherwise we run the risk of creating things like GvIO, which can cause
1427 subtle bugs. eg the one that tripped up SQL::Translator */
1429 faking_it = SvOK(gv);
1431 if (add & GV_ADDWARN)
1432 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1433 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1435 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1436 : (PL_dowarn & G_WARN_ON ) ) )
1439 /* set up magic where warranted */
1440 if (stash != PL_defstash) { /* not the main stash */
1441 /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1442 and VERSION. All the others apply only to the main stash or to
1443 CORE (which is checked right after this). */
1445 const char * const name2 = name + 1;
1448 if (strnEQ(name2, "XPORT", 5))
1452 if (strEQ(name2, "SA"))
1453 gv_magicalize_isa(gv);
1456 if (strEQ(name2, "VERLOAD"))
1457 gv_magicalize_overload(gv);
1460 if (strEQ(name2, "ERSION"))
1466 goto add_magical_gv;
1469 if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
1470 /* Avoid null warning: */
1471 const char * const stashname = HvNAME(stash); assert(stashname);
1472 if (strnEQ(stashname, "CORE", 4)
1473 && S_maybe_add_coresub(aTHX_
1474 addmg ? stash : 0, gv, name, len, nambeg, full_len
1483 /* Nothing else to do.
1484 The compiler will probably turn the switch statement into a
1485 branch table. Make sure we avoid even that small overhead for
1486 the common case of lower case variable names. */
1490 const char * const name2 = name + 1;
1493 if (strEQ(name2, "RGV")) {
1494 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1496 else if (strEQ(name2, "RGVOUT")) {
1501 if (strnEQ(name2, "XPORT", 5))
1505 if (strEQ(name2, "SA")) {
1506 gv_magicalize_isa(gv);
1510 if (strEQ(name2, "VERLOAD")) {
1511 gv_magicalize_overload(gv);
1515 if (strEQ(name2, "IG")) {
1518 if (!PL_psig_name) {
1519 Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1520 Newxz(PL_psig_pend, SIG_SIZE, int);
1521 PL_psig_ptr = PL_psig_name + SIG_SIZE;
1523 /* I think that the only way to get here is to re-use an
1524 embedded perl interpreter, where the previous
1525 use didn't clean up fully because
1526 PL_perl_destruct_level was 0. I'm not sure that we
1527 "support" that, in that I suspect in that scenario
1528 there are sufficient other garbage values left in the
1529 interpreter structure that something else will crash
1530 before we get here. I suspect that this is one of
1531 those "doctor, it hurts when I do this" bugs. */
1532 Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1533 Zero(PL_psig_pend, SIG_SIZE, int);
1537 hv_magic(hv, NULL, PERL_MAGIC_sig);
1538 for (i = 1; i < SIG_SIZE; i++) {
1539 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1541 sv_setsv(*init, &PL_sv_undef);
1546 if (strEQ(name2, "ERSION"))
1549 case '\003': /* $^CHILD_ERROR_NATIVE */
1550 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1553 case '\005': /* $^ENCODING */
1554 if (strEQ(name2, "NCODING"))
1557 case '\007': /* $^GLOBAL_PHASE */
1558 if (strEQ(name2, "LOBAL_PHASE"))
1561 case '\015': /* $^MATCH */
1562 if (strEQ(name2, "ATCH"))
1564 case '\017': /* $^OPEN */
1565 if (strEQ(name2, "PEN"))
1568 case '\020': /* $^PREMATCH $^POSTMATCH */
1569 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1572 case '\024': /* ${^TAINT} */
1573 if (strEQ(name2, "AINT"))
1576 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1577 if (strEQ(name2, "NICODE"))
1579 if (strEQ(name2, "TF8LOCALE"))
1581 if (strEQ(name2, "TF8CACHE"))
1584 case '\027': /* $^WARNING_BITS */
1585 if (strEQ(name2, "ARNING_BITS"))
1598 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1600 /* This snippet is taken from is_gv_magical */
1601 const char *end = name + len;
1602 while (--end > name) {
1603 if (!isDIGIT(*end)) goto add_magical_gv;
1610 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1611 be case '\0' in this switch statement (ie a default case) */
1617 sv_type == SVt_PVAV ||
1618 sv_type == SVt_PVHV ||
1619 sv_type == SVt_PVCV ||
1620 sv_type == SVt_PVFM ||
1623 PL_sawampersand = TRUE;
1627 sv_setpv(GvSVn(gv),PL_chopset);
1631 #ifdef COMPLEX_STATUS
1632 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1638 /* If %! has been used, automatically load Errno.pm. */
1640 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1642 /* magicalization must be done before require_tie_mod is called */
1643 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1644 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1649 GvMULTI_on(gv); /* no used once warnings here */
1651 AV* const av = GvAVn(gv);
1652 SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1654 sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1655 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1657 SvREADONLY_on(GvSVn(gv));
1660 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1661 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1667 if (sv_type == SVt_PV)
1668 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1669 "$%c is no longer supported", *name);
1672 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1675 case '\010': /* $^H */
1677 HV *const hv = GvHVn(gv);
1678 hv_magic(hv, NULL, PERL_MAGIC_hints);
1681 case '\023': /* $^S */
1683 SvREADONLY_on(GvSVn(gv));
1708 case '\001': /* $^A */
1709 case '\003': /* $^C */
1710 case '\004': /* $^D */
1711 case '\005': /* $^E */
1712 case '\006': /* $^F */
1713 case '\011': /* $^I, NOT \t in EBCDIC */
1714 case '\016': /* $^N */
1715 case '\017': /* $^O */
1716 case '\020': /* $^P */
1717 case '\024': /* $^T */
1718 case '\027': /* $^W */
1720 sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1723 case '\014': /* $^L */
1724 sv_setpvs(GvSVn(gv),"\f");
1725 PL_formfeed = GvSVn(gv);
1728 sv_setpvs(GvSVn(gv),"\034");
1732 SV * const sv = GvSV(gv);
1733 if (!sv_derived_from(PL_patchlevel, "version"))
1734 upg_version(PL_patchlevel, TRUE);
1735 GvSV(gv) = vnumify(PL_patchlevel);
1736 SvREADONLY_on(GvSV(gv));
1740 case '\026': /* $^V */
1742 SV * const sv = GvSV(gv);
1743 GvSV(gv) = new_version(PL_patchlevel);
1744 SvREADONLY_on(GvSV(gv));
1752 if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
1753 GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
1755 (void)hv_store(stash,name,len,(SV *)gv,0);
1756 else SvREFCNT_dec(gv), gv = NULL;
1758 if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1763 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1767 const HV * const hv = GvSTASH(gv);
1769 PERL_ARGS_ASSERT_GV_FULLNAME4;
1775 sv_setpv(sv, prefix ? prefix : "");
1777 name = HvNAME_get(hv);
1779 namelen = HvNAMELEN_get(hv);
1785 if (keepmain || strNE(name, "main")) {
1786 sv_catpvn(sv,name,namelen);
1789 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1793 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1795 const GV * const egv = GvEGVx(gv);
1797 PERL_ARGS_ASSERT_GV_EFULLNAME4;
1799 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1803 Perl_gv_check(pTHX_ const HV *stash)
1808 PERL_ARGS_ASSERT_GV_CHECK;
1810 if (!HvARRAY(stash))
1812 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1814 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1817 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1818 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1820 if (hv != PL_defstash && hv != stash)
1821 gv_check(hv); /* nested package */
1823 else if (isALPHA(*HeKEY(entry))) {
1825 gv = MUTABLE_GV(HeVAL(entry));
1826 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1829 CopLINE_set(PL_curcop, GvLINE(gv));
1831 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1833 CopFILEGV(PL_curcop)
1834 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1836 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1837 "Name \"%s::%s\" used only once: possible typo",
1838 HvNAME_get(stash), GvNAME(gv));
1845 Perl_newGVgen(pTHX_ const char *pack)
1849 PERL_ARGS_ASSERT_NEWGVGEN;
1851 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1855 /* hopefully this is only called on local symbol table entries */
1858 Perl_gp_ref(pTHX_ GP *gp)
1866 /* If the GP they asked for a reference to contains
1867 a method cache entry, clear it first, so that we
1868 don't infect them with our cached entry */
1869 SvREFCNT_dec(gp->gp_cv);
1878 Perl_gp_free(pTHX_ GV *gv)
1884 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1886 if (gp->gp_refcnt == 0) {
1887 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1888 "Attempt to free unreferenced glob pointers"
1889 pTHX__FORMAT pTHX__VALUE);
1892 if (--gp->gp_refcnt > 0) {
1893 if (gp->gp_egv == gv)
1900 /* Copy and null out all the glob slots, so destructors do not see
1902 HEK * const file_hek = gp->gp_file_hek;
1903 SV * const sv = gp->gp_sv;
1904 AV * const av = gp->gp_av;
1905 HV * const hv = gp->gp_hv;
1906 IO * const io = gp->gp_io;
1907 CV * const cv = gp->gp_cv;
1908 CV * const form = gp->gp_form;
1910 gp->gp_file_hek = NULL;
1919 unshare_hek(file_hek);
1923 /* FIXME - another reference loop GV -> symtab -> GV ?
1924 Somehow gp->gp_hv can end up pointing at freed garbage. */
1925 if (hv && SvTYPE(hv) == SVt_PVHV) {
1926 const char *hvname = HvNAME_get(hv);
1927 if (PL_stashcache && hvname)
1928 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
1936 if (!gp->gp_file_hek
1942 && !gp->gp_form) break;
1944 if (--attempts == 0) {
1946 "panic: gp_free failed to free glob pointer - "
1947 "something is repeatedly re-creating entries"
1957 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1959 AMT * const amtp = (AMT*)mg->mg_ptr;
1960 PERL_UNUSED_ARG(sv);
1962 PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1964 if (amtp && AMT_AMAGIC(amtp)) {
1966 for (i = 1; i < NofAMmeth; i++) {
1967 CV * const cv = amtp->table[i];
1969 SvREFCNT_dec(MUTABLE_SV(cv));
1970 amtp->table[i] = NULL;
1977 /* Updates and caches the CV's */
1979 * 1 on success and there is some overload
1980 * 0 if there is no overload
1981 * -1 if some error occurred and it couldn't croak
1985 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1988 MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1990 const struct mro_meta* stash_meta = HvMROMETA(stash);
1993 PERL_ARGS_ASSERT_GV_AMUPDATE;
1995 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1997 const AMT * const amtp = (AMT*)mg->mg_ptr;
1998 if (amtp->was_ok_am == PL_amagic_generation
1999 && amtp->was_ok_sub == newgen) {
2000 return AMT_OVERLOADED(amtp) ? 1 : 0;
2002 sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
2005 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
2008 amt.was_ok_am = PL_amagic_generation;
2009 amt.was_ok_sub = newgen;
2010 amt.fallback = AMGfallNO;
2014 int filled = 0, have_ovl = 0;
2017 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
2019 /* Try to find via inheritance. */
2020 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
2021 SV * const sv = gv ? GvSV(gv) : NULL;
2025 lim = DESTROY_amg; /* Skip overloading entries. */
2026 #ifdef PERL_DONT_CREATE_GVSV
2028 NOOP; /* Equivalent to !SvTRUE and !SvOK */
2031 else if (SvTRUE(sv))
2032 amt.fallback=AMGfallYES;
2034 amt.fallback=AMGfallNEVER;
2036 for (i = 1; i < lim; i++)
2037 amt.table[i] = NULL;
2038 for (; i < NofAMmeth; i++) {
2039 const char * const cooky = PL_AMG_names[i];
2040 /* Human-readable form, for debugging: */
2041 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
2042 const STRLEN l = PL_AMG_namelens[i];
2044 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
2045 cp, HvNAME_get(stash)) );
2046 /* don't fill the cache while looking up!
2047 Creation of inheritance stubs in intermediate packages may
2048 conflict with the logic of runtime method substitution.
2049 Indeed, for inheritance A -> B -> C, if C overloads "+0",
2050 then we could have created stubs for "(+0" in A and C too.
2051 But if B overloads "bool", we may want to use it for
2052 numifying instead of C's "+0". */
2053 if (i >= DESTROY_amg)
2054 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
2055 else /* Autoload taken care of below */
2056 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
2058 if (gv && (cv = GvCV(gv))) {
2060 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
2061 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
2062 /* This is a hack to support autoloading..., while
2063 knowing *which* methods were declared as overloaded. */
2064 /* GvSV contains the name of the method. */
2066 SV *gvsv = GvSV(gv);
2068 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
2069 "\" for overloaded \"%s\" in package \"%.256s\"\n",
2070 (void*)GvSV(gv), cp, hvname) );
2071 if (!gvsv || !SvPOK(gvsv)
2072 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
2075 /* Can be an import stub (created by "can"). */
2080 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
2081 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
2082 "in package \"%.256s\"",
2083 (GvCVGEN(gv) ? "Stub found while resolving"
2088 cv = GvCV(gv = ngv);
2090 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
2091 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
2092 GvNAME(CvGV(cv))) );
2094 if (i < DESTROY_amg)
2096 } else if (gv) { /* Autoloaded... */
2097 cv = MUTABLE_CV(gv);
2100 amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
2103 AMT_AMAGIC_on(&amt);
2105 AMT_OVERLOADED_on(&amt);
2106 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2107 (char*)&amt, sizeof(AMT));
2111 /* Here we have no table: */
2113 AMT_AMAGIC_off(&amt);
2114 sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
2115 (char*)&amt, sizeof(AMTS));
2121 Perl_gv_handler(pTHX_ HV *stash, I32 id)
2127 struct mro_meta* stash_meta;
2129 if (!stash || !HvNAME_get(stash))
2132 stash_meta = HvMROMETA(stash);
2133 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
2135 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2138 /* If we're looking up a destructor to invoke, we must avoid
2139 * that Gv_AMupdate croaks, because we might be dying already */
2140 if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
2141 /* and if it didn't found a destructor, we fall back
2142 * to a simpler method that will only look for the
2143 * destructor instead of the whole magic */
2144 if (id == DESTROY_amg) {
2145 GV * const gv = gv_fetchmethod(stash, "DESTROY");
2151 mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
2154 amtp = (AMT*)mg->mg_ptr;
2155 if ( amtp->was_ok_am != PL_amagic_generation
2156 || amtp->was_ok_sub != newgen )
2158 if (AMT_AMAGIC(amtp)) {
2159 CV * const ret = amtp->table[id];
2160 if (ret && isGV(ret)) { /* Autoloading stab */
2161 /* Passing it through may have resulted in a warning
2162 "Inherited AUTOLOAD for a non-method deprecated", since
2163 our caller is going through a function call, not a method call.
2164 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
2165 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
2177 /* Implement tryAMAGICun_MG macro.
2178 Do get magic, then see if the stack arg is overloaded and if so call it.
2180 AMGf_set return the arg using SETs rather than assigning to
2182 AMGf_numeric apply sv_2num to the stack arg.
2186 Perl_try_amagic_un(pTHX_ int method, int flags) {
2190 SV* const arg = TOPs;
2194 if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
2195 AMGf_noright | AMGf_unary))) {
2196 if (flags & AMGf_set) {
2201 if (SvPADMY(TARG)) {
2202 sv_setsv(TARG, tmpsv);
2212 if ((flags & AMGf_numeric) && SvROK(arg))
2218 /* Implement tryAMAGICbin_MG macro.
2219 Do get magic, then see if the two stack args are overloaded and if so
2222 AMGf_set return the arg using SETs rather than assigning to
2224 AMGf_assign op may be called as mutator (eg +=)
2225 AMGf_numeric apply sv_2num to the stack arg.
2229 Perl_try_amagic_bin(pTHX_ int method, int flags) {
2232 SV* const left = TOPm1s;
2233 SV* const right = TOPs;
2239 if (SvAMAGIC(left) || SvAMAGIC(right)) {
2240 SV * const tmpsv = amagic_call(left, right, method,
2241 ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
2243 if (flags & AMGf_set) {
2250 if (opASSIGN || SvPADMY(TARG)) {
2251 sv_setsv(TARG, tmpsv);
2261 if(left==right && SvGMAGICAL(left)) {
2262 SV * const left = sv_newmortal();
2264 /* Print the uninitialized warning now, so it includes the vari-
2267 if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
2268 sv_setsv_flags(left, &PL_sv_no, 0);
2270 else sv_setsv_flags(left, right, 0);
2273 if (flags & AMGf_numeric) {
2275 *(sp-1) = sv_2num(TOPm1s);
2277 *sp = sv_2num(right);
2283 Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
2286 PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
2288 while (SvAMAGIC(ref) &&
2289 (tmpsv = amagic_call(ref, &PL_sv_undef, method,
2290 AMGf_noright | AMGf_unary))) {
2292 Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
2293 if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
2294 /* Bail out if it returns us the same reference. */
2299 return tmpsv ? tmpsv : ref;
2303 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2308 CV **cvp=NULL, **ocvp=NULL;
2309 AMT *amtp=NULL, *oamtp=NULL;
2310 int off = 0, off1, lr = 0, notfound = 0;
2311 int postpr = 0, force_cpy = 0;
2312 int assign = AMGf_assign & flags;
2313 const int assignshift = assign ? 1 : 0;
2314 int use_default_op = 0;
2320 PERL_ARGS_ASSERT_AMAGIC_CALL;
2322 if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2323 SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
2325 if ( !lex_mask || !SvOK(lex_mask) )
2326 /* overloading lexically disabled */
2328 else if ( lex_mask && SvPOK(lex_mask) ) {
2329 /* we have an entry in the hints hash, check if method has been
2330 * masked by overloading.pm */
2332 const int offset = method / 8;
2333 const int bit = method % 8;
2334 char *pv = SvPV(lex_mask, len);
2336 /* Bit set, so this overloading operator is disabled */
2337 if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2342 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2343 && (stash = SvSTASH(SvRV(left)))
2344 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2345 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2346 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2348 && ((cv = cvp[off=method+assignshift])
2349 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2355 cv = cvp[off=method])))) {
2356 lr = -1; /* Call method for left argument */
2358 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2361 /* look for substituted methods */
2362 /* In all the covered cases we should be called with assign==0. */
2366 if ((cv = cvp[off=add_ass_amg])
2367 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2368 right = &PL_sv_yes; lr = -1; assign = 1;
2373 if ((cv = cvp[off = subtr_ass_amg])
2374 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2375 right = &PL_sv_yes; lr = -1; assign = 1;
2379 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2382 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2385 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2388 (void)((cv = cvp[off=bool__amg])
2389 || (cv = cvp[off=numer_amg])
2390 || (cv = cvp[off=string_amg]));
2397 * SV* ref causes confusion with the interpreter variable of
2400 SV* const tmpRef=SvRV(left);
2401 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2403 * Just to be extra cautious. Maybe in some
2404 * additional cases sv_setsv is safe, too.
2406 SV* const newref = newSVsv(tmpRef);
2407 SvOBJECT_on(newref);
2408 /* As a bit of a source compatibility hack, SvAMAGIC() and
2409 friends dereference an RV, to behave the same was as when
2410 overloading was stored on the reference, not the referant.
2411 Hence we can't use SvAMAGIC_on()
2413 SvFLAGS(newref) |= SVf_AMAGIC;
2414 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2420 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2421 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2422 SV* const nullsv=sv_2mortal(newSViv(0));
2424 SV* const lessp = amagic_call(left,nullsv,
2425 lt_amg,AMGf_noright);
2426 logic = SvTRUE(lessp);
2428 SV* const lessp = amagic_call(left,nullsv,
2429 ncmp_amg,AMGf_noright);
2430 logic = (SvNV(lessp) < 0);
2433 if (off==subtr_amg) {
2444 if ((cv = cvp[off=subtr_amg])) {
2446 left = sv_2mortal(newSViv(0));
2451 case iter_amg: /* XXXX Eventually should do to_gv. */
2452 case ftest_amg: /* XXXX Eventually should do to_gv. */
2455 return NULL; /* Delegate operation to standard mechanisms. */
2463 return left; /* Delegate operation to standard mechanisms. */
2468 if (!cv) goto not_found;
2469 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2470 && (stash = SvSTASH(SvRV(right)))
2471 && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2472 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2473 ? (amtp = (AMT*)mg->mg_ptr)->table
2475 && (cv = cvp[off=method])) { /* Method for right
2478 } else if (((cvp && amtp->fallback > AMGfallNEVER)
2479 || (ocvp && oamtp->fallback > AMGfallNEVER))
2480 && !(flags & AMGf_unary)) {
2481 /* We look for substitution for
2482 * comparison operations and
2484 if (method==concat_amg || method==concat_ass_amg
2485 || method==repeat_amg || method==repeat_ass_amg) {
2486 return NULL; /* Delegate operation to string conversion */
2508 if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
2512 if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
2522 not_found: /* No method found, either report or croak */
2530 return left; /* Delegate operation to standard mechanisms. */
2533 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2534 notfound = 1; lr = -1;
2535 } else if (cvp && (cv=cvp[nomethod_amg])) {
2536 notfound = 1; lr = 1;
2537 } else if ((use_default_op =
2538 (!ocvp || oamtp->fallback >= AMGfallYES)
2539 && (!cvp || amtp->fallback >= AMGfallYES))
2541 /* Skip generating the "no method found" message. */
2545 if (off==-1) off=method;
2546 msg = sv_2mortal(Perl_newSVpvf(aTHX_
2547 "Operation \"%s\": no method found,%sargument %s%s%s%s",
2548 AMG_id2name(method + assignshift),
2549 (flags & AMGf_unary ? " " : "\n\tleft "),
2551 "in overloaded package ":
2552 "has no overloaded magic",
2554 HvNAME_get(SvSTASH(SvRV(left))):
2557 ",\n\tright argument in overloaded package ":
2560 : ",\n\tright argument has no overloaded magic"),
2562 HvNAME_get(SvSTASH(SvRV(right))):
2564 if (use_default_op) {
2565 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2567 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2571 force_cpy = force_cpy || assign;
2576 DEBUG_o(Perl_deb(aTHX_
2577 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2579 method+assignshift==off? "" :
2581 method+assignshift==off? "" :
2582 AMG_id2name(method+assignshift),
2583 method+assignshift==off? "" : "\")",
2584 flags & AMGf_unary? "" :
2585 lr==1 ? " for right argument": " for left argument",
2586 flags & AMGf_unary? " for argument" : "",
2587 stash ? HvNAME_get(stash) : "null",
2588 fl? ",\n\tassignment variant used": "") );
2591 /* Since we use shallow copy during assignment, we need
2592 * to dublicate the contents, probably calling user-supplied
2593 * version of copy operator
2595 /* We need to copy in following cases:
2596 * a) Assignment form was called.
2597 * assignshift==1, assign==T, method + 1 == off
2598 * b) Increment or decrement, called directly.
2599 * assignshift==0, assign==0, method + 0 == off
2600 * c) Increment or decrement, translated to assignment add/subtr.
2601 * assignshift==0, assign==T,
2603 * d) Increment or decrement, translated to nomethod.
2604 * assignshift==0, assign==0,
2606 * e) Assignment form translated to nomethod.
2607 * assignshift==1, assign==T, method + 1 != off
2610 /* off is method, method+assignshift, or a result of opcode substitution.
2611 * In the latter case assignshift==0, so only notfound case is important.
2613 if (( (method + assignshift == off)
2614 && (assign || (method == inc_amg) || (method == dec_amg)))
2617 /* newSVsv does not behave as advertised, so we copy missing
2618 * information by hand */
2619 SV *tmpRef = SvRV(left);
2621 if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
2622 SvRV_set(left, rv_copy);
2624 SvREFCNT_dec(tmpRef);
2632 const bool oldcatch = CATCH_GET;
2635 Zero(&myop, 1, BINOP);
2636 myop.op_last = (OP *) &myop;
2637 myop.op_next = NULL;
2638 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2640 PUSHSTACKi(PERLSI_OVERLOAD);
2643 PL_op = (OP *) &myop;
2644 if (PERLDB_SUB && PL_curstash != PL_debstash)
2645 PL_op->op_private |= OPpENTERSUB_DB;
2647 Perl_pp_pushmark(aTHX);
2649 EXTEND(SP, notfound + 5);
2650 PUSHs(lr>0? right: left);
2651 PUSHs(lr>0? left: right);
2652 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2654 PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2655 AMG_id2namelen(method + assignshift), SVs_TEMP));
2657 PUSHs(MUTABLE_SV(cv));
2660 if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2668 CATCH_SET(oldcatch);
2675 ans=SvIV(res)<=0; break;
2678 ans=SvIV(res)<0; break;
2681 ans=SvIV(res)>=0; break;
2684 ans=SvIV(res)>0; break;
2687 ans=SvIV(res)==0; break;
2690 ans=SvIV(res)!=0; break;
2693 SvSetSV(left,res); return left;
2695 ans=!SvTRUE(res); break;
2700 } else if (method==copy_amg) {
2702 Perl_croak(aTHX_ "Copy method did not return a reference");
2704 return SvREFCNT_inc(SvRV(res));
2712 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2717 PERL_ARGS_ASSERT_GV_NAME_SET;
2718 PERL_UNUSED_ARG(flags);
2721 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2723 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2724 unshare_hek(GvNAME_HEK(gv));
2727 PERL_HASH(hash, name, len);
2728 GvNAME_HEK(gv) = share_hek(name, len, hash);
2732 =for apidoc gv_try_downgrade
2734 If the typeglob C<gv> can be expressed more succinctly, by having
2735 something other than a real GV in its place in the stash, replace it
2736 with the optimised form. Basic requirements for this are that C<gv>
2737 is a real typeglob, is sufficiently ordinary, and is only referenced
2738 from its package. This function is meant to be used when a GV has been
2739 looked up in part to see what was there, causing upgrading, but based
2740 on what was found it turns out that the real GV isn't required after all.
2742 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2744 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2745 sub, the typeglob is replaced with a scalar-reference placeholder that
2746 more compactly represents the same thing.
2752 Perl_gv_try_downgrade(pTHX_ GV *gv)
2758 PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2760 /* XXX Why and where does this leave dangling pointers during global
2762 if (PL_phase == PERL_PHASE_DESTRUCT) return;
2764 if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2765 !SvOBJECT(gv) && !SvREADONLY(gv) &&
2766 isGV_with_GP(gv) && GvGP(gv) &&
2767 !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2768 !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2769 GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2771 if (SvMAGICAL(gv)) {
2773 /* only backref magic is allowed */
2774 if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2776 for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2777 if (mg->mg_type != PERL_MAGIC_backref)
2783 HEK *gvnhek = GvNAME_HEK(gv);
2784 (void)hv_delete(stash, HEK_KEY(gvnhek),
2785 HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2786 } else if (GvMULTI(gv) && cv &&
2787 !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2788 CvSTASH(cv) == stash && CvGV(cv) == gv &&
2789 CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2790 !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2791 (namehek = GvNAME_HEK(gv)) &&
2792 (gvp = hv_fetch(stash, HEK_KEY(namehek),
2793 HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2795 SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2799 SvFLAGS(gv) = SVt_IV|SVf_ROK;
2800 SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2801 STRUCT_OFFSET(XPVIV, xiv_iv));
2802 SvRV_set(gv, value);
2809 core_xsub(pTHX_ CV* cv)
2812 "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
2818 * c-indentation-style: bsd
2820 * indent-tabs-mode: t
2823 * ex: set ts=8 sts=4 sw=4 noet: