3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 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,'
23 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
24 It is a structure that holds a pointer to a scalar, an array, a hash etc,
25 corresponding to $foo, @foo, %foo.
27 GVs are usually found as values in stashes (symbol table hashes) where
28 Perl stores its global variables.
38 static const char S_autoload[] = "AUTOLOAD";
39 static const STRLEN S_autolen = sizeof(S_autoload)-1;
42 #ifdef PERL_DONT_CREATE_GVSV
44 Perl_gv_SVadd(pTHX_ GV *gv)
46 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
47 Perl_croak(aTHX_ "Bad symbol for scalar");
55 Perl_gv_AVadd(pTHX_ register GV *gv)
57 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
58 Perl_croak(aTHX_ "Bad symbol for array");
65 Perl_gv_HVadd(pTHX_ register GV *gv)
67 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
68 Perl_croak(aTHX_ "Bad symbol for hash");
75 Perl_gv_IOadd(pTHX_ register GV *gv)
78 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
81 * if it walks like a dirhandle, then let's assume that
82 * this is a dirhandle.
84 const char * const fh =
85 PL_op->op_type == OP_READDIR ||
86 PL_op->op_type == OP_TELLDIR ||
87 PL_op->op_type == OP_SEEKDIR ||
88 PL_op->op_type == OP_REWINDDIR ||
89 PL_op->op_type == OP_CLOSEDIR ?
90 "dirhandle" : "filehandle";
91 Perl_croak(aTHX_ "Bad symbol for %s", fh);
95 #ifdef GV_UNIQUE_CHECK
97 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
106 Perl_gv_fetchfile(pTHX_ const char *name)
108 return gv_fetchfile_flags(name, strlen(name), 0);
112 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
118 const STRLEN tmplen = namelen + 2;
121 PERL_UNUSED_ARG(flags);
126 if (tmplen <= sizeof smallbuf)
129 Newx(tmpbuf, tmplen, char);
130 /* This is where the debugger's %{"::_<$filename"} hash is created */
133 memcpy(tmpbuf + 2, name, namelen);
134 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
136 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
137 #ifdef PERL_DONT_CREATE_GVSV
138 GvSV(gv) = newSVpvn(name, namelen);
140 sv_setpvn(GvSV(gv), name, namelen);
143 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
145 if (tmpbuf != smallbuf)
151 =for apidoc gv_const_sv
153 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
154 inlining, or C<gv> is a placeholder reference that would be promoted to such
155 a typeglob, then returns the value returned by the sub. Otherwise, returns
162 Perl_gv_const_sv(pTHX_ GV *gv)
164 if (SvTYPE(gv) == SVt_PVGV)
165 return cv_const_sv(GvCVu(gv));
166 return SvROK(gv) ? SvRV(gv) : NULL;
170 Perl_newGP(pTHX_ GV *const gv)
175 const char *const file
176 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
177 const STRLEN len = strlen(file);
179 SV *const temp_sv = CopFILESV(PL_curcop);
184 file = SvPVX(temp_sv);
185 len = SvCUR(temp_sv);
192 PERL_HASH(hash, file, len);
196 #ifndef PERL_DONT_CREATE_GVSV
197 gp->gp_sv = newSV(0);
200 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
201 /* XXX Ideally this cast would be replaced with a change to const char*
203 gp->gp_file_hek = share_hek(file, len, hash);
211 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
214 const U32 old_type = SvTYPE(gv);
215 const bool doproto = old_type > SVt_NULL;
216 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
217 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
218 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
220 assert (!(proto && has_constant));
223 /* The constant has to be a simple scalar type. */
224 switch (SvTYPE(has_constant)) {
230 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
231 sv_reftype(has_constant, 0));
239 if (old_type < SVt_PVGV) {
240 if (old_type >= SVt_PV)
242 sv_upgrade((SV*)gv, SVt_PVGV);
250 Safefree(SvPVX_mutable(gv));
255 GvGP(gv) = Perl_newGP(aTHX_ gv);
258 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
259 gv_name_set(gv, name, len, GV_ADD);
260 if (multi || doproto) /* doproto means it _was_ mentioned */
262 if (doproto) { /* Replicate part of newSUB here. */
265 /* newCONSTSUB takes ownership of the reference from us. */
266 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
267 /* If this reference was a copy of another, then the subroutine
268 must have been "imported", by a Perl space assignment to a GV
269 from a reference to CV. */
270 if (exported_constant)
271 GvIMPORTED_CV_on(gv);
273 (void) start_subparse(0,0); /* Create empty CV in compcv. */
274 GvCV(gv) = PL_compcv;
278 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
280 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
281 CvSTASH(GvCV(gv)) = PL_curstash;
283 sv_setpv((SV*)GvCV(gv), proto);
290 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
302 #ifdef PERL_DONT_CREATE_GVSV
310 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
311 If we just cast GvSVn(gv) to void, it ignores evaluating it for
319 =for apidoc gv_fetchmeth
321 Returns the glob with the given C<name> and a defined subroutine or
322 C<NULL>. The glob lives in the given C<stash>, or in the stashes
323 accessible via @ISA and UNIVERSAL::.
325 The argument C<level> should be either 0 or -1. If C<level==0>, as a
326 side-effect creates a glob with the given C<name> in the given C<stash>
327 which in the case of success contains an alias for the subroutine, and sets
328 up caching info for this glob.
330 This function grants C<"SUPER"> token as a postfix of the stash name. The
331 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
332 visible to Perl code. So when calling C<call_sv>, you should not use
333 the GV directly; instead, you should use the method's CV, which can be
334 obtained from the GV with the C<GvCV> macro.
339 /* NOTE: No support for tied ISA */
342 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
350 GV* candidate = NULL;
355 I32 create = (level >= 0) ? 1 : 0;
360 /* UNIVERSAL methods should be callable without a stash */
362 create = 0; /* probably appropriate */
363 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
369 hvname = HvNAME_get(stash);
371 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
376 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
378 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
380 /* check locally for a real method or a cache entry */
381 gvp = (GV**)hv_fetch(stash, name, len, create);
385 if (SvTYPE(topgv) != SVt_PVGV)
386 gv_init(topgv, stash, name, len, TRUE);
387 if ((cand_cv = GvCV(topgv))) {
388 /* If genuine method or valid cache entry, use it */
389 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
393 /* stale cache entry, junk it and move on */
394 SvREFCNT_dec(cand_cv);
395 GvCV(topgv) = cand_cv = NULL;
399 else if (GvCVGEN(topgv) == topgen_cmp) {
400 /* cache indicates no such method definitively */
405 packlen = HvNAMELEN_get(stash);
406 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
409 basestash = gv_stashpvn(hvname, packlen, GV_ADD);
410 linear_av = mro_get_linear_isa(basestash);
413 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
416 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
417 items = AvFILLp(linear_av); /* no +1, to skip over self */
419 linear_sv = *linear_svp++;
421 cstash = gv_stashsv(linear_sv, 0);
424 if (ckWARN(WARN_SYNTAX))
425 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
426 SVfARG(linear_sv), hvname);
432 gvp = (GV**)hv_fetch(cstash, name, len, 0);
436 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
437 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
439 * Found real method, cache method in topgv if:
440 * 1. topgv has no synonyms (else inheritance crosses wires)
441 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
443 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
444 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
445 SvREFCNT_inc_simple_void_NN(cand_cv);
446 GvCV(topgv) = cand_cv;
447 GvCVGEN(topgv) = topgen_cmp;
453 /* Check UNIVERSAL without caching */
454 if(level == 0 || level == -1) {
455 candidate = gv_fetchmeth(NULL, name, len, 1);
457 cand_cv = GvCV(candidate);
458 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
459 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
460 SvREFCNT_inc_simple_void_NN(cand_cv);
461 GvCV(topgv) = cand_cv;
462 GvCVGEN(topgv) = topgen_cmp;
468 if (topgv && GvREFCNT(topgv) == 1) {
469 /* cache the fact that the method is not defined */
470 GvCVGEN(topgv) = topgen_cmp;
477 =for apidoc gv_fetchmeth_autoload
479 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
480 Returns a glob for the subroutine.
482 For an autoloaded subroutine without a GV, will create a GV even
483 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
484 of the result may be zero.
490 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
492 GV *gv = gv_fetchmeth(stash, name, len, level);
499 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
500 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
502 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
505 if (!(CvROOT(cv) || CvXSUB(cv)))
507 /* Have an autoload */
508 if (level < 0) /* Cannot do without a stub */
509 gv_fetchmeth(stash, name, len, 0);
510 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
519 =for apidoc gv_fetchmethod_autoload
521 Returns the glob which contains the subroutine to call to invoke the method
522 on the C<stash>. In fact in the presence of autoloading this may be the
523 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
526 The third parameter of C<gv_fetchmethod_autoload> determines whether
527 AUTOLOAD lookup is performed if the given method is not present: non-zero
528 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
529 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
530 with a non-zero C<autoload> parameter.
532 These functions grant C<"SUPER"> token as a prefix of the method name. Note
533 that if you want to keep the returned glob for a long time, you need to
534 check for it being "AUTOLOAD", since at the later time the call may load a
535 different subroutine due to $AUTOLOAD changing its value. Use the glob
536 created via a side effect to do this.
538 These functions have the same side-effects and as C<gv_fetchmeth> with
539 C<level==0>. C<name> should be writable if contains C<':'> or C<'
540 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
541 C<call_sv> apply equally to these functions.
547 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
554 stash = gv_stashpvn(name, namelen, 0);
555 if(stash) return stash;
557 /* If we must create it, give it an @ISA array containing
558 the real package this SUPER is for, so that it's tied
559 into the cache invalidation code correctly */
560 stash = gv_stashpvn(name, namelen, GV_ADD);
561 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
563 gv_init(gv, stash, "ISA", 3, TRUE);
564 superisa = GvAVn(gv);
566 sv_magic((SV*)superisa, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
568 av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
570 av_push(superisa, newSVhek(CopSTASH(PL_curcop)
571 ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
578 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
581 register const char *nend;
582 const char *nsplit = NULL;
586 if (stash && SvTYPE(stash) < SVt_PVHV)
589 for (nend = name; *nend; nend++) {
592 else if (*nend == ':' && *(nend + 1) == ':')
596 const char * const origname = name;
600 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
601 /* ->SUPER::method should really be looked up in original stash */
602 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
603 CopSTASHPV(PL_curcop)));
604 /* __PACKAGE__::SUPER stash should be autovivified */
605 stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
606 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
607 origname, HvNAME_get(stash), name) );
610 /* don't autovifify if ->NoSuchStash::method */
611 stash = gv_stashpvn(origname, nsplit - origname, 0);
613 /* however, explicit calls to Pkg::SUPER::method may
614 happen, and may require autovivification to work */
615 if (!stash && (nsplit - origname) >= 7 &&
616 strnEQ(nsplit - 7, "::SUPER", 7) &&
617 gv_stashpvn(origname, nsplit - origname - 7, 0))
618 stash = gv_get_super_pkg(origname, nsplit - origname);
623 gv = gv_fetchmeth(stash, name, nend - name, 0);
625 if (strEQ(name,"import") || strEQ(name,"unimport"))
626 gv = (GV*)&PL_sv_yes;
628 gv = gv_autoload4(ostash, name, nend - name, TRUE);
631 CV* const cv = GvCV(gv);
632 if (!CvROOT(cv) && !CvXSUB(cv)) {
640 if (GvCV(stubgv) != cv) /* orphaned import */
643 autogv = gv_autoload4(GvSTASH(stubgv),
644 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
654 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
662 const char *packname = "";
663 STRLEN packname_len = 0;
665 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
668 if (SvTYPE(stash) < SVt_PVHV) {
669 packname = SvPV_const((SV*)stash, packname_len);
673 packname = HvNAME_get(stash);
674 packname_len = HvNAMELEN_get(stash);
677 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
681 if (!(CvROOT(cv) || CvXSUB(cv)))
685 * Inheriting AUTOLOAD for non-methods works ... for now.
687 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
688 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
690 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
691 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
692 packname, (int)len, name);
695 /* rather than lookup/init $AUTOLOAD here
696 * only to have the XSUB do another lookup for $AUTOLOAD
697 * and split that value on the last '::',
698 * pass along the same data via some unused fields in the CV
701 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
707 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
708 * The subroutine's original name may not be "AUTOLOAD", so we don't
709 * use that, but for lack of anything better we will use the sub's
710 * original package to look up $AUTOLOAD.
712 varstash = GvSTASH(CvGV(cv));
713 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
717 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
718 #ifdef PERL_DONT_CREATE_GVSV
719 GvSV(vargv) = newSV(0);
723 varsv = GvSVn(vargv);
724 sv_setpvn(varsv, packname, packname_len);
725 sv_catpvs(varsv, "::");
726 sv_catpvn(varsv, name, len);
731 /* require_tie_mod() internal routine for requiring a module
732 * that implements the logic of automatical ties like %! and %-
734 * The "gv" parameter should be the glob.
735 * "varpv" holds the name of the var, used for error messages.
736 * "namesv" holds the module name. Its refcount will be decremented.
737 * "methpv" holds the method name to test for to check that things
738 * are working reasonably close to as expected.
739 * "flags": if flag & 1 then save the scalar before loading.
740 * For the protection of $! to work (it is set by this routine)
741 * the sv slot must already be magicalized.
744 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
747 HV* stash = gv_stashsv(namesv, 0);
749 if (!stash || !(gv_fetchmethod(stash, methpv))) {
750 SV *module = newSVsv(namesv);
751 char varname = *varpv; /* varpv might be clobbered by load_module,
752 so save it. For the moment it's always
758 PUSHSTACKi(PERLSI_MAGIC);
759 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
763 stash = gv_stashsv(namesv, 0);
765 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
766 varname, SVfARG(namesv));
767 else if (!gv_fetchmethod(stash, methpv))
768 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
769 varname, SVfARG(namesv), methpv);
771 SvREFCNT_dec(namesv);
776 =for apidoc gv_stashpv
778 Returns a pointer to the stash for a specified package. Uses C<strlen> to
779 determine the length of C<name>, then calls C<gv_stashpvn()>.
785 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
787 return gv_stashpvn(name, strlen(name), create);
791 =for apidoc gv_stashpvn
793 Returns a pointer to the stash for a specified package. The C<namelen>
794 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
795 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
796 created if it does not already exist. If the package does not exist and
797 C<flags> is 0 (or any other setting that does not create packages) then NULL
805 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
812 if (namelen + 2 <= sizeof smallbuf)
815 Newx(tmpbuf, namelen + 2, char);
816 Copy(name,tmpbuf,namelen,char);
817 tmpbuf[namelen++] = ':';
818 tmpbuf[namelen++] = ':';
819 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
820 if (tmpbuf != smallbuf)
825 GvHV(tmpgv) = newHV();
827 if (!HvNAME_get(stash))
828 hv_name_set(stash, name, namelen, 0);
833 =for apidoc gv_stashsv
835 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
841 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
844 const char * const ptr = SvPV_const(sv,len);
845 return gv_stashpvn(ptr, len, flags);
850 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
851 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
855 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
857 const char * const nambeg = SvPV_const(name, len);
858 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
862 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
866 register const char *name = nambeg;
867 register GV *gv = NULL;
870 register const char *name_cursor;
872 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
873 const I32 no_expand = flags & GV_NOEXPAND;
874 const I32 add = flags & ~GV_NOADD_MASK;
875 const char *const name_end = nambeg + full_len;
876 const char *const name_em1 = name_end - 1;
878 if (flags & GV_NOTQUAL) {
879 /* Caller promised that there is no stash, so we can skip the check. */
884 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
885 /* accidental stringify on a GV? */
889 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
890 if ((*name_cursor == ':' && name_cursor < name_em1
891 && name_cursor[1] == ':')
892 || (*name_cursor == '\'' && name_cursor[1]))
896 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
899 len = name_cursor - name;
904 if (len + 2 <= (I32)sizeof (smallbuf))
907 Newx(tmpbuf, len+2, char);
908 Copy(name, tmpbuf, len, char);
911 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
912 gv = gvp ? *gvp : NULL;
913 if (gv && gv != (GV*)&PL_sv_undef) {
914 if (SvTYPE(gv) != SVt_PVGV)
915 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
919 if (tmpbuf != smallbuf)
921 if (!gv || gv == (GV*)&PL_sv_undef)
924 if (!(stash = GvHV(gv)))
925 stash = GvHV(gv) = newHV();
927 if (!HvNAME_get(stash))
928 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
931 if (*name_cursor == ':')
935 if (name == name_end)
936 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
939 len = name_cursor - name;
941 /* No stash in name, so see how we can default */
945 if (len && isIDFIRST_lazy(name)) {
954 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
955 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
956 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
960 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
965 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
966 && name[3] == 'I' && name[4] == 'N')
970 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
971 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
972 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
976 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
977 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
985 else if (IN_PERL_COMPILETIME) {
987 if (add && (PL_hints & HINT_STRICT_VARS) &&
988 sv_type != SVt_PVCV &&
989 sv_type != SVt_PVGV &&
990 sv_type != SVt_PVFM &&
991 sv_type != SVt_PVIO &&
992 !(len == 1 && sv_type == SVt_PV &&
993 (*name == 'a' || *name == 'b')) )
995 gvp = (GV**)hv_fetch(stash,name,len,0);
997 *gvp == (GV*)&PL_sv_undef ||
998 SvTYPE(*gvp) != SVt_PVGV)
1002 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
1003 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1004 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1006 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
1007 sv_type == SVt_PVAV ? '@' :
1008 sv_type == SVt_PVHV ? '%' : '$',
1011 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
1017 stash = CopSTASH(PL_curcop);
1020 stash = PL_defstash;
1023 /* By this point we should have a stash and a name */
1027 SV * const err = Perl_mess(aTHX_
1028 "Global symbol \"%s%s\" requires explicit package name",
1029 (sv_type == SVt_PV ? "$"
1030 : sv_type == SVt_PVAV ? "@"
1031 : sv_type == SVt_PVHV ? "%"
1034 if (USE_UTF8_IN_NAMES)
1037 gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
1039 /* symbol table under destruction */
1048 if (!SvREFCNT(stash)) /* symbol table under destruction */
1051 gvp = (GV**)hv_fetch(stash,name,len,add);
1052 if (!gvp || *gvp == (GV*)&PL_sv_undef)
1055 if (SvTYPE(gv) == SVt_PVGV) {
1058 gv_init_sv(gv, sv_type);
1059 if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1061 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1062 else if (*name == '-' || *name == '+')
1063 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1067 } else if (no_init) {
1069 } else if (no_expand && SvROK(gv)) {
1073 /* Adding a new symbol */
1075 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
1076 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1077 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1078 gv_init_sv(gv, sv_type);
1080 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1081 : (PL_dowarn & G_WARN_ON ) ) )
1084 /* set up magic where warranted */
1089 /* Nothing else to do.
1090 The compiler will probably turn the switch statement into a
1091 branch table. Make sure we avoid even that small overhead for
1092 the common case of lower case variable names. */
1096 const char * const name2 = name + 1;
1099 if (strEQ(name2, "RGV")) {
1100 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1102 else if (strEQ(name2, "RGVOUT")) {
1107 if (strnEQ(name2, "XPORT", 5))
1111 if (strEQ(name2, "SA")) {
1112 AV* const av = GvAVn(gv);
1114 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1115 /* NOTE: No support for tied ISA */
1116 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1117 && AvFILLp(av) == -1)
1120 av_push(av, newSVpvn(pname = "NDBM_File",9));
1121 gv_stashpvn(pname, 9, GV_ADD);
1122 av_push(av, newSVpvn(pname = "DB_File",7));
1123 gv_stashpvn(pname, 7, GV_ADD);
1124 av_push(av, newSVpvn(pname = "GDBM_File",9));
1125 gv_stashpvn(pname, 9, GV_ADD);
1126 av_push(av, newSVpvn(pname = "SDBM_File",9));
1127 gv_stashpvn(pname, 9, GV_ADD);
1128 av_push(av, newSVpvn(pname = "ODBM_File",9));
1129 gv_stashpvn(pname, 9, GV_ADD);
1134 if (strEQ(name2, "VERLOAD")) {
1135 HV* const hv = GvHVn(gv);
1137 hv_magic(hv, NULL, PERL_MAGIC_overload);
1141 if (strEQ(name2, "IG")) {
1145 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
1146 Newxz(PL_psig_name, SIG_SIZE, SV*);
1147 Newxz(PL_psig_pend, SIG_SIZE, int);
1151 hv_magic(hv, NULL, PERL_MAGIC_sig);
1152 for (i = 1; i < SIG_SIZE; i++) {
1153 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1155 sv_setsv(*init, &PL_sv_undef);
1157 PL_psig_name[i] = 0;
1158 PL_psig_pend[i] = 0;
1163 if (strEQ(name2, "ERSION"))
1166 case '\003': /* $^CHILD_ERROR_NATIVE */
1167 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1170 case '\005': /* $^ENCODING */
1171 if (strEQ(name2, "NCODING"))
1174 case '\015': /* $^MATCH */
1175 if (strEQ(name2, "ATCH"))
1177 case '\017': /* $^OPEN */
1178 if (strEQ(name2, "PEN"))
1181 case '\020': /* $^PREMATCH $^POSTMATCH */
1182 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1184 case '\024': /* ${^TAINT} */
1185 if (strEQ(name2, "AINT"))
1188 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1189 if (strEQ(name2, "NICODE"))
1191 if (strEQ(name2, "TF8LOCALE"))
1193 if (strEQ(name2, "TF8CACHE"))
1196 case '\027': /* $^WARNING_BITS */
1197 if (strEQ(name2, "ARNING_BITS"))
1210 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1212 /* This snippet is taken from is_gv_magical */
1213 const char *end = name + len;
1214 while (--end > name) {
1215 if (!isDIGIT(*end)) return gv;
1222 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1223 be case '\0' in this switch statement (ie a default case) */
1229 sv_type == SVt_PVAV ||
1230 sv_type == SVt_PVHV ||
1231 sv_type == SVt_PVCV ||
1232 sv_type == SVt_PVFM ||
1235 PL_sawampersand = TRUE;
1239 sv_setpv(GvSVn(gv),PL_chopset);
1243 #ifdef COMPLEX_STATUS
1244 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1250 /* If %! has been used, automatically load Errno.pm. */
1252 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1254 /* magicalization must be done before require_tie_mod is called */
1255 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1256 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1261 GvMULTI_on(gv); /* no used once warnings here */
1263 AV* const av = GvAVn(gv);
1264 SV* const avc = (*name == '+') ? (SV*)av : NULL;
1266 sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0);
1267 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1269 SvREADONLY_on(GvSVn(gv));
1272 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1273 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1279 if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
1280 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1281 "$%c is no longer supported", *name);
1284 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1287 case '\010': /* $^H */
1289 HV *const hv = GvHVn(gv);
1290 hv_magic(hv, NULL, PERL_MAGIC_hints);
1293 case '\023': /* $^S */
1295 SvREADONLY_on(GvSVn(gv));
1319 case '\001': /* $^A */
1320 case '\003': /* $^C */
1321 case '\004': /* $^D */
1322 case '\005': /* $^E */
1323 case '\006': /* $^F */
1324 case '\011': /* $^I, NOT \t in EBCDIC */
1325 case '\016': /* $^N */
1326 case '\017': /* $^O */
1327 case '\020': /* $^P */
1328 case '\024': /* $^T */
1329 case '\027': /* $^W */
1331 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1334 case '\014': /* $^L */
1335 sv_setpvn(GvSVn(gv),"\f",1);
1336 PL_formfeed = GvSVn(gv);
1339 sv_setpvn(GvSVn(gv),"\034",1);
1343 SV * const sv = GvSVn(gv);
1344 if (!sv_derived_from(PL_patchlevel, "version"))
1345 upg_version(PL_patchlevel, TRUE);
1346 GvSV(gv) = vnumify(PL_patchlevel);
1347 SvREADONLY_on(GvSV(gv));
1351 case '\026': /* $^V */
1353 SV * const sv = GvSVn(gv);
1354 GvSV(gv) = new_version(PL_patchlevel);
1355 SvREADONLY_on(GvSV(gv));
1365 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1369 const HV * const hv = GvSTASH(gv);
1374 sv_setpv(sv, prefix ? prefix : "");
1376 name = HvNAME_get(hv);
1378 namelen = HvNAMELEN_get(hv);
1384 if (keepmain || strNE(name, "main")) {
1385 sv_catpvn(sv,name,namelen);
1388 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1392 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1394 const GV * const egv = GvEGV(gv);
1395 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1403 IO * const io = (IO*)newSV_type(SVt_PVIO);
1404 /* This used to read SvREFCNT(io) = 1;
1405 It's not clear why the reference count needed an explicit reset. NWC
1407 assert (SvREFCNT(io) == 1);
1409 /* Clear the stashcache because a new IO could overrule a package name */
1410 hv_clear(PL_stashcache);
1411 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1412 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1413 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1414 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1415 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1420 Perl_gv_check(pTHX_ const HV *stash)
1425 if (!HvARRAY(stash))
1427 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1429 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1432 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1433 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1435 if (hv != PL_defstash && hv != stash)
1436 gv_check(hv); /* nested package */
1438 else if (isALPHA(*HeKEY(entry))) {
1440 gv = (GV*)HeVAL(entry);
1441 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1444 CopLINE_set(PL_curcop, GvLINE(gv));
1446 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1448 CopFILEGV(PL_curcop)
1449 = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1451 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1452 "Name \"%s::%s\" used only once: possible typo",
1453 HvNAME_get(stash), GvNAME(gv));
1460 Perl_newGVgen(pTHX_ const char *pack)
1463 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1467 /* hopefully this is only called on local symbol table entries */
1470 Perl_gp_ref(pTHX_ GP *gp)
1478 /* If the GP they asked for a reference to contains
1479 a method cache entry, clear it first, so that we
1480 don't infect them with our cached entry */
1481 SvREFCNT_dec(gp->gp_cv);
1490 Perl_gp_free(pTHX_ GV *gv)
1495 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1497 if (gp->gp_refcnt == 0) {
1498 if (ckWARN_d(WARN_INTERNAL))
1499 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1500 "Attempt to free unreferenced glob pointers"
1501 pTHX__FORMAT pTHX__VALUE);
1504 if (--gp->gp_refcnt > 0) {
1505 if (gp->gp_egv == gv)
1511 if (gp->gp_file_hek)
1512 unshare_hek(gp->gp_file_hek);
1513 SvREFCNT_dec(gp->gp_sv);
1514 SvREFCNT_dec(gp->gp_av);
1515 /* FIXME - another reference loop GV -> symtab -> GV ?
1516 Somehow gp->gp_hv can end up pointing at freed garbage. */
1517 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1518 const char *hvname = HvNAME_get(gp->gp_hv);
1519 if (PL_stashcache && hvname)
1520 (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1522 SvREFCNT_dec(gp->gp_hv);
1524 SvREFCNT_dec(gp->gp_io);
1525 SvREFCNT_dec(gp->gp_cv);
1526 SvREFCNT_dec(gp->gp_form);
1533 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1535 AMT * const amtp = (AMT*)mg->mg_ptr;
1536 PERL_UNUSED_ARG(sv);
1538 if (amtp && AMT_AMAGIC(amtp)) {
1540 for (i = 1; i < NofAMmeth; i++) {
1541 CV * const cv = amtp->table[i];
1543 SvREFCNT_dec((SV *) cv);
1544 amtp->table[i] = NULL;
1551 /* Updates and caches the CV's */
1554 Perl_Gv_AMupdate(pTHX_ HV *stash)
1557 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1559 const struct mro_meta* stash_meta = HvMROMETA(stash);
1562 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1564 const AMT * const amtp = (AMT*)mg->mg_ptr;
1565 if (amtp->was_ok_am == PL_amagic_generation
1566 && amtp->was_ok_sub == newgen) {
1567 return (bool)AMT_OVERLOADED(amtp);
1569 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1572 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1575 amt.was_ok_am = PL_amagic_generation;
1576 amt.was_ok_sub = newgen;
1577 amt.fallback = AMGfallNO;
1581 int filled = 0, have_ovl = 0;
1584 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1586 /* Try to find via inheritance. */
1587 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1588 SV * const sv = gv ? GvSV(gv) : NULL;
1592 lim = DESTROY_amg; /* Skip overloading entries. */
1593 #ifdef PERL_DONT_CREATE_GVSV
1595 NOOP; /* Equivalent to !SvTRUE and !SvOK */
1598 else if (SvTRUE(sv))
1599 amt.fallback=AMGfallYES;
1601 amt.fallback=AMGfallNEVER;
1603 for (i = 1; i < lim; i++)
1604 amt.table[i] = NULL;
1605 for (; i < NofAMmeth; i++) {
1606 const char * const cooky = PL_AMG_names[i];
1607 /* Human-readable form, for debugging: */
1608 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1609 const STRLEN l = PL_AMG_namelens[i];
1611 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1612 cp, HvNAME_get(stash)) );
1613 /* don't fill the cache while looking up!
1614 Creation of inheritance stubs in intermediate packages may
1615 conflict with the logic of runtime method substitution.
1616 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1617 then we could have created stubs for "(+0" in A and C too.
1618 But if B overloads "bool", we may want to use it for
1619 numifying instead of C's "+0". */
1620 if (i >= DESTROY_amg)
1621 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1622 else /* Autoload taken care of below */
1623 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1625 if (gv && (cv = GvCV(gv))) {
1627 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1628 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1629 /* This is a hack to support autoloading..., while
1630 knowing *which* methods were declared as overloaded. */
1631 /* GvSV contains the name of the method. */
1633 SV *gvsv = GvSV(gv);
1635 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1636 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1637 (void*)GvSV(gv), cp, hvname) );
1638 if (!gvsv || !SvPOK(gvsv)
1639 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1642 /* Can be an import stub (created by "can"). */
1643 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1644 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1645 "in package \"%.256s\"",
1646 (GvCVGEN(gv) ? "Stub found while resolving"
1650 cv = GvCV(gv = ngv);
1652 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1653 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1654 GvNAME(CvGV(cv))) );
1656 if (i < DESTROY_amg)
1658 } else if (gv) { /* Autoloaded... */
1662 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1665 AMT_AMAGIC_on(&amt);
1667 AMT_OVERLOADED_on(&amt);
1668 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1669 (char*)&amt, sizeof(AMT));
1673 /* Here we have no table: */
1675 AMT_AMAGIC_off(&amt);
1676 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1677 (char*)&amt, sizeof(AMTS));
1683 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1689 struct mro_meta* stash_meta;
1691 if (!stash || !HvNAME_get(stash))
1694 stash_meta = HvMROMETA(stash);
1695 newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1697 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1701 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1704 amtp = (AMT*)mg->mg_ptr;
1705 if ( amtp->was_ok_am != PL_amagic_generation
1706 || amtp->was_ok_sub != newgen )
1708 if (AMT_AMAGIC(amtp)) {
1709 CV * const ret = amtp->table[id];
1710 if (ret && isGV(ret)) { /* Autoloading stab */
1711 /* Passing it through may have resulted in a warning
1712 "Inherited AUTOLOAD for a non-method deprecated", since
1713 our caller is going through a function call, not a method call.
1714 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1715 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1728 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1733 CV **cvp=NULL, **ocvp=NULL;
1734 AMT *amtp=NULL, *oamtp=NULL;
1735 int off = 0, off1, lr = 0, notfound = 0;
1736 int postpr = 0, force_cpy = 0;
1737 int assign = AMGf_assign & flags;
1738 const int assignshift = assign ? 1 : 0;
1743 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1744 && (stash = SvSTASH(SvRV(left)))
1745 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1746 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1747 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1749 && ((cv = cvp[off=method+assignshift])
1750 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1756 cv = cvp[off=method])))) {
1757 lr = -1; /* Call method for left argument */
1759 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1762 /* look for substituted methods */
1763 /* In all the covered cases we should be called with assign==0. */
1767 if ((cv = cvp[off=add_ass_amg])
1768 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1769 right = &PL_sv_yes; lr = -1; assign = 1;
1774 if ((cv = cvp[off = subtr_ass_amg])
1775 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1776 right = &PL_sv_yes; lr = -1; assign = 1;
1780 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1783 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1786 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1789 (void)((cv = cvp[off=bool__amg])
1790 || (cv = cvp[off=numer_amg])
1791 || (cv = cvp[off=string_amg]));
1797 * SV* ref causes confusion with the interpreter variable of
1800 SV* const tmpRef=SvRV(left);
1801 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1803 * Just to be extra cautious. Maybe in some
1804 * additional cases sv_setsv is safe, too.
1806 SV* const newref = newSVsv(tmpRef);
1807 SvOBJECT_on(newref);
1808 /* As a bit of a source compatibility hack, SvAMAGIC() and
1809 friends dereference an RV, to behave the same was as when
1810 overloading was stored on the reference, not the referant.
1811 Hence we can't use SvAMAGIC_on()
1813 SvFLAGS(newref) |= SVf_AMAGIC;
1814 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1820 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1821 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1822 SV* const nullsv=sv_2mortal(newSViv(0));
1824 SV* const lessp = amagic_call(left,nullsv,
1825 lt_amg,AMGf_noright);
1826 logic = SvTRUE(lessp);
1828 SV* const lessp = amagic_call(left,nullsv,
1829 ncmp_amg,AMGf_noright);
1830 logic = (SvNV(lessp) < 0);
1833 if (off==subtr_amg) {
1844 if ((cv = cvp[off=subtr_amg])) {
1846 left = sv_2mortal(newSViv(0));
1851 case iter_amg: /* XXXX Eventually should do to_gv. */
1853 return NULL; /* Delegate operation to standard mechanisms. */
1861 return left; /* Delegate operation to standard mechanisms. */
1866 if (!cv) goto not_found;
1867 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1868 && (stash = SvSTASH(SvRV(right)))
1869 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1870 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1871 ? (amtp = (AMT*)mg->mg_ptr)->table
1873 && (cv = cvp[off=method])) { /* Method for right
1876 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1877 && (cvp=ocvp) && (lr = -1))
1878 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1879 && !(flags & AMGf_unary)) {
1880 /* We look for substitution for
1881 * comparison operations and
1883 if (method==concat_amg || method==concat_ass_amg
1884 || method==repeat_amg || method==repeat_ass_amg) {
1885 return NULL; /* Delegate operation to string conversion */
1895 postpr = 1; off=ncmp_amg; break;
1902 postpr = 1; off=scmp_amg; break;
1904 if (off != -1) cv = cvp[off];
1909 not_found: /* No method found, either report or croak */
1930 return left; /* Delegate operation to standard mechanisms. */
1933 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1934 notfound = 1; lr = -1;
1935 } else if (cvp && (cv=cvp[nomethod_amg])) {
1936 notfound = 1; lr = 1;
1937 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1938 /* Skip generating the "no method found" message. */
1942 if (off==-1) off=method;
1943 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1944 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1945 AMG_id2name(method + assignshift),
1946 (flags & AMGf_unary ? " " : "\n\tleft "),
1948 "in overloaded package ":
1949 "has no overloaded magic",
1951 HvNAME_get(SvSTASH(SvRV(left))):
1954 ",\n\tright argument in overloaded package ":
1957 : ",\n\tright argument has no overloaded magic"),
1959 HvNAME_get(SvSTASH(SvRV(right))):
1961 if (amtp && amtp->fallback >= AMGfallYES) {
1962 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1964 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1968 force_cpy = force_cpy || assign;
1973 DEBUG_o(Perl_deb(aTHX_
1974 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1976 method+assignshift==off? "" :
1978 method+assignshift==off? "" :
1979 AMG_id2name(method+assignshift),
1980 method+assignshift==off? "" : "\")",
1981 flags & AMGf_unary? "" :
1982 lr==1 ? " for right argument": " for left argument",
1983 flags & AMGf_unary? " for argument" : "",
1984 stash ? HvNAME_get(stash) : "null",
1985 fl? ",\n\tassignment variant used": "") );
1988 /* Since we use shallow copy during assignment, we need
1989 * to dublicate the contents, probably calling user-supplied
1990 * version of copy operator
1992 /* We need to copy in following cases:
1993 * a) Assignment form was called.
1994 * assignshift==1, assign==T, method + 1 == off
1995 * b) Increment or decrement, called directly.
1996 * assignshift==0, assign==0, method + 0 == off
1997 * c) Increment or decrement, translated to assignment add/subtr.
1998 * assignshift==0, assign==T,
2000 * d) Increment or decrement, translated to nomethod.
2001 * assignshift==0, assign==0,
2003 * e) Assignment form translated to nomethod.
2004 * assignshift==1, assign==T, method + 1 != off
2007 /* off is method, method+assignshift, or a result of opcode substitution.
2008 * In the latter case assignshift==0, so only notfound case is important.
2010 if (( (method + assignshift == off)
2011 && (assign || (method == inc_amg) || (method == dec_amg)))
2018 const bool oldcatch = CATCH_GET;
2021 Zero(&myop, 1, BINOP);
2022 myop.op_last = (OP *) &myop;
2023 myop.op_next = NULL;
2024 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2026 PUSHSTACKi(PERLSI_OVERLOAD);
2029 PL_op = (OP *) &myop;
2030 if (PERLDB_SUB && PL_curstash != PL_debstash)
2031 PL_op->op_private |= OPpENTERSUB_DB;
2035 EXTEND(SP, notfound + 5);
2036 PUSHs(lr>0? right: left);
2037 PUSHs(lr>0? left: right);
2038 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2040 PUSHs( sv_2mortal(newSVpvn(AMG_id2name(method + assignshift),
2041 AMG_id2namelen(method + assignshift))));
2046 if ((PL_op = Perl_pp_entersub(aTHX)))
2054 CATCH_SET(oldcatch);
2061 ans=SvIV(res)<=0; break;
2064 ans=SvIV(res)<0; break;
2067 ans=SvIV(res)>=0; break;
2070 ans=SvIV(res)>0; break;
2073 ans=SvIV(res)==0; break;
2076 ans=SvIV(res)!=0; break;
2079 SvSetSV(left,res); return left;
2081 ans=!SvTRUE(res); break;
2086 } else if (method==copy_amg) {
2088 Perl_croak(aTHX_ "Copy method did not return a reference");
2090 return SvREFCNT_inc(SvRV(res));
2098 =for apidoc is_gv_magical_sv
2100 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2106 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2109 const char * const temp = SvPV_const(name, len);
2110 return is_gv_magical(temp, len, flags);
2114 =for apidoc is_gv_magical
2116 Returns C<TRUE> if given the name of a magical GV.
2118 Currently only useful internally when determining if a GV should be
2119 created even in rvalue contexts.
2121 C<flags> is not used at present but available for future extension to
2122 allow selecting particular classes of magical variable.
2124 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2125 This assumption is met by all callers within the perl core, which all pass
2126 pointers returned by SvPV.
2131 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2133 PERL_UNUSED_CONTEXT;
2134 PERL_UNUSED_ARG(flags);
2137 const char * const name1 = name + 1;
2140 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2144 if (len == 8 && strEQ(name1, "VERLOAD"))
2148 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2151 /* Using ${^...} variables is likely to be sufficiently rare that
2152 it seems sensible to avoid the space hit of also checking the
2154 case '\017': /* ${^OPEN} */
2155 if (strEQ(name1, "PEN"))
2158 case '\024': /* ${^TAINT} */
2159 if (strEQ(name1, "AINT"))
2162 case '\025': /* ${^UNICODE} */
2163 if (strEQ(name1, "NICODE"))
2165 if (strEQ(name1, "TF8LOCALE"))
2168 case '\027': /* ${^WARNING_BITS} */
2169 if (strEQ(name1, "ARNING_BITS"))
2182 const char *end = name + len;
2183 while (--end > name) {
2191 /* Because we're already assuming that name is NUL terminated
2192 below, we can treat an empty name as "\0" */
2219 case '\001': /* $^A */
2220 case '\003': /* $^C */
2221 case '\004': /* $^D */
2222 case '\005': /* $^E */
2223 case '\006': /* $^F */
2224 case '\010': /* $^H */
2225 case '\011': /* $^I, NOT \t in EBCDIC */
2226 case '\014': /* $^L */
2227 case '\016': /* $^N */
2228 case '\017': /* $^O */
2229 case '\020': /* $^P */
2230 case '\023': /* $^S */
2231 case '\024': /* $^T */
2232 case '\026': /* $^V */
2233 case '\027': /* $^W */
2253 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2259 PERL_UNUSED_ARG(flags);
2262 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2264 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2265 unshare_hek(GvNAME_HEK(gv));
2268 PERL_HASH(hash, name, len);
2269 GvNAME_HEK(gv) = share_hek(name, len, hash);
2274 * c-indentation-style: bsd
2276 * indent-tabs-mode: t
2279 * ex: set ts=8 sts=4 sw=4 noet: