3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
37 static const char S_autoload[] = "AUTOLOAD";
38 static const STRLEN S_autolen = sizeof(S_autoload)-1;
41 #ifdef PERL_DONT_CREATE_GVSV
43 Perl_gv_SVadd(pTHX_ GV *gv)
45 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
46 Perl_croak(aTHX_ "Bad symbol for scalar");
54 Perl_gv_AVadd(pTHX_ register GV *gv)
56 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
57 Perl_croak(aTHX_ "Bad symbol for array");
64 Perl_gv_HVadd(pTHX_ register GV *gv)
66 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
67 Perl_croak(aTHX_ "Bad symbol for hash");
74 Perl_gv_IOadd(pTHX_ register GV *gv)
77 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
80 * if it walks like a dirhandle, then let's assume that
81 * this is a dirhandle.
83 const char * const fh =
84 PL_op->op_type == OP_READDIR ||
85 PL_op->op_type == OP_TELLDIR ||
86 PL_op->op_type == OP_SEEKDIR ||
87 PL_op->op_type == OP_REWINDDIR ||
88 PL_op->op_type == OP_CLOSEDIR ?
89 "dirhandle" : "filehandle";
90 Perl_croak(aTHX_ "Bad symbol for %s", fh);
94 #ifdef GV_UNIQUE_CHECK
96 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
105 Perl_gv_fetchfile(pTHX_ const char *name)
116 tmplen = strlen(name) + 2;
117 if (tmplen < sizeof smallbuf)
120 Newx(tmpbuf, tmplen + 1, char);
121 /* This is where the debugger's %{"::_<$filename"} hash is created */
124 memcpy(tmpbuf + 2, name, tmplen - 1);
125 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
127 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
128 #ifdef PERL_DONT_CREATE_GVSV
129 GvSV(gv) = newSVpvn(name, tmplen - 2);
131 sv_setpvn(GvSV(gv), name, tmplen - 2);
134 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
136 if (tmpbuf != smallbuf)
142 =for apidoc gv_const_sv
144 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
145 inlining, or C<gv> is a placeholder reference that would be promoted to such
146 a typeglob, then returns the value returned by the sub. Otherwise, returns
153 Perl_gv_const_sv(pTHX_ GV *gv)
155 if (SvTYPE(gv) == SVt_PVGV)
156 return cv_const_sv(GvCVu(gv));
157 return SvROK(gv) ? SvRV(gv) : NULL;
161 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
165 const U32 old_type = SvTYPE(gv);
166 const bool doproto = old_type > SVt_NULL;
167 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
168 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
170 assert (!(proto && has_constant));
173 /* The constant has to be a simple scalar type. */
174 switch (SvTYPE(has_constant)) {
180 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
181 sv_reftype(has_constant, 0));
188 if (old_type < SVt_PVGV) {
189 if (old_type >= SVt_PV)
191 sv_upgrade((SV*)gv, SVt_PVGV);
199 Safefree(SvPVX_mutable(gv));
203 GvGP(gv) = gp_ref(gp);
204 #ifdef PERL_DONT_CREATE_GVSV
209 GvLINE(gv) = CopLINE(PL_curcop);
210 /* XXX Ideally this cast would be replaced with a change to const char*
212 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
217 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
218 gv_name_set(gv, name, len, GV_ADD);
219 if (multi || doproto) /* doproto means it _was_ mentioned */
221 if (doproto) { /* Replicate part of newSUB here. */
225 /* newCONSTSUB takes ownership of the reference from us. */
226 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
228 /* XXX unsafe for threads if eval_owner isn't held */
229 (void) start_subparse(0,0); /* Create empty CV in compcv. */
230 GvCV(gv) = PL_compcv;
236 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
237 CvSTASH(GvCV(gv)) = PL_curstash;
239 sv_setpv((SV*)GvCV(gv), proto);
246 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
258 #ifdef PERL_DONT_CREATE_GVSV
271 =for apidoc gv_fetchmeth
273 Returns the glob with the given C<name> and a defined subroutine or
274 C<NULL>. The glob lives in the given C<stash>, or in the stashes
275 accessible via @ISA and UNIVERSAL::.
277 The argument C<level> should be either 0 or -1. If C<level==0>, as a
278 side-effect creates a glob with the given C<name> in the given C<stash>
279 which in the case of success contains an alias for the subroutine, and sets
280 up caching info for this glob. Similarly for all the searched stashes.
282 This function grants C<"SUPER"> token as a postfix of the stash name. The
283 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
284 visible to Perl code. So when calling C<call_sv>, you should not use
285 the GV directly; instead, you should use the method's CV, which can be
286 obtained from the GV with the C<GvCV> macro.
292 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
302 /* UNIVERSAL methods should be callable without a stash */
304 level = -1; /* probably appropriate */
305 if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
309 hvname = HvNAME_get(stash);
312 "Can't use anonymous symbol table for method lookup");
314 if ((level > 100) || (level < -100))
315 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
318 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
320 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
325 if (SvTYPE(topgv) != SVt_PVGV)
326 gv_init(topgv, stash, name, len, TRUE);
327 if ((cv = GvCV(topgv))) {
328 /* If genuine method or valid cache entry, use it */
329 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
331 /* Stale cached entry: junk it */
333 GvCV(topgv) = cv = NULL;
336 else if (GvCVGEN(topgv) == PL_sub_generation)
337 return 0; /* cache indicates sub doesn't exist */
340 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
341 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
343 /* create and re-create @.*::SUPER::ISA on demand */
344 if (!av || !SvMAGIC(av)) {
345 STRLEN packlen = HvNAMELEN_get(stash);
347 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
351 basestash = gv_stashpvn(hvname, packlen, TRUE);
352 gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
353 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
354 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
355 if (!gvp || !(gv = *gvp))
356 Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
357 if (SvTYPE(gv) != SVt_PVGV)
358 gv_init(gv, stash, "ISA", 3, TRUE);
359 SvREFCNT_dec(GvAV(gv));
360 GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
366 SV** svp = AvARRAY(av);
367 /* NOTE: No support for tied ISA */
368 I32 items = AvFILLp(av) + 1;
370 SV* const sv = *svp++;
371 HV* const basestash = gv_stashsv(sv, FALSE);
373 if (ckWARN(WARN_MISC))
374 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
378 gv = gv_fetchmeth(basestash, name, len,
379 (level >= 0) ? level + 1 : level - 1);
385 /* if at top level, try UNIVERSAL */
387 if (level == 0 || level == -1) {
388 HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
391 if ((gv = gv_fetchmeth(lastchance, name, len,
392 (level >= 0) ? level + 1 : level - 1)))
396 * Cache method in topgv if:
397 * 1. topgv has no synonyms (else inheritance crosses wires)
398 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
401 GvREFCNT(topgv) == 1 &&
403 (CvROOT(cv) || CvXSUB(cv)))
405 if ((cv = GvCV(topgv)))
407 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
408 GvCVGEN(topgv) = PL_sub_generation;
412 else if (topgv && GvREFCNT(topgv) == 1) {
413 /* cache the fact that the method is not defined */
414 GvCVGEN(topgv) = PL_sub_generation;
423 =for apidoc gv_fetchmeth_autoload
425 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
426 Returns a glob for the subroutine.
428 For an autoloaded subroutine without a GV, will create a GV even
429 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
430 of the result may be zero.
436 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
438 GV *gv = gv_fetchmeth(stash, name, len, level);
445 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
446 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
448 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
451 if (!(CvROOT(cv) || CvXSUB(cv)))
453 /* Have an autoload */
454 if (level < 0) /* Cannot do without a stub */
455 gv_fetchmeth(stash, name, len, 0);
456 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
465 =for apidoc gv_fetchmethod_autoload
467 Returns the glob which contains the subroutine to call to invoke the method
468 on the C<stash>. In fact in the presence of autoloading this may be the
469 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
472 The third parameter of C<gv_fetchmethod_autoload> determines whether
473 AUTOLOAD lookup is performed if the given method is not present: non-zero
474 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
475 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
476 with a non-zero C<autoload> parameter.
478 These functions grant C<"SUPER"> token as a prefix of the method name. Note
479 that if you want to keep the returned glob for a long time, you need to
480 check for it being "AUTOLOAD", since at the later time the call may load a
481 different subroutine due to $AUTOLOAD changing its value. Use the glob
482 created via a side effect to do this.
484 These functions have the same side-effects and as C<gv_fetchmeth> with
485 C<level==0>. C<name> should be writable if contains C<':'> or C<'
486 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
487 C<call_sv> apply equally to these functions.
493 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
496 register const char *nend;
497 const char *nsplit = NULL;
501 if (stash && SvTYPE(stash) < SVt_PVHV)
504 for (nend = name; *nend; nend++) {
507 else if (*nend == ':' && *(nend + 1) == ':')
511 const char * const origname = name;
515 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
516 /* ->SUPER::method should really be looked up in original stash */
517 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
518 CopSTASHPV(PL_curcop)));
519 /* __PACKAGE__::SUPER stash should be autovivified */
520 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
521 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
522 origname, HvNAME_get(stash), name) );
525 /* don't autovifify if ->NoSuchStash::method */
526 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
528 /* however, explicit calls to Pkg::SUPER::method may
529 happen, and may require autovivification to work */
530 if (!stash && (nsplit - origname) >= 7 &&
531 strnEQ(nsplit - 7, "::SUPER", 7) &&
532 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
533 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
538 gv = gv_fetchmeth(stash, name, nend - name, 0);
540 if (strEQ(name,"import") || strEQ(name,"unimport"))
541 gv = (GV*)&PL_sv_yes;
543 gv = gv_autoload4(ostash, name, nend - name, TRUE);
546 CV* const cv = GvCV(gv);
547 if (!CvROOT(cv) && !CvXSUB(cv)) {
555 if (GvCV(stubgv) != cv) /* orphaned import */
558 autogv = gv_autoload4(GvSTASH(stubgv),
559 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
569 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
577 const char *packname = "";
578 STRLEN packname_len = 0;
580 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
583 if (SvTYPE(stash) < SVt_PVHV) {
584 packname = SvPV_const((SV*)stash, packname_len);
588 packname = HvNAME_get(stash);
589 packname_len = HvNAMELEN_get(stash);
592 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
596 if (!(CvROOT(cv) || CvXSUB(cv)))
600 * Inheriting AUTOLOAD for non-methods works ... for now.
602 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
603 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
605 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
606 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
607 packname, (int)len, name);
610 /* rather than lookup/init $AUTOLOAD here
611 * only to have the XSUB do another lookup for $AUTOLOAD
612 * and split that value on the last '::',
613 * pass along the same data via some unused fields in the CV
616 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
622 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
623 * The subroutine's original name may not be "AUTOLOAD", so we don't
624 * use that, but for lack of anything better we will use the sub's
625 * original package to look up $AUTOLOAD.
627 varstash = GvSTASH(CvGV(cv));
628 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
632 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
633 #ifdef PERL_DONT_CREATE_GVSV
634 GvSV(vargv) = newSV(0);
638 varsv = GvSVn(vargv);
639 sv_setpvn(varsv, packname, packname_len);
640 sv_catpvs(varsv, "::");
641 sv_catpvn(varsv, name, len);
642 SvTAINTED_off(varsv);
646 /* The "gv" parameter should be the glob known to Perl code as *!
647 * The scalar must already have been magicalized.
650 S_require_errno(pTHX_ GV *gv)
653 HV* stash = gv_stashpvs("Errno", FALSE);
655 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
659 save_scalar(gv); /* keep the value of $! */
660 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
661 newSVpvs("Errno"), NULL);
664 stash = gv_stashpvs("Errno", FALSE);
665 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
666 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
671 =for apidoc gv_stashpv
673 Returns a pointer to the stash for a specified package. C<name> should
674 be a valid UTF-8 string and must be null-terminated. If C<create> is set
675 then the package will be created if it does not already exist. If C<create>
676 is not set and the package does not exist then NULL is returned.
682 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
684 return gv_stashpvn(name, strlen(name), create);
688 =for apidoc gv_stashpvn
690 Returns a pointer to the stash for a specified package. C<name> should
691 be a valid UTF-8 string. The C<namelen> parameter indicates the length of
692 the C<name>, in bytes. If C<create> is set then the package will be
693 created if it does not already exist. If C<create> is not set and the
694 package does not exist then NULL is returned.
700 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
707 if (namelen + 3 < sizeof smallbuf)
710 Newx(tmpbuf, namelen + 3, char);
711 Copy(name,tmpbuf,namelen,char);
712 tmpbuf[namelen++] = ':';
713 tmpbuf[namelen++] = ':';
714 tmpbuf[namelen] = '\0';
715 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
716 if (tmpbuf != smallbuf)
721 GvHV(tmpgv) = newHV();
723 if (!HvNAME_get(stash))
724 hv_name_set(stash, name, namelen, 0);
729 =for apidoc gv_stashsv
731 Returns a pointer to the stash for a specified package, which must be a
732 valid UTF-8 string. See C<gv_stashpv>.
738 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
741 const char * const ptr = SvPV_const(sv,len);
742 return gv_stashpvn(ptr, len, create);
747 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
748 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
752 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
754 const char * const nambeg = SvPV_const(name, len);
755 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
759 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
763 register const char *name = nambeg;
764 register GV *gv = NULL;
767 register const char *name_cursor;
769 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
770 const I32 no_expand = flags & GV_NOEXPAND;
772 flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL;
773 const char *const name_end = nambeg + full_len;
774 const char *const name_em1 = name_end - 1;
776 if (flags & GV_NOTQUAL) {
777 /* Caller promised that there is no stash, so we can skip the check. */
782 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
783 /* accidental stringify on a GV? */
787 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
788 if ((*name_cursor == ':' && name_cursor < name_em1
789 && name_cursor[1] == ':')
790 || (*name_cursor == '\'' && name_cursor[1]))
794 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
797 len = name_cursor - name;
802 if (len + 3 < sizeof (smallbuf))
805 Newx(tmpbuf, len+3, char);
806 Copy(name, tmpbuf, len, char);
810 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
811 gv = gvp ? *gvp : NULL;
812 if (gv && gv != (GV*)&PL_sv_undef) {
813 if (SvTYPE(gv) != SVt_PVGV)
814 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
818 if (tmpbuf != smallbuf)
820 if (!gv || gv == (GV*)&PL_sv_undef)
823 if (!(stash = GvHV(gv)))
824 stash = GvHV(gv) = newHV();
826 if (!HvNAME_get(stash))
827 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
830 if (*name_cursor == ':')
834 if (name == name_end)
835 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
838 len = name_cursor - name;
840 /* No stash in name, so see how we can default */
844 if (len && isIDFIRST_lazy(name)) {
853 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
854 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
855 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
859 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
864 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
865 && name[3] == 'I' && name[4] == 'N')
869 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
870 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
871 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
875 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
876 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
884 else if (IN_PERL_COMPILETIME) {
886 if (add && (PL_hints & HINT_STRICT_VARS) &&
887 sv_type != SVt_PVCV &&
888 sv_type != SVt_PVGV &&
889 sv_type != SVt_PVFM &&
890 sv_type != SVt_PVIO &&
891 !(len == 1 && sv_type == SVt_PV &&
892 (*name == 'a' || *name == 'b')) )
894 gvp = (GV**)hv_fetch(stash,name,len,0);
896 *gvp == (GV*)&PL_sv_undef ||
897 SvTYPE(*gvp) != SVt_PVGV)
901 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
902 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
903 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
905 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
906 sv_type == SVt_PVAV ? '@' :
907 sv_type == SVt_PVHV ? '%' : '$',
910 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
916 stash = CopSTASH(PL_curcop);
922 /* By this point we should have a stash and a name */
926 SV * const err = Perl_mess(aTHX_
927 "Global symbol \"%s%s\" requires explicit package name",
928 (sv_type == SVt_PV ? "$"
929 : sv_type == SVt_PVAV ? "@"
930 : sv_type == SVt_PVHV ? "%"
932 if (USE_UTF8_IN_NAMES)
935 stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
941 if (!SvREFCNT(stash)) /* symbol table under destruction */
944 gvp = (GV**)hv_fetch(stash,name,len,add);
945 if (!gvp || *gvp == (GV*)&PL_sv_undef)
948 if (SvTYPE(gv) == SVt_PVGV) {
951 gv_init_sv(gv, sv_type);
952 if (*name=='!' && sv_type == SVt_PVHV && len==1)
956 } else if (no_init) {
958 } else if (no_expand && SvROK(gv)) {
962 /* Adding a new symbol */
964 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
965 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
966 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
967 gv_init_sv(gv, sv_type);
969 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
970 : (PL_dowarn & G_WARN_ON ) ) )
973 /* set up magic where warranted */
978 /* Nothing else to do.
979 The compiler will probably turn the switch statement into a
980 branch table. Make sure we avoid even that small overhead for
981 the common case of lower case variable names. */
985 const char * const name2 = name + 1;
988 if (strEQ(name2, "RGV")) {
989 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
993 if (strnEQ(name2, "XPORT", 5))
997 if (strEQ(name2, "SA")) {
998 AV* const av = GvAVn(gv);
1000 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1001 /* NOTE: No support for tied ISA */
1002 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1003 && AvFILLp(av) == -1)
1006 av_push(av, newSVpvn(pname = "NDBM_File",9));
1007 gv_stashpvn(pname, 9, TRUE);
1008 av_push(av, newSVpvn(pname = "DB_File",7));
1009 gv_stashpvn(pname, 7, TRUE);
1010 av_push(av, newSVpvn(pname = "GDBM_File",9));
1011 gv_stashpvn(pname, 9, TRUE);
1012 av_push(av, newSVpvn(pname = "SDBM_File",9));
1013 gv_stashpvn(pname, 9, TRUE);
1014 av_push(av, newSVpvn(pname = "ODBM_File",9));
1015 gv_stashpvn(pname, 9, TRUE);
1020 if (strEQ(name2, "VERLOAD")) {
1021 HV* const hv = GvHVn(gv);
1023 hv_magic(hv, NULL, PERL_MAGIC_overload);
1027 if (strEQ(name2, "IG")) {
1031 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
1032 Newxz(PL_psig_name, SIG_SIZE, SV*);
1033 Newxz(PL_psig_pend, SIG_SIZE, int);
1037 hv_magic(hv, NULL, PERL_MAGIC_sig);
1038 for (i = 1; i < SIG_SIZE; i++) {
1039 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1041 sv_setsv(*init, &PL_sv_undef);
1043 PL_psig_name[i] = 0;
1044 PL_psig_pend[i] = 0;
1049 if (strEQ(name2, "ERSION"))
1052 case '\003': /* $^CHILD_ERROR_NATIVE */
1053 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1056 case '\005': /* $^ENCODING */
1057 if (strEQ(name2, "NCODING"))
1060 case '\017': /* $^OPEN */
1061 if (strEQ(name2, "PEN"))
1064 case '\024': /* ${^TAINT} */
1065 if (strEQ(name2, "AINT"))
1068 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1069 if (strEQ(name2, "NICODE"))
1071 if (strEQ(name2, "TF8LOCALE"))
1073 if (strEQ(name2, "TF8CACHE"))
1076 case '\027': /* $^WARNING_BITS */
1077 if (strEQ(name2, "ARNING_BITS"))
1090 /* ensures variable is only digits */
1091 /* ${"1foo"} fails this test (and is thus writeable) */
1092 /* added by japhy, but borrowed from is_gv_magical */
1093 const char *end = name + len;
1094 while (--end > name) {
1095 if (!isDIGIT(*end)) return gv;
1102 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1103 be case '\0' in this switch statement (ie a default case) */
1109 sv_type == SVt_PVAV ||
1110 sv_type == SVt_PVHV ||
1111 sv_type == SVt_PVCV ||
1112 sv_type == SVt_PVFM ||
1115 PL_sawampersand = TRUE;
1119 sv_setpv(GvSVn(gv),PL_chopset);
1123 #ifdef COMPLEX_STATUS
1124 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1130 /* If %! has been used, automatically load Errno.pm.
1131 The require will itself set errno, so in order to
1132 preserve its value we have to set up the magic
1133 now (rather than going to magicalize)
1136 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1138 if (sv_type == SVt_PVHV)
1144 AV* const av = GvAVn(gv);
1145 sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
1151 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1152 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1153 "$%c is no longer supported", *name);
1156 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1159 case '\010': /* $^H */
1161 HV *const hv = GvHVn(gv);
1162 hv_magic(hv, NULL, PERL_MAGIC_hints);
1168 AV* const av = GvAVn(gv);
1169 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1173 case '\023': /* $^S */
1184 SvREADONLY_on(GvSVn(gv));
1199 case '\001': /* $^A */
1200 case '\003': /* $^C */
1201 case '\004': /* $^D */
1202 case '\005': /* $^E */
1203 case '\006': /* $^F */
1204 case '\011': /* $^I, NOT \t in EBCDIC */
1205 case '\016': /* $^N */
1206 case '\017': /* $^O */
1207 case '\020': /* $^P */
1208 case '\024': /* $^T */
1209 case '\027': /* $^W */
1211 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1214 case '\014': /* $^L */
1215 sv_setpvn(GvSVn(gv),"\f",1);
1216 PL_formfeed = GvSVn(gv);
1219 sv_setpvn(GvSVn(gv),"\034",1);
1223 SV * const sv = GvSVn(gv);
1224 if (!sv_derived_from(PL_patchlevel, "version"))
1225 upg_version(PL_patchlevel);
1226 GvSV(gv) = vnumify(PL_patchlevel);
1227 SvREADONLY_on(GvSV(gv));
1231 case '\026': /* $^V */
1233 SV * const sv = GvSVn(gv);
1234 GvSV(gv) = new_version(PL_patchlevel);
1235 SvREADONLY_on(GvSV(gv));
1245 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1249 const HV * const hv = GvSTASH(gv);
1254 sv_setpv(sv, prefix ? prefix : "");
1256 name = HvNAME_get(hv);
1258 namelen = HvNAMELEN_get(hv);
1264 if (keepmain || strNE(name, "main")) {
1265 sv_catpvn(sv,name,namelen);
1268 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1272 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1274 const GV * const egv = GvEGV(gv);
1275 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1283 IO * const io = (IO*)newSV(0);
1285 sv_upgrade((SV *)io,SVt_PVIO);
1286 /* This used to read SvREFCNT(io) = 1;
1287 It's not clear why the reference count needed an explicit reset. NWC
1289 assert (SvREFCNT(io) == 1);
1291 /* Clear the stashcache because a new IO could overrule a package name */
1292 hv_clear(PL_stashcache);
1293 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1294 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1295 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1296 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1297 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1302 Perl_gv_check(pTHX_ HV *stash)
1307 if (!HvARRAY(stash))
1309 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1311 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1314 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1315 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1317 if (hv != PL_defstash && hv != stash)
1318 gv_check(hv); /* nested package */
1320 else if (isALPHA(*HeKEY(entry))) {
1322 gv = (GV*)HeVAL(entry);
1323 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1326 /* performance hack: if filename is absolute and it's a standard
1327 * module, don't bother warning */
1328 #ifdef MACOS_TRADITIONAL
1329 # define LIB_COMPONENT ":lib:"
1331 # define LIB_COMPONENT "/lib/"
1334 && PERL_FILE_IS_ABSOLUTE(file)
1335 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1339 CopLINE_set(PL_curcop, GvLINE(gv));
1341 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1343 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1345 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1346 "Name \"%s::%s\" used only once: possible typo",
1347 HvNAME_get(stash), GvNAME(gv));
1354 Perl_newGVgen(pTHX_ const char *pack)
1357 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1361 /* hopefully this is only called on local symbol table entries */
1364 Perl_gp_ref(pTHX_ GP *gp)
1372 /* multi-named GPs cannot be used for method cache */
1373 SvREFCNT_dec(gp->gp_cv);
1378 /* Adding a new name to a subroutine invalidates method cache */
1379 PL_sub_generation++;
1386 Perl_gp_free(pTHX_ GV *gv)
1391 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1393 if (gp->gp_refcnt == 0) {
1394 if (ckWARN_d(WARN_INTERNAL))
1395 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1396 "Attempt to free unreferenced glob pointers"
1397 pTHX__FORMAT pTHX__VALUE);
1401 /* Deleting the name of a subroutine invalidates method cache */
1402 PL_sub_generation++;
1404 if (--gp->gp_refcnt > 0) {
1405 if (gp->gp_egv == gv)
1411 SvREFCNT_dec(gp->gp_sv);
1412 SvREFCNT_dec(gp->gp_av);
1413 /* FIXME - another reference loop GV -> symtab -> GV ?
1414 Somehow gp->gp_hv can end up pointing at freed garbage. */
1415 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1416 const char *hvname = HvNAME_get(gp->gp_hv);
1417 if (PL_stashcache && hvname)
1418 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1420 SvREFCNT_dec(gp->gp_hv);
1422 SvREFCNT_dec(gp->gp_io);
1423 SvREFCNT_dec(gp->gp_cv);
1424 SvREFCNT_dec(gp->gp_form);
1431 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1433 AMT * const amtp = (AMT*)mg->mg_ptr;
1434 PERL_UNUSED_ARG(sv);
1436 if (amtp && AMT_AMAGIC(amtp)) {
1438 for (i = 1; i < NofAMmeth; i++) {
1439 CV * const cv = amtp->table[i];
1441 SvREFCNT_dec((SV *) cv);
1442 amtp->table[i] = NULL;
1449 /* Updates and caches the CV's */
1452 Perl_Gv_AMupdate(pTHX_ HV *stash)
1455 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1456 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1459 if (mg && amtp->was_ok_am == PL_amagic_generation
1460 && amtp->was_ok_sub == PL_sub_generation)
1461 return (bool)AMT_OVERLOADED(amtp);
1462 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1464 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1467 amt.was_ok_am = PL_amagic_generation;
1468 amt.was_ok_sub = PL_sub_generation;
1469 amt.fallback = AMGfallNO;
1473 int filled = 0, have_ovl = 0;
1476 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1478 /* Try to find via inheritance. */
1479 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1480 SV * const sv = gv ? GvSV(gv) : NULL;
1484 lim = DESTROY_amg; /* Skip overloading entries. */
1485 #ifdef PERL_DONT_CREATE_GVSV
1487 /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */
1490 else if (SvTRUE(sv))
1491 amt.fallback=AMGfallYES;
1493 amt.fallback=AMGfallNEVER;
1495 for (i = 1; i < lim; i++)
1496 amt.table[i] = NULL;
1497 for (; i < NofAMmeth; i++) {
1498 const char * const cooky = PL_AMG_names[i];
1499 /* Human-readable form, for debugging: */
1500 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1501 const STRLEN l = strlen(cooky);
1503 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1504 cp, HvNAME_get(stash)) );
1505 /* don't fill the cache while looking up!
1506 Creation of inheritance stubs in intermediate packages may
1507 conflict with the logic of runtime method substitution.
1508 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1509 then we could have created stubs for "(+0" in A and C too.
1510 But if B overloads "bool", we may want to use it for
1511 numifying instead of C's "+0". */
1512 if (i >= DESTROY_amg)
1513 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1514 else /* Autoload taken care of below */
1515 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1517 if (gv && (cv = GvCV(gv))) {
1519 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1520 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1521 /* This is a hack to support autoloading..., while
1522 knowing *which* methods were declared as overloaded. */
1523 /* GvSV contains the name of the method. */
1525 SV *gvsv = GvSV(gv);
1527 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1528 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1529 GvSV(gv), cp, hvname) );
1530 if (!gvsv || !SvPOK(gvsv)
1531 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1534 /* Can be an import stub (created by "can"). */
1535 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1536 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1537 "in package \"%.256s\"",
1538 (GvCVGEN(gv) ? "Stub found while resolving"
1542 cv = GvCV(gv = ngv);
1544 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1545 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1546 GvNAME(CvGV(cv))) );
1548 if (i < DESTROY_amg)
1550 } else if (gv) { /* Autoloaded... */
1554 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1557 AMT_AMAGIC_on(&amt);
1559 AMT_OVERLOADED_on(&amt);
1560 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1561 (char*)&amt, sizeof(AMT));
1565 /* Here we have no table: */
1567 AMT_AMAGIC_off(&amt);
1568 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1569 (char*)&amt, sizeof(AMTS));
1575 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1581 if (!stash || !HvNAME_get(stash))
1583 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1587 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1589 amtp = (AMT*)mg->mg_ptr;
1590 if ( amtp->was_ok_am != PL_amagic_generation
1591 || amtp->was_ok_sub != PL_sub_generation )
1593 if (AMT_AMAGIC(amtp)) {
1594 CV * const ret = amtp->table[id];
1595 if (ret && isGV(ret)) { /* Autoloading stab */
1596 /* Passing it through may have resulted in a warning
1597 "Inherited AUTOLOAD for a non-method deprecated", since
1598 our caller is going through a function call, not a method call.
1599 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1600 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1613 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1618 CV **cvp=NULL, **ocvp=NULL;
1619 AMT *amtp=NULL, *oamtp=NULL;
1620 int off = 0, off1, lr = 0, notfound = 0;
1621 int postpr = 0, force_cpy = 0;
1622 int assign = AMGf_assign & flags;
1623 const int assignshift = assign ? 1 : 0;
1628 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1629 && (stash = SvSTASH(SvRV(left)))
1630 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1631 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1632 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1634 && ((cv = cvp[off=method+assignshift])
1635 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1641 cv = cvp[off=method])))) {
1642 lr = -1; /* Call method for left argument */
1644 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1647 /* look for substituted methods */
1648 /* In all the covered cases we should be called with assign==0. */
1652 if ((cv = cvp[off=add_ass_amg])
1653 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1654 right = &PL_sv_yes; lr = -1; assign = 1;
1659 if ((cv = cvp[off = subtr_ass_amg])
1660 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1661 right = &PL_sv_yes; lr = -1; assign = 1;
1665 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1668 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1671 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1674 (void)((cv = cvp[off=bool__amg])
1675 || (cv = cvp[off=numer_amg])
1676 || (cv = cvp[off=string_amg]));
1682 * SV* ref causes confusion with the interpreter variable of
1685 SV* const tmpRef=SvRV(left);
1686 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1688 * Just to be extra cautious. Maybe in some
1689 * additional cases sv_setsv is safe, too.
1691 SV* const newref = newSVsv(tmpRef);
1692 SvOBJECT_on(newref);
1693 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1699 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1700 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1701 SV* const nullsv=sv_2mortal(newSViv(0));
1703 SV* const lessp = amagic_call(left,nullsv,
1704 lt_amg,AMGf_noright);
1705 logic = SvTRUE(lessp);
1707 SV* const lessp = amagic_call(left,nullsv,
1708 ncmp_amg,AMGf_noright);
1709 logic = (SvNV(lessp) < 0);
1712 if (off==subtr_amg) {
1723 if ((cv = cvp[off=subtr_amg])) {
1725 left = sv_2mortal(newSViv(0));
1730 case iter_amg: /* XXXX Eventually should do to_gv. */
1732 return NULL; /* Delegate operation to standard mechanisms. */
1740 return left; /* Delegate operation to standard mechanisms. */
1745 if (!cv) goto not_found;
1746 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1747 && (stash = SvSTASH(SvRV(right)))
1748 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1749 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1750 ? (amtp = (AMT*)mg->mg_ptr)->table
1752 && (cv = cvp[off=method])) { /* Method for right
1755 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1756 && (cvp=ocvp) && (lr = -1))
1757 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1758 && !(flags & AMGf_unary)) {
1759 /* We look for substitution for
1760 * comparison operations and
1762 if (method==concat_amg || method==concat_ass_amg
1763 || method==repeat_amg || method==repeat_ass_amg) {
1764 return NULL; /* Delegate operation to string conversion */
1774 postpr = 1; off=ncmp_amg; break;
1781 postpr = 1; off=scmp_amg; break;
1783 if (off != -1) cv = cvp[off];
1788 not_found: /* No method found, either report or croak */
1796 return left; /* Delegate operation to standard mechanisms. */
1799 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1800 notfound = 1; lr = -1;
1801 } else if (cvp && (cv=cvp[nomethod_amg])) {
1802 notfound = 1; lr = 1;
1805 if (off==-1) off=method;
1806 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1807 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1808 AMG_id2name(method + assignshift),
1809 (flags & AMGf_unary ? " " : "\n\tleft "),
1811 "in overloaded package ":
1812 "has no overloaded magic",
1814 HvNAME_get(SvSTASH(SvRV(left))):
1817 ",\n\tright argument in overloaded package ":
1820 : ",\n\tright argument has no overloaded magic"),
1822 HvNAME_get(SvSTASH(SvRV(right))):
1824 if (amtp && amtp->fallback >= AMGfallYES) {
1825 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1827 Perl_croak(aTHX_ "%"SVf, msg);
1831 force_cpy = force_cpy || assign;
1836 DEBUG_o(Perl_deb(aTHX_
1837 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1839 method+assignshift==off? "" :
1841 method+assignshift==off? "" :
1842 AMG_id2name(method+assignshift),
1843 method+assignshift==off? "" : "\")",
1844 flags & AMGf_unary? "" :
1845 lr==1 ? " for right argument": " for left argument",
1846 flags & AMGf_unary? " for argument" : "",
1847 stash ? HvNAME_get(stash) : "null",
1848 fl? ",\n\tassignment variant used": "") );
1851 /* Since we use shallow copy during assignment, we need
1852 * to dublicate the contents, probably calling user-supplied
1853 * version of copy operator
1855 /* We need to copy in following cases:
1856 * a) Assignment form was called.
1857 * assignshift==1, assign==T, method + 1 == off
1858 * b) Increment or decrement, called directly.
1859 * assignshift==0, assign==0, method + 0 == off
1860 * c) Increment or decrement, translated to assignment add/subtr.
1861 * assignshift==0, assign==T,
1863 * d) Increment or decrement, translated to nomethod.
1864 * assignshift==0, assign==0,
1866 * e) Assignment form translated to nomethod.
1867 * assignshift==1, assign==T, method + 1 != off
1870 /* off is method, method+assignshift, or a result of opcode substitution.
1871 * In the latter case assignshift==0, so only notfound case is important.
1873 if (( (method + assignshift == off)
1874 && (assign || (method == inc_amg) || (method == dec_amg)))
1881 const bool oldcatch = CATCH_GET;
1884 Zero(&myop, 1, BINOP);
1885 myop.op_last = (OP *) &myop;
1886 myop.op_next = NULL;
1887 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1889 PUSHSTACKi(PERLSI_OVERLOAD);
1892 PL_op = (OP *) &myop;
1893 if (PERLDB_SUB && PL_curstash != PL_debstash)
1894 PL_op->op_private |= OPpENTERSUB_DB;
1898 EXTEND(SP, notfound + 5);
1899 PUSHs(lr>0? right: left);
1900 PUSHs(lr>0? left: right);
1901 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1903 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1908 if ((PL_op = Perl_pp_entersub(aTHX)))
1916 CATCH_SET(oldcatch);
1923 ans=SvIV(res)<=0; break;
1926 ans=SvIV(res)<0; break;
1929 ans=SvIV(res)>=0; break;
1932 ans=SvIV(res)>0; break;
1935 ans=SvIV(res)==0; break;
1938 ans=SvIV(res)!=0; break;
1941 SvSetSV(left,res); return left;
1943 ans=!SvTRUE(res); break;
1948 } else if (method==copy_amg) {
1950 Perl_croak(aTHX_ "Copy method did not return a reference");
1952 return SvREFCNT_inc(SvRV(res));
1960 =for apidoc is_gv_magical_sv
1962 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1968 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1971 const char * const temp = SvPV_const(name, len);
1972 return is_gv_magical(temp, len, flags);
1976 =for apidoc is_gv_magical
1978 Returns C<TRUE> if given the name of a magical GV.
1980 Currently only useful internally when determining if a GV should be
1981 created even in rvalue contexts.
1983 C<flags> is not used at present but available for future extension to
1984 allow selecting particular classes of magical variable.
1986 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1987 This assumption is met by all callers within the perl core, which all pass
1988 pointers returned by SvPV.
1993 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1995 PERL_UNUSED_CONTEXT;
1996 PERL_UNUSED_ARG(flags);
1999 const char * const name1 = name + 1;
2002 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2006 if (len == 8 && strEQ(name1, "VERLOAD"))
2010 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2013 /* Using ${^...} variables is likely to be sufficiently rare that
2014 it seems sensible to avoid the space hit of also checking the
2016 case '\017': /* ${^OPEN} */
2017 if (strEQ(name1, "PEN"))
2020 case '\024': /* ${^TAINT} */
2021 if (strEQ(name1, "AINT"))
2024 case '\025': /* ${^UNICODE} */
2025 if (strEQ(name1, "NICODE"))
2027 if (strEQ(name1, "TF8LOCALE"))
2030 case '\027': /* ${^WARNING_BITS} */
2031 if (strEQ(name1, "ARNING_BITS"))
2044 const char *end = name + len;
2045 while (--end > name) {
2053 /* Because we're already assuming that name is NUL terminated
2054 below, we can treat an empty name as "\0" */
2081 case '\001': /* $^A */
2082 case '\003': /* $^C */
2083 case '\004': /* $^D */
2084 case '\005': /* $^E */
2085 case '\006': /* $^F */
2086 case '\010': /* $^H */
2087 case '\011': /* $^I, NOT \t in EBCDIC */
2088 case '\014': /* $^L */
2089 case '\016': /* $^N */
2090 case '\017': /* $^O */
2091 case '\020': /* $^P */
2092 case '\023': /* $^S */
2093 case '\024': /* $^T */
2094 case '\026': /* $^V */
2095 case '\027': /* $^W */
2115 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2120 PERL_UNUSED_ARG(flags);
2123 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2125 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2126 unshare_hek(GvNAME_HEK(gv));
2129 PERL_HASH(hash, name, len);
2130 GvNAME_HEK(gv) = name ? share_hek(name, len, hash) : 0;
2135 * c-indentation-style: bsd
2137 * indent-tabs-mode: t
2140 * ex: set ts=8 sts=4 sw=4 noet: