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 = "";
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"))
1074 case '\027': /* $^WARNING_BITS */
1075 if (strEQ(name2, "ARNING_BITS"))
1088 /* ensures variable is only digits */
1089 /* ${"1foo"} fails this test (and is thus writeable) */
1090 /* added by japhy, but borrowed from is_gv_magical */
1091 const char *end = name + len;
1092 while (--end > name) {
1093 if (!isDIGIT(*end)) return gv;
1100 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1101 be case '\0' in this switch statement (ie a default case) */
1107 sv_type == SVt_PVAV ||
1108 sv_type == SVt_PVHV ||
1109 sv_type == SVt_PVCV ||
1110 sv_type == SVt_PVFM ||
1113 PL_sawampersand = TRUE;
1117 sv_setpv(GvSVn(gv),PL_chopset);
1121 #ifdef COMPLEX_STATUS
1122 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1128 /* If %! has been used, automatically load Errno.pm.
1129 The require will itself set errno, so in order to
1130 preserve its value we have to set up the magic
1131 now (rather than going to magicalize)
1134 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1136 if (sv_type == SVt_PVHV)
1142 AV* const av = GvAVn(gv);
1143 sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
1149 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1150 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1151 "$%c is no longer supported", *name);
1154 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1159 AV* const av = GvAVn(gv);
1160 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1164 case '\023': /* $^S */
1175 SvREADONLY_on(GvSVn(gv));
1190 case '\001': /* $^A */
1191 case '\003': /* $^C */
1192 case '\004': /* $^D */
1193 case '\005': /* $^E */
1194 case '\006': /* $^F */
1195 case '\010': /* $^H */
1196 case '\011': /* $^I, NOT \t in EBCDIC */
1197 case '\016': /* $^N */
1198 case '\017': /* $^O */
1199 case '\020': /* $^P */
1200 case '\024': /* $^T */
1201 case '\027': /* $^W */
1203 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1206 case '\014': /* $^L */
1207 sv_setpvn(GvSVn(gv),"\f",1);
1208 PL_formfeed = GvSVn(gv);
1211 sv_setpvn(GvSVn(gv),"\034",1);
1215 SV * const sv = GvSVn(gv);
1216 if (!sv_derived_from(PL_patchlevel, "version"))
1217 upg_version(PL_patchlevel);
1218 GvSV(gv) = vnumify(PL_patchlevel);
1219 SvREADONLY_on(GvSV(gv));
1223 case '\026': /* $^V */
1225 SV * const sv = GvSVn(gv);
1226 GvSV(gv) = new_version(PL_patchlevel);
1227 SvREADONLY_on(GvSV(gv));
1237 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1241 const HV * const hv = GvSTASH(gv);
1246 sv_setpv(sv, prefix ? prefix : "");
1248 name = HvNAME_get(hv);
1250 namelen = HvNAMELEN_get(hv);
1256 if (keepmain || strNE(name, "main")) {
1257 sv_catpvn(sv,name,namelen);
1260 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1264 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1266 const GV * const egv = GvEGV(gv);
1267 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1275 IO * const io = (IO*)newSV(0);
1277 sv_upgrade((SV *)io,SVt_PVIO);
1278 /* This used to read SvREFCNT(io) = 1;
1279 It's not clear why the reference count needed an explicit reset. NWC
1281 assert (SvREFCNT(io) == 1);
1283 /* Clear the stashcache because a new IO could overrule a package name */
1284 hv_clear(PL_stashcache);
1285 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1286 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1287 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1288 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1289 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1294 Perl_gv_check(pTHX_ HV *stash)
1299 if (!HvARRAY(stash))
1301 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1303 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1306 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1307 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1309 if (hv != PL_defstash && hv != stash)
1310 gv_check(hv); /* nested package */
1312 else if (isALPHA(*HeKEY(entry))) {
1314 gv = (GV*)HeVAL(entry);
1315 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1318 /* performance hack: if filename is absolute and it's a standard
1319 * module, don't bother warning */
1320 #ifdef MACOS_TRADITIONAL
1321 # define LIB_COMPONENT ":lib:"
1323 # define LIB_COMPONENT "/lib/"
1326 && PERL_FILE_IS_ABSOLUTE(file)
1327 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1331 CopLINE_set(PL_curcop, GvLINE(gv));
1333 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1335 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1337 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1338 "Name \"%s::%s\" used only once: possible typo",
1339 HvNAME_get(stash), GvNAME(gv));
1346 Perl_newGVgen(pTHX_ const char *pack)
1349 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1353 /* hopefully this is only called on local symbol table entries */
1356 Perl_gp_ref(pTHX_ GP *gp)
1364 /* multi-named GPs cannot be used for method cache */
1365 SvREFCNT_dec(gp->gp_cv);
1370 /* Adding a new name to a subroutine invalidates method cache */
1371 PL_sub_generation++;
1378 Perl_gp_free(pTHX_ GV *gv)
1383 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1385 if (gp->gp_refcnt == 0) {
1386 if (ckWARN_d(WARN_INTERNAL))
1387 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1388 "Attempt to free unreferenced glob pointers"
1389 pTHX__FORMAT pTHX__VALUE);
1393 /* Deleting the name of a subroutine invalidates method cache */
1394 PL_sub_generation++;
1396 if (--gp->gp_refcnt > 0) {
1397 if (gp->gp_egv == gv)
1403 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1404 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1405 /* FIXME - another reference loop GV -> symtab -> GV ?
1406 Somehow gp->gp_hv can end up pointing at freed garbage. */
1407 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1408 const char *hvname = HvNAME_get(gp->gp_hv);
1409 if (PL_stashcache && hvname)
1410 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1412 SvREFCNT_dec(gp->gp_hv);
1414 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1415 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1416 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1423 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1425 AMT * const amtp = (AMT*)mg->mg_ptr;
1426 PERL_UNUSED_ARG(sv);
1428 if (amtp && AMT_AMAGIC(amtp)) {
1430 for (i = 1; i < NofAMmeth; i++) {
1431 CV * const cv = amtp->table[i];
1433 SvREFCNT_dec((SV *) cv);
1434 amtp->table[i] = NULL;
1441 /* Updates and caches the CV's */
1444 Perl_Gv_AMupdate(pTHX_ HV *stash)
1447 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1448 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1451 if (mg && amtp->was_ok_am == PL_amagic_generation
1452 && amtp->was_ok_sub == PL_sub_generation)
1453 return (bool)AMT_OVERLOADED(amtp);
1454 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1456 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1459 amt.was_ok_am = PL_amagic_generation;
1460 amt.was_ok_sub = PL_sub_generation;
1461 amt.fallback = AMGfallNO;
1465 int filled = 0, have_ovl = 0;
1468 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1470 /* Try to find via inheritance. */
1471 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1472 SV * const sv = gv ? GvSV(gv) : NULL;
1476 lim = DESTROY_amg; /* Skip overloading entries. */
1477 #ifdef PERL_DONT_CREATE_GVSV
1479 /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */
1482 else if (SvTRUE(sv))
1483 amt.fallback=AMGfallYES;
1485 amt.fallback=AMGfallNEVER;
1487 for (i = 1; i < lim; i++)
1488 amt.table[i] = NULL;
1489 for (; i < NofAMmeth; i++) {
1490 const char * const cooky = PL_AMG_names[i];
1491 /* Human-readable form, for debugging: */
1492 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1493 const STRLEN l = strlen(cooky);
1495 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1496 cp, HvNAME_get(stash)) );
1497 /* don't fill the cache while looking up!
1498 Creation of inheritance stubs in intermediate packages may
1499 conflict with the logic of runtime method substitution.
1500 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1501 then we could have created stubs for "(+0" in A and C too.
1502 But if B overloads "bool", we may want to use it for
1503 numifying instead of C's "+0". */
1504 if (i >= DESTROY_amg)
1505 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1506 else /* Autoload taken care of below */
1507 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1509 if (gv && (cv = GvCV(gv))) {
1511 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1512 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1513 /* This is a hack to support autoloading..., while
1514 knowing *which* methods were declared as overloaded. */
1515 /* GvSV contains the name of the method. */
1517 SV *gvsv = GvSV(gv);
1519 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1520 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1521 GvSV(gv), cp, hvname) );
1522 if (!gvsv || !SvPOK(gvsv)
1523 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1526 /* Can be an import stub (created by "can"). */
1527 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1528 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1529 "in package \"%.256s\"",
1530 (GvCVGEN(gv) ? "Stub found while resolving"
1534 cv = GvCV(gv = ngv);
1536 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1537 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1538 GvNAME(CvGV(cv))) );
1540 if (i < DESTROY_amg)
1542 } else if (gv) { /* Autoloaded... */
1546 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1549 AMT_AMAGIC_on(&amt);
1551 AMT_OVERLOADED_on(&amt);
1552 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1553 (char*)&amt, sizeof(AMT));
1557 /* Here we have no table: */
1559 AMT_AMAGIC_off(&amt);
1560 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1561 (char*)&amt, sizeof(AMTS));
1567 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1573 if (!stash || !HvNAME_get(stash))
1575 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1579 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1581 amtp = (AMT*)mg->mg_ptr;
1582 if ( amtp->was_ok_am != PL_amagic_generation
1583 || amtp->was_ok_sub != PL_sub_generation )
1585 if (AMT_AMAGIC(amtp)) {
1586 CV * const ret = amtp->table[id];
1587 if (ret && isGV(ret)) { /* Autoloading stab */
1588 /* Passing it through may have resulted in a warning
1589 "Inherited AUTOLOAD for a non-method deprecated", since
1590 our caller is going through a function call, not a method call.
1591 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1592 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1605 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1610 CV **cvp=NULL, **ocvp=NULL;
1611 AMT *amtp=NULL, *oamtp=NULL;
1612 int off = 0, off1, lr = 0, notfound = 0;
1613 int postpr = 0, force_cpy = 0;
1614 int assign = AMGf_assign & flags;
1615 const int assignshift = assign ? 1 : 0;
1620 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1621 && (stash = SvSTASH(SvRV(left)))
1622 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1623 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1624 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1626 && ((cv = cvp[off=method+assignshift])
1627 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1633 cv = cvp[off=method])))) {
1634 lr = -1; /* Call method for left argument */
1636 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1639 /* look for substituted methods */
1640 /* In all the covered cases we should be called with assign==0. */
1644 if ((cv = cvp[off=add_ass_amg])
1645 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1646 right = &PL_sv_yes; lr = -1; assign = 1;
1651 if ((cv = cvp[off = subtr_ass_amg])
1652 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1653 right = &PL_sv_yes; lr = -1; assign = 1;
1657 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1660 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1663 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1666 (void)((cv = cvp[off=bool__amg])
1667 || (cv = cvp[off=numer_amg])
1668 || (cv = cvp[off=string_amg]));
1674 * SV* ref causes confusion with the interpreter variable of
1677 SV* const tmpRef=SvRV(left);
1678 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1680 * Just to be extra cautious. Maybe in some
1681 * additional cases sv_setsv is safe, too.
1683 SV* const newref = newSVsv(tmpRef);
1684 SvOBJECT_on(newref);
1685 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1691 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1692 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1693 SV* const nullsv=sv_2mortal(newSViv(0));
1695 SV* const lessp = amagic_call(left,nullsv,
1696 lt_amg,AMGf_noright);
1697 logic = SvTRUE(lessp);
1699 SV* const lessp = amagic_call(left,nullsv,
1700 ncmp_amg,AMGf_noright);
1701 logic = (SvNV(lessp) < 0);
1704 if (off==subtr_amg) {
1715 if ((cv = cvp[off=subtr_amg])) {
1717 left = sv_2mortal(newSViv(0));
1722 case iter_amg: /* XXXX Eventually should do to_gv. */
1724 return NULL; /* Delegate operation to standard mechanisms. */
1732 return left; /* Delegate operation to standard mechanisms. */
1737 if (!cv) goto not_found;
1738 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1739 && (stash = SvSTASH(SvRV(right)))
1740 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1741 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1742 ? (amtp = (AMT*)mg->mg_ptr)->table
1744 && (cv = cvp[off=method])) { /* Method for right
1747 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1748 && (cvp=ocvp) && (lr = -1))
1749 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1750 && !(flags & AMGf_unary)) {
1751 /* We look for substitution for
1752 * comparison operations and
1754 if (method==concat_amg || method==concat_ass_amg
1755 || method==repeat_amg || method==repeat_ass_amg) {
1756 return NULL; /* Delegate operation to string conversion */
1766 postpr = 1; off=ncmp_amg; break;
1773 postpr = 1; off=scmp_amg; break;
1775 if (off != -1) cv = cvp[off];
1780 not_found: /* No method found, either report or croak */
1788 return left; /* Delegate operation to standard mechanisms. */
1791 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1792 notfound = 1; lr = -1;
1793 } else if (cvp && (cv=cvp[nomethod_amg])) {
1794 notfound = 1; lr = 1;
1797 if (off==-1) off=method;
1798 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1799 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1800 AMG_id2name(method + assignshift),
1801 (flags & AMGf_unary ? " " : "\n\tleft "),
1803 "in overloaded package ":
1804 "has no overloaded magic",
1806 HvNAME_get(SvSTASH(SvRV(left))):
1809 ",\n\tright argument in overloaded package ":
1812 : ",\n\tright argument has no overloaded magic"),
1814 HvNAME_get(SvSTASH(SvRV(right))):
1816 if (amtp && amtp->fallback >= AMGfallYES) {
1817 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1819 Perl_croak(aTHX_ "%"SVf, msg);
1823 force_cpy = force_cpy || assign;
1828 DEBUG_o(Perl_deb(aTHX_
1829 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1831 method+assignshift==off? "" :
1833 method+assignshift==off? "" :
1834 AMG_id2name(method+assignshift),
1835 method+assignshift==off? "" : "\")",
1836 flags & AMGf_unary? "" :
1837 lr==1 ? " for right argument": " for left argument",
1838 flags & AMGf_unary? " for argument" : "",
1839 stash ? HvNAME_get(stash) : "null",
1840 fl? ",\n\tassignment variant used": "") );
1843 /* Since we use shallow copy during assignment, we need
1844 * to dublicate the contents, probably calling user-supplied
1845 * version of copy operator
1847 /* We need to copy in following cases:
1848 * a) Assignment form was called.
1849 * assignshift==1, assign==T, method + 1 == off
1850 * b) Increment or decrement, called directly.
1851 * assignshift==0, assign==0, method + 0 == off
1852 * c) Increment or decrement, translated to assignment add/subtr.
1853 * assignshift==0, assign==T,
1855 * d) Increment or decrement, translated to nomethod.
1856 * assignshift==0, assign==0,
1858 * e) Assignment form translated to nomethod.
1859 * assignshift==1, assign==T, method + 1 != off
1862 /* off is method, method+assignshift, or a result of opcode substitution.
1863 * In the latter case assignshift==0, so only notfound case is important.
1865 if (( (method + assignshift == off)
1866 && (assign || (method == inc_amg) || (method == dec_amg)))
1873 const bool oldcatch = CATCH_GET;
1876 Zero(&myop, 1, BINOP);
1877 myop.op_last = (OP *) &myop;
1878 myop.op_next = NULL;
1879 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1881 PUSHSTACKi(PERLSI_OVERLOAD);
1884 PL_op = (OP *) &myop;
1885 if (PERLDB_SUB && PL_curstash != PL_debstash)
1886 PL_op->op_private |= OPpENTERSUB_DB;
1890 EXTEND(SP, notfound + 5);
1891 PUSHs(lr>0? right: left);
1892 PUSHs(lr>0? left: right);
1893 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1895 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1900 if ((PL_op = Perl_pp_entersub(aTHX)))
1908 CATCH_SET(oldcatch);
1915 ans=SvIV(res)<=0; break;
1918 ans=SvIV(res)<0; break;
1921 ans=SvIV(res)>=0; break;
1924 ans=SvIV(res)>0; break;
1927 ans=SvIV(res)==0; break;
1930 ans=SvIV(res)!=0; break;
1933 SvSetSV(left,res); return left;
1935 ans=!SvTRUE(res); break;
1940 } else if (method==copy_amg) {
1942 Perl_croak(aTHX_ "Copy method did not return a reference");
1944 return SvREFCNT_inc(SvRV(res));
1952 =for apidoc is_gv_magical_sv
1954 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1960 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1963 const char * const temp = SvPV_const(name, len);
1964 return is_gv_magical(temp, len, flags);
1968 =for apidoc is_gv_magical
1970 Returns C<TRUE> if given the name of a magical GV.
1972 Currently only useful internally when determining if a GV should be
1973 created even in rvalue contexts.
1975 C<flags> is not used at present but available for future extension to
1976 allow selecting particular classes of magical variable.
1978 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1979 This assumption is met by all callers within the perl core, which all pass
1980 pointers returned by SvPV.
1985 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1987 PERL_UNUSED_CONTEXT;
1988 PERL_UNUSED_ARG(flags);
1991 const char * const name1 = name + 1;
1994 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1998 if (len == 8 && strEQ(name1, "VERLOAD"))
2002 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2005 /* Using ${^...} variables is likely to be sufficiently rare that
2006 it seems sensible to avoid the space hit of also checking the
2008 case '\017': /* ${^OPEN} */
2009 if (strEQ(name1, "PEN"))
2012 case '\024': /* ${^TAINT} */
2013 if (strEQ(name1, "AINT"))
2016 case '\025': /* ${^UNICODE} */
2017 if (strEQ(name1, "NICODE"))
2019 if (strEQ(name1, "TF8LOCALE"))
2022 case '\027': /* ${^WARNING_BITS} */
2023 if (strEQ(name1, "ARNING_BITS"))
2036 const char *end = name + len;
2037 while (--end > name) {
2045 /* Because we're already assuming that name is NUL terminated
2046 below, we can treat an empty name as "\0" */
2073 case '\001': /* $^A */
2074 case '\003': /* $^C */
2075 case '\004': /* $^D */
2076 case '\005': /* $^E */
2077 case '\006': /* $^F */
2078 case '\010': /* $^H */
2079 case '\011': /* $^I, NOT \t in EBCDIC */
2080 case '\014': /* $^L */
2081 case '\016': /* $^N */
2082 case '\017': /* $^O */
2083 case '\020': /* $^P */
2084 case '\023': /* $^S */
2085 case '\024': /* $^T */
2086 case '\026': /* $^V */
2087 case '\027': /* $^W */
2107 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2112 PERL_UNUSED_ARG(flags);
2115 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2117 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2118 unshare_hek(GvNAME_HEK(gv));
2121 PERL_HASH(hash, name, len);
2122 GvNAME_HEK(gv) = name ? share_hek(name, len, hash) : 0;
2127 * c-indentation-style: bsd
2129 * indent-tabs-mode: t
2132 * ex: set ts=8 sts=4 sw=4 noet: