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"))
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);
1161 AV* const av = GvAVn(gv);
1162 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1166 case '\023': /* $^S */
1177 SvREADONLY_on(GvSVn(gv));
1192 case '\001': /* $^A */
1193 case '\003': /* $^C */
1194 case '\004': /* $^D */
1195 case '\005': /* $^E */
1196 case '\006': /* $^F */
1197 case '\010': /* $^H */
1198 case '\011': /* $^I, NOT \t in EBCDIC */
1199 case '\016': /* $^N */
1200 case '\017': /* $^O */
1201 case '\020': /* $^P */
1202 case '\024': /* $^T */
1203 case '\027': /* $^W */
1205 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1208 case '\014': /* $^L */
1209 sv_setpvn(GvSVn(gv),"\f",1);
1210 PL_formfeed = GvSVn(gv);
1213 sv_setpvn(GvSVn(gv),"\034",1);
1217 SV * const sv = GvSVn(gv);
1218 if (!sv_derived_from(PL_patchlevel, "version"))
1219 upg_version(PL_patchlevel);
1220 GvSV(gv) = vnumify(PL_patchlevel);
1221 SvREADONLY_on(GvSV(gv));
1225 case '\026': /* $^V */
1227 SV * const sv = GvSVn(gv);
1228 GvSV(gv) = new_version(PL_patchlevel);
1229 SvREADONLY_on(GvSV(gv));
1239 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1243 const HV * const hv = GvSTASH(gv);
1248 sv_setpv(sv, prefix ? prefix : "");
1250 name = HvNAME_get(hv);
1252 namelen = HvNAMELEN_get(hv);
1258 if (keepmain || strNE(name, "main")) {
1259 sv_catpvn(sv,name,namelen);
1262 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1266 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1268 const GV * const egv = GvEGV(gv);
1269 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1277 IO * const io = (IO*)newSV(0);
1279 sv_upgrade((SV *)io,SVt_PVIO);
1280 /* This used to read SvREFCNT(io) = 1;
1281 It's not clear why the reference count needed an explicit reset. NWC
1283 assert (SvREFCNT(io) == 1);
1285 /* Clear the stashcache because a new IO could overrule a package name */
1286 hv_clear(PL_stashcache);
1287 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1288 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1289 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1290 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1291 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1296 Perl_gv_check(pTHX_ HV *stash)
1301 if (!HvARRAY(stash))
1303 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1305 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1308 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1309 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1311 if (hv != PL_defstash && hv != stash)
1312 gv_check(hv); /* nested package */
1314 else if (isALPHA(*HeKEY(entry))) {
1316 gv = (GV*)HeVAL(entry);
1317 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1320 /* performance hack: if filename is absolute and it's a standard
1321 * module, don't bother warning */
1322 #ifdef MACOS_TRADITIONAL
1323 # define LIB_COMPONENT ":lib:"
1325 # define LIB_COMPONENT "/lib/"
1328 && PERL_FILE_IS_ABSOLUTE(file)
1329 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1333 CopLINE_set(PL_curcop, GvLINE(gv));
1335 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1337 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1339 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1340 "Name \"%s::%s\" used only once: possible typo",
1341 HvNAME_get(stash), GvNAME(gv));
1348 Perl_newGVgen(pTHX_ const char *pack)
1351 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1355 /* hopefully this is only called on local symbol table entries */
1358 Perl_gp_ref(pTHX_ GP *gp)
1366 /* multi-named GPs cannot be used for method cache */
1367 SvREFCNT_dec(gp->gp_cv);
1372 /* Adding a new name to a subroutine invalidates method cache */
1373 PL_sub_generation++;
1380 Perl_gp_free(pTHX_ GV *gv)
1385 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1387 if (gp->gp_refcnt == 0) {
1388 if (ckWARN_d(WARN_INTERNAL))
1389 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1390 "Attempt to free unreferenced glob pointers"
1391 pTHX__FORMAT pTHX__VALUE);
1395 /* Deleting the name of a subroutine invalidates method cache */
1396 PL_sub_generation++;
1398 if (--gp->gp_refcnt > 0) {
1399 if (gp->gp_egv == gv)
1405 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1406 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1407 /* FIXME - another reference loop GV -> symtab -> GV ?
1408 Somehow gp->gp_hv can end up pointing at freed garbage. */
1409 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1410 const char *hvname = HvNAME_get(gp->gp_hv);
1411 if (PL_stashcache && hvname)
1412 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1414 SvREFCNT_dec(gp->gp_hv);
1416 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1417 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1418 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1425 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1427 AMT * const amtp = (AMT*)mg->mg_ptr;
1428 PERL_UNUSED_ARG(sv);
1430 if (amtp && AMT_AMAGIC(amtp)) {
1432 for (i = 1; i < NofAMmeth; i++) {
1433 CV * const cv = amtp->table[i];
1435 SvREFCNT_dec((SV *) cv);
1436 amtp->table[i] = NULL;
1443 /* Updates and caches the CV's */
1446 Perl_Gv_AMupdate(pTHX_ HV *stash)
1449 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1450 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1453 if (mg && amtp->was_ok_am == PL_amagic_generation
1454 && amtp->was_ok_sub == PL_sub_generation)
1455 return (bool)AMT_OVERLOADED(amtp);
1456 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1458 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1461 amt.was_ok_am = PL_amagic_generation;
1462 amt.was_ok_sub = PL_sub_generation;
1463 amt.fallback = AMGfallNO;
1467 int filled = 0, have_ovl = 0;
1470 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1472 /* Try to find via inheritance. */
1473 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1474 SV * const sv = gv ? GvSV(gv) : NULL;
1478 lim = DESTROY_amg; /* Skip overloading entries. */
1479 #ifdef PERL_DONT_CREATE_GVSV
1481 /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */
1484 else if (SvTRUE(sv))
1485 amt.fallback=AMGfallYES;
1487 amt.fallback=AMGfallNEVER;
1489 for (i = 1; i < lim; i++)
1490 amt.table[i] = NULL;
1491 for (; i < NofAMmeth; i++) {
1492 const char * const cooky = PL_AMG_names[i];
1493 /* Human-readable form, for debugging: */
1494 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1495 const STRLEN l = strlen(cooky);
1497 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1498 cp, HvNAME_get(stash)) );
1499 /* don't fill the cache while looking up!
1500 Creation of inheritance stubs in intermediate packages may
1501 conflict with the logic of runtime method substitution.
1502 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1503 then we could have created stubs for "(+0" in A and C too.
1504 But if B overloads "bool", we may want to use it for
1505 numifying instead of C's "+0". */
1506 if (i >= DESTROY_amg)
1507 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1508 else /* Autoload taken care of below */
1509 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1511 if (gv && (cv = GvCV(gv))) {
1513 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1514 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1515 /* This is a hack to support autoloading..., while
1516 knowing *which* methods were declared as overloaded. */
1517 /* GvSV contains the name of the method. */
1519 SV *gvsv = GvSV(gv);
1521 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1522 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1523 GvSV(gv), cp, hvname) );
1524 if (!gvsv || !SvPOK(gvsv)
1525 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1528 /* Can be an import stub (created by "can"). */
1529 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1530 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1531 "in package \"%.256s\"",
1532 (GvCVGEN(gv) ? "Stub found while resolving"
1536 cv = GvCV(gv = ngv);
1538 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1539 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1540 GvNAME(CvGV(cv))) );
1542 if (i < DESTROY_amg)
1544 } else if (gv) { /* Autoloaded... */
1548 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1551 AMT_AMAGIC_on(&amt);
1553 AMT_OVERLOADED_on(&amt);
1554 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1555 (char*)&amt, sizeof(AMT));
1559 /* Here we have no table: */
1561 AMT_AMAGIC_off(&amt);
1562 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1563 (char*)&amt, sizeof(AMTS));
1569 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1575 if (!stash || !HvNAME_get(stash))
1577 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1581 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1583 amtp = (AMT*)mg->mg_ptr;
1584 if ( amtp->was_ok_am != PL_amagic_generation
1585 || amtp->was_ok_sub != PL_sub_generation )
1587 if (AMT_AMAGIC(amtp)) {
1588 CV * const ret = amtp->table[id];
1589 if (ret && isGV(ret)) { /* Autoloading stab */
1590 /* Passing it through may have resulted in a warning
1591 "Inherited AUTOLOAD for a non-method deprecated", since
1592 our caller is going through a function call, not a method call.
1593 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1594 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1607 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1612 CV **cvp=NULL, **ocvp=NULL;
1613 AMT *amtp=NULL, *oamtp=NULL;
1614 int off = 0, off1, lr = 0, notfound = 0;
1615 int postpr = 0, force_cpy = 0;
1616 int assign = AMGf_assign & flags;
1617 const int assignshift = assign ? 1 : 0;
1622 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1623 && (stash = SvSTASH(SvRV(left)))
1624 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1625 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1626 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1628 && ((cv = cvp[off=method+assignshift])
1629 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1635 cv = cvp[off=method])))) {
1636 lr = -1; /* Call method for left argument */
1638 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1641 /* look for substituted methods */
1642 /* In all the covered cases we should be called with assign==0. */
1646 if ((cv = cvp[off=add_ass_amg])
1647 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1648 right = &PL_sv_yes; lr = -1; assign = 1;
1653 if ((cv = cvp[off = subtr_ass_amg])
1654 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1655 right = &PL_sv_yes; lr = -1; assign = 1;
1659 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1662 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1665 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1668 (void)((cv = cvp[off=bool__amg])
1669 || (cv = cvp[off=numer_amg])
1670 || (cv = cvp[off=string_amg]));
1676 * SV* ref causes confusion with the interpreter variable of
1679 SV* const tmpRef=SvRV(left);
1680 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1682 * Just to be extra cautious. Maybe in some
1683 * additional cases sv_setsv is safe, too.
1685 SV* const newref = newSVsv(tmpRef);
1686 SvOBJECT_on(newref);
1687 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1693 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1694 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1695 SV* const nullsv=sv_2mortal(newSViv(0));
1697 SV* const lessp = amagic_call(left,nullsv,
1698 lt_amg,AMGf_noright);
1699 logic = SvTRUE(lessp);
1701 SV* const lessp = amagic_call(left,nullsv,
1702 ncmp_amg,AMGf_noright);
1703 logic = (SvNV(lessp) < 0);
1706 if (off==subtr_amg) {
1717 if ((cv = cvp[off=subtr_amg])) {
1719 left = sv_2mortal(newSViv(0));
1724 case iter_amg: /* XXXX Eventually should do to_gv. */
1726 return NULL; /* Delegate operation to standard mechanisms. */
1734 return left; /* Delegate operation to standard mechanisms. */
1739 if (!cv) goto not_found;
1740 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1741 && (stash = SvSTASH(SvRV(right)))
1742 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1743 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1744 ? (amtp = (AMT*)mg->mg_ptr)->table
1746 && (cv = cvp[off=method])) { /* Method for right
1749 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1750 && (cvp=ocvp) && (lr = -1))
1751 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1752 && !(flags & AMGf_unary)) {
1753 /* We look for substitution for
1754 * comparison operations and
1756 if (method==concat_amg || method==concat_ass_amg
1757 || method==repeat_amg || method==repeat_ass_amg) {
1758 return NULL; /* Delegate operation to string conversion */
1768 postpr = 1; off=ncmp_amg; break;
1775 postpr = 1; off=scmp_amg; break;
1777 if (off != -1) cv = cvp[off];
1782 not_found: /* No method found, either report or croak */
1790 return left; /* Delegate operation to standard mechanisms. */
1793 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1794 notfound = 1; lr = -1;
1795 } else if (cvp && (cv=cvp[nomethod_amg])) {
1796 notfound = 1; lr = 1;
1799 if (off==-1) off=method;
1800 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1801 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1802 AMG_id2name(method + assignshift),
1803 (flags & AMGf_unary ? " " : "\n\tleft "),
1805 "in overloaded package ":
1806 "has no overloaded magic",
1808 HvNAME_get(SvSTASH(SvRV(left))):
1811 ",\n\tright argument in overloaded package ":
1814 : ",\n\tright argument has no overloaded magic"),
1816 HvNAME_get(SvSTASH(SvRV(right))):
1818 if (amtp && amtp->fallback >= AMGfallYES) {
1819 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1821 Perl_croak(aTHX_ "%"SVf, msg);
1825 force_cpy = force_cpy || assign;
1830 DEBUG_o(Perl_deb(aTHX_
1831 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1833 method+assignshift==off? "" :
1835 method+assignshift==off? "" :
1836 AMG_id2name(method+assignshift),
1837 method+assignshift==off? "" : "\")",
1838 flags & AMGf_unary? "" :
1839 lr==1 ? " for right argument": " for left argument",
1840 flags & AMGf_unary? " for argument" : "",
1841 stash ? HvNAME_get(stash) : "null",
1842 fl? ",\n\tassignment variant used": "") );
1845 /* Since we use shallow copy during assignment, we need
1846 * to dublicate the contents, probably calling user-supplied
1847 * version of copy operator
1849 /* We need to copy in following cases:
1850 * a) Assignment form was called.
1851 * assignshift==1, assign==T, method + 1 == off
1852 * b) Increment or decrement, called directly.
1853 * assignshift==0, assign==0, method + 0 == off
1854 * c) Increment or decrement, translated to assignment add/subtr.
1855 * assignshift==0, assign==T,
1857 * d) Increment or decrement, translated to nomethod.
1858 * assignshift==0, assign==0,
1860 * e) Assignment form translated to nomethod.
1861 * assignshift==1, assign==T, method + 1 != off
1864 /* off is method, method+assignshift, or a result of opcode substitution.
1865 * In the latter case assignshift==0, so only notfound case is important.
1867 if (( (method + assignshift == off)
1868 && (assign || (method == inc_amg) || (method == dec_amg)))
1875 const bool oldcatch = CATCH_GET;
1878 Zero(&myop, 1, BINOP);
1879 myop.op_last = (OP *) &myop;
1880 myop.op_next = NULL;
1881 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1883 PUSHSTACKi(PERLSI_OVERLOAD);
1886 PL_op = (OP *) &myop;
1887 if (PERLDB_SUB && PL_curstash != PL_debstash)
1888 PL_op->op_private |= OPpENTERSUB_DB;
1892 EXTEND(SP, notfound + 5);
1893 PUSHs(lr>0? right: left);
1894 PUSHs(lr>0? left: right);
1895 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1897 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1902 if ((PL_op = Perl_pp_entersub(aTHX)))
1910 CATCH_SET(oldcatch);
1917 ans=SvIV(res)<=0; break;
1920 ans=SvIV(res)<0; break;
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 SvSetSV(left,res); return left;
1937 ans=!SvTRUE(res); break;
1942 } else if (method==copy_amg) {
1944 Perl_croak(aTHX_ "Copy method did not return a reference");
1946 return SvREFCNT_inc(SvRV(res));
1954 =for apidoc is_gv_magical_sv
1956 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1962 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1965 const char * const temp = SvPV_const(name, len);
1966 return is_gv_magical(temp, len, flags);
1970 =for apidoc is_gv_magical
1972 Returns C<TRUE> if given the name of a magical GV.
1974 Currently only useful internally when determining if a GV should be
1975 created even in rvalue contexts.
1977 C<flags> is not used at present but available for future extension to
1978 allow selecting particular classes of magical variable.
1980 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1981 This assumption is met by all callers within the perl core, which all pass
1982 pointers returned by SvPV.
1987 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1989 PERL_UNUSED_CONTEXT;
1990 PERL_UNUSED_ARG(flags);
1993 const char * const name1 = name + 1;
1996 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2000 if (len == 8 && strEQ(name1, "VERLOAD"))
2004 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2007 /* Using ${^...} variables is likely to be sufficiently rare that
2008 it seems sensible to avoid the space hit of also checking the
2010 case '\017': /* ${^OPEN} */
2011 if (strEQ(name1, "PEN"))
2014 case '\024': /* ${^TAINT} */
2015 if (strEQ(name1, "AINT"))
2018 case '\025': /* ${^UNICODE} */
2019 if (strEQ(name1, "NICODE"))
2021 if (strEQ(name1, "TF8LOCALE"))
2024 case '\027': /* ${^WARNING_BITS} */
2025 if (strEQ(name1, "ARNING_BITS"))
2038 const char *end = name + len;
2039 while (--end > name) {
2047 /* Because we're already assuming that name is NUL terminated
2048 below, we can treat an empty name as "\0" */
2075 case '\001': /* $^A */
2076 case '\003': /* $^C */
2077 case '\004': /* $^D */
2078 case '\005': /* $^E */
2079 case '\006': /* $^F */
2080 case '\010': /* $^H */
2081 case '\011': /* $^I, NOT \t in EBCDIC */
2082 case '\014': /* $^L */
2083 case '\016': /* $^N */
2084 case '\017': /* $^O */
2085 case '\020': /* $^P */
2086 case '\023': /* $^S */
2087 case '\024': /* $^T */
2088 case '\026': /* $^V */
2089 case '\027': /* $^W */
2109 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2114 PERL_UNUSED_ARG(flags);
2117 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2119 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2120 unshare_hek(GvNAME_HEK(gv));
2123 PERL_HASH(hash, name, len);
2124 GvNAME_HEK(gv) = name ? share_hek(name, len, hash) : 0;
2129 * c-indentation-style: bsd
2131 * indent-tabs-mode: t
2134 * ex: set ts=8 sts=4 sw=4 noet: