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 GvNAME(gv) = savepvn(name, len);
220 if (multi || doproto) /* doproto means it _was_ mentioned */
222 if (doproto) { /* Replicate part of newSUB here. */
226 /* newCONSTSUB takes ownership of the reference from us. */
227 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
229 /* XXX unsafe for threads if eval_owner isn't held */
230 (void) start_subparse(0,0); /* Create empty CV in compcv. */
231 GvCV(gv) = PL_compcv;
237 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
238 CvSTASH(GvCV(gv)) = PL_curstash;
240 sv_setpv((SV*)GvCV(gv), proto);
247 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
259 #ifdef PERL_DONT_CREATE_GVSV
272 =for apidoc gv_fetchmeth
274 Returns the glob with the given C<name> and a defined subroutine or
275 C<NULL>. The glob lives in the given C<stash>, or in the stashes
276 accessible via @ISA and UNIVERSAL::.
278 The argument C<level> should be either 0 or -1. If C<level==0>, as a
279 side-effect creates a glob with the given C<name> in the given C<stash>
280 which in the case of success contains an alias for the subroutine, and sets
281 up caching info for this glob. Similarly for all the searched stashes.
283 This function grants C<"SUPER"> token as a postfix of the stash name. The
284 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
285 visible to Perl code. So when calling C<call_sv>, you should not use
286 the GV directly; instead, you should use the method's CV, which can be
287 obtained from the GV with the C<GvCV> macro.
293 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
303 /* UNIVERSAL methods should be callable without a stash */
305 level = -1; /* probably appropriate */
306 if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
310 hvname = HvNAME_get(stash);
313 "Can't use anonymous symbol table for method lookup");
315 if ((level > 100) || (level < -100))
316 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
319 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
321 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
326 if (SvTYPE(topgv) != SVt_PVGV)
327 gv_init(topgv, stash, name, len, TRUE);
328 if ((cv = GvCV(topgv))) {
329 /* If genuine method or valid cache entry, use it */
330 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
332 /* Stale cached entry: junk it */
334 GvCV(topgv) = cv = NULL;
337 else if (GvCVGEN(topgv) == PL_sub_generation)
338 return 0; /* cache indicates sub doesn't exist */
341 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
342 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
344 /* create and re-create @.*::SUPER::ISA on demand */
345 if (!av || !SvMAGIC(av)) {
346 STRLEN packlen = HvNAMELEN_get(stash);
348 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
352 basestash = gv_stashpvn(hvname, packlen, TRUE);
353 gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
354 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
355 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
356 if (!gvp || !(gv = *gvp))
357 Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
358 if (SvTYPE(gv) != SVt_PVGV)
359 gv_init(gv, stash, "ISA", 3, TRUE);
360 SvREFCNT_dec(GvAV(gv));
361 GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
367 SV** svp = AvARRAY(av);
368 /* NOTE: No support for tied ISA */
369 I32 items = AvFILLp(av) + 1;
371 SV* const sv = *svp++;
372 HV* const basestash = gv_stashsv(sv, FALSE);
374 if (ckWARN(WARN_MISC))
375 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
379 gv = gv_fetchmeth(basestash, name, len,
380 (level >= 0) ? level + 1 : level - 1);
386 /* if at top level, try UNIVERSAL */
388 if (level == 0 || level == -1) {
389 HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
392 if ((gv = gv_fetchmeth(lastchance, name, len,
393 (level >= 0) ? level + 1 : level - 1)))
397 * Cache method in topgv if:
398 * 1. topgv has no synonyms (else inheritance crosses wires)
399 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
402 GvREFCNT(topgv) == 1 &&
404 (CvROOT(cv) || CvXSUB(cv)))
406 if ((cv = GvCV(topgv)))
408 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
409 GvCVGEN(topgv) = PL_sub_generation;
413 else if (topgv && GvREFCNT(topgv) == 1) {
414 /* cache the fact that the method is not defined */
415 GvCVGEN(topgv) = PL_sub_generation;
424 =for apidoc gv_fetchmeth_autoload
426 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
427 Returns a glob for the subroutine.
429 For an autoloaded subroutine without a GV, will create a GV even
430 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
431 of the result may be zero.
437 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
439 GV *gv = gv_fetchmeth(stash, name, len, level);
446 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
447 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
449 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
452 if (!(CvROOT(cv) || CvXSUB(cv)))
454 /* Have an autoload */
455 if (level < 0) /* Cannot do without a stub */
456 gv_fetchmeth(stash, name, len, 0);
457 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
466 =for apidoc gv_fetchmethod_autoload
468 Returns the glob which contains the subroutine to call to invoke the method
469 on the C<stash>. In fact in the presence of autoloading this may be the
470 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
473 The third parameter of C<gv_fetchmethod_autoload> determines whether
474 AUTOLOAD lookup is performed if the given method is not present: non-zero
475 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
476 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
477 with a non-zero C<autoload> parameter.
479 These functions grant C<"SUPER"> token as a prefix of the method name. Note
480 that if you want to keep the returned glob for a long time, you need to
481 check for it being "AUTOLOAD", since at the later time the call may load a
482 different subroutine due to $AUTOLOAD changing its value. Use the glob
483 created via a side effect to do this.
485 These functions have the same side-effects and as C<gv_fetchmeth> with
486 C<level==0>. C<name> should be writable if contains C<':'> or C<'
487 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
488 C<call_sv> apply equally to these functions.
494 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
497 register const char *nend;
498 const char *nsplit = NULL;
502 if (stash && SvTYPE(stash) < SVt_PVHV)
505 for (nend = name; *nend; nend++) {
508 else if (*nend == ':' && *(nend + 1) == ':')
512 const char * const origname = name;
516 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
517 /* ->SUPER::method should really be looked up in original stash */
518 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
519 CopSTASHPV(PL_curcop)));
520 /* __PACKAGE__::SUPER stash should be autovivified */
521 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
522 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
523 origname, HvNAME_get(stash), name) );
526 /* don't autovifify if ->NoSuchStash::method */
527 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
529 /* however, explicit calls to Pkg::SUPER::method may
530 happen, and may require autovivification to work */
531 if (!stash && (nsplit - origname) >= 7 &&
532 strnEQ(nsplit - 7, "::SUPER", 7) &&
533 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
534 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
539 gv = gv_fetchmeth(stash, name, nend - name, 0);
541 if (strEQ(name,"import") || strEQ(name,"unimport"))
542 gv = (GV*)&PL_sv_yes;
544 gv = gv_autoload4(ostash, name, nend - name, TRUE);
547 CV* const cv = GvCV(gv);
548 if (!CvROOT(cv) && !CvXSUB(cv)) {
556 if (GvCV(stubgv) != cv) /* orphaned import */
559 autogv = gv_autoload4(GvSTASH(stubgv),
560 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
570 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
578 const char *packname = "";
581 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
584 if (SvTYPE(stash) < SVt_PVHV) {
585 packname = SvPV_const((SV*)stash, packname_len);
589 packname = HvNAME_get(stash);
590 packname_len = HvNAMELEN_get(stash);
593 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
597 if (!(CvROOT(cv) || CvXSUB(cv)))
601 * Inheriting AUTOLOAD for non-methods works ... for now.
603 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
604 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
606 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
607 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
608 packname, (int)len, name);
611 /* rather than lookup/init $AUTOLOAD here
612 * only to have the XSUB do another lookup for $AUTOLOAD
613 * and split that value on the last '::',
614 * pass along the same data via some unused fields in the CV
617 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
623 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
624 * The subroutine's original name may not be "AUTOLOAD", so we don't
625 * use that, but for lack of anything better we will use the sub's
626 * original package to look up $AUTOLOAD.
628 varstash = GvSTASH(CvGV(cv));
629 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
633 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
634 #ifdef PERL_DONT_CREATE_GVSV
635 GvSV(vargv) = newSV(0);
639 varsv = GvSVn(vargv);
640 sv_setpvn(varsv, packname, packname_len);
641 sv_catpvs(varsv, "::");
642 sv_catpvn(varsv, name, len);
643 SvTAINTED_off(varsv);
647 /* The "gv" parameter should be the glob known to Perl code as *!
648 * The scalar must already have been magicalized.
651 S_require_errno(pTHX_ GV *gv)
654 HV* stash = gv_stashpvs("Errno", FALSE);
656 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
660 save_scalar(gv); /* keep the value of $! */
661 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
662 newSVpvs("Errno"), NULL);
665 stash = gv_stashpvs("Errno", FALSE);
666 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
667 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
672 =for apidoc gv_stashpv
674 Returns a pointer to the stash for a specified package. C<name> should
675 be a valid UTF-8 string and must be null-terminated. If C<create> is set
676 then the package will be created if it does not already exist. If C<create>
677 is not set and the package does not exist then NULL is returned.
683 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
685 return gv_stashpvn(name, strlen(name), create);
689 =for apidoc gv_stashpvn
691 Returns a pointer to the stash for a specified package. C<name> should
692 be a valid UTF-8 string. The C<namelen> parameter indicates the length of
693 the C<name>, in bytes. If C<create> is set then the package will be
694 created if it does not already exist. If C<create> is not set and the
695 package does not exist then NULL is returned.
701 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
708 if (namelen + 3 < sizeof smallbuf)
711 Newx(tmpbuf, namelen + 3, char);
712 Copy(name,tmpbuf,namelen,char);
713 tmpbuf[namelen++] = ':';
714 tmpbuf[namelen++] = ':';
715 tmpbuf[namelen] = '\0';
716 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
717 if (tmpbuf != smallbuf)
722 GvHV(tmpgv) = newHV();
724 if (!HvNAME_get(stash))
725 hv_name_set(stash, name, namelen, 0);
730 =for apidoc gv_stashsv
732 Returns a pointer to the stash for a specified package, which must be a
733 valid UTF-8 string. See C<gv_stashpv>.
739 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
742 const char * const ptr = SvPV_const(sv,len);
743 return gv_stashpvn(ptr, len, create);
748 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
749 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
753 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
755 const char * const nambeg = SvPV_const(name, len);
756 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
760 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
764 register const char *name = nambeg;
765 register GV *gv = NULL;
768 register const char *name_cursor;
770 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
771 const I32 no_expand = flags & GV_NOEXPAND;
773 flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL;
774 const char *const name_end = nambeg + full_len;
775 const char *const name_em1 = name_end - 1;
777 if (flags & GV_NOTQUAL) {
778 /* Caller promised that there is no stash, so we can skip the check. */
783 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
784 /* accidental stringify on a GV? */
788 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
789 if ((*name_cursor == ':' && name_cursor < name_em1
790 && name_cursor[1] == ':')
791 || (*name_cursor == '\'' && name_cursor[1]))
795 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
798 len = name_cursor - name;
803 if (len + 3 < sizeof (smallbuf))
806 Newx(tmpbuf, len+3, char);
807 Copy(name, tmpbuf, len, char);
811 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
812 gv = gvp ? *gvp : NULL;
813 if (gv && gv != (GV*)&PL_sv_undef) {
814 if (SvTYPE(gv) != SVt_PVGV)
815 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
819 if (tmpbuf != smallbuf)
821 if (!gv || gv == (GV*)&PL_sv_undef)
824 if (!(stash = GvHV(gv)))
825 stash = GvHV(gv) = newHV();
827 if (!HvNAME_get(stash))
828 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
831 if (*name_cursor == ':')
835 if (name == name_end)
836 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
839 len = name_cursor - name;
841 /* No stash in name, so see how we can default */
845 if (len && isIDFIRST_lazy(name)) {
854 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
855 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
856 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
860 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
865 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
866 && name[3] == 'I' && name[4] == 'N')
870 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
871 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
872 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
876 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
877 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
885 else if (IN_PERL_COMPILETIME) {
887 if (add && (PL_hints & HINT_STRICT_VARS) &&
888 sv_type != SVt_PVCV &&
889 sv_type != SVt_PVGV &&
890 sv_type != SVt_PVFM &&
891 sv_type != SVt_PVIO &&
892 !(len == 1 && sv_type == SVt_PV &&
893 (*name == 'a' || *name == 'b')) )
895 gvp = (GV**)hv_fetch(stash,name,len,0);
897 *gvp == (GV*)&PL_sv_undef ||
898 SvTYPE(*gvp) != SVt_PVGV)
902 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
903 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
904 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
906 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
907 sv_type == SVt_PVAV ? '@' :
908 sv_type == SVt_PVHV ? '%' : '$',
911 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
917 stash = CopSTASH(PL_curcop);
923 /* By this point we should have a stash and a name */
927 SV * const err = Perl_mess(aTHX_
928 "Global symbol \"%s%s\" requires explicit package name",
929 (sv_type == SVt_PV ? "$"
930 : sv_type == SVt_PVAV ? "@"
931 : sv_type == SVt_PVHV ? "%"
933 if (USE_UTF8_IN_NAMES)
936 stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
942 if (!SvREFCNT(stash)) /* symbol table under destruction */
945 gvp = (GV**)hv_fetch(stash,name,len,add);
946 if (!gvp || *gvp == (GV*)&PL_sv_undef)
949 if (SvTYPE(gv) == SVt_PVGV) {
952 gv_init_sv(gv, sv_type);
953 if (*name=='!' && sv_type == SVt_PVHV && len==1)
957 } else if (no_init) {
959 } else if (no_expand && SvROK(gv)) {
963 /* Adding a new symbol */
965 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
966 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
967 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
968 gv_init_sv(gv, sv_type);
970 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
971 : (PL_dowarn & G_WARN_ON ) ) )
974 /* set up magic where warranted */
979 /* Nothing else to do.
980 The compiler will probably turn the switch statement into a
981 branch table. Make sure we avoid even that small overhead for
982 the common case of lower case variable names. */
986 const char * const name2 = name + 1;
989 if (strEQ(name2, "RGV")) {
990 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
994 if (strnEQ(name2, "XPORT", 5))
998 if (strEQ(name2, "SA")) {
999 AV* const av = GvAVn(gv);
1001 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1002 /* NOTE: No support for tied ISA */
1003 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1004 && AvFILLp(av) == -1)
1007 av_push(av, newSVpvn(pname = "NDBM_File",9));
1008 gv_stashpvn(pname, 9, TRUE);
1009 av_push(av, newSVpvn(pname = "DB_File",7));
1010 gv_stashpvn(pname, 7, TRUE);
1011 av_push(av, newSVpvn(pname = "GDBM_File",9));
1012 gv_stashpvn(pname, 9, TRUE);
1013 av_push(av, newSVpvn(pname = "SDBM_File",9));
1014 gv_stashpvn(pname, 9, TRUE);
1015 av_push(av, newSVpvn(pname = "ODBM_File",9));
1016 gv_stashpvn(pname, 9, TRUE);
1021 if (strEQ(name2, "VERLOAD")) {
1022 HV* const hv = GvHVn(gv);
1024 hv_magic(hv, NULL, PERL_MAGIC_overload);
1028 if (strEQ(name2, "IG")) {
1032 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
1033 Newxz(PL_psig_name, SIG_SIZE, SV*);
1034 Newxz(PL_psig_pend, SIG_SIZE, int);
1038 hv_magic(hv, NULL, PERL_MAGIC_sig);
1039 for (i = 1; i < SIG_SIZE; i++) {
1040 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1042 sv_setsv(*init, &PL_sv_undef);
1044 PL_psig_name[i] = 0;
1045 PL_psig_pend[i] = 0;
1050 if (strEQ(name2, "ERSION"))
1053 case '\003': /* $^CHILD_ERROR_NATIVE */
1054 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1057 case '\005': /* $^ENCODING */
1058 if (strEQ(name2, "NCODING"))
1061 case '\017': /* $^OPEN */
1062 if (strEQ(name2, "PEN"))
1065 case '\024': /* ${^TAINT} */
1066 if (strEQ(name2, "AINT"))
1069 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1070 if (strEQ(name2, "NICODE"))
1072 if (strEQ(name2, "TF8LOCALE"))
1075 case '\027': /* $^WARNING_BITS */
1076 if (strEQ(name2, "ARNING_BITS"))
1089 /* ensures variable is only digits */
1090 /* ${"1foo"} fails this test (and is thus writeable) */
1091 /* added by japhy, but borrowed from is_gv_magical */
1092 const char *end = name + len;
1093 while (--end > name) {
1094 if (!isDIGIT(*end)) return gv;
1101 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1102 be case '\0' in this switch statement (ie a default case) */
1108 sv_type == SVt_PVAV ||
1109 sv_type == SVt_PVHV ||
1110 sv_type == SVt_PVCV ||
1111 sv_type == SVt_PVFM ||
1114 PL_sawampersand = TRUE;
1118 sv_setpv(GvSVn(gv),PL_chopset);
1122 #ifdef COMPLEX_STATUS
1123 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1129 /* If %! has been used, automatically load Errno.pm.
1130 The require will itself set errno, so in order to
1131 preserve its value we have to set up the magic
1132 now (rather than going to magicalize)
1135 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1137 if (sv_type == SVt_PVHV)
1143 AV* const av = GvAVn(gv);
1144 sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
1150 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1151 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1152 "$%c is no longer supported", *name);
1155 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1160 AV* const av = GvAVn(gv);
1161 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1165 case '\023': /* $^S */
1176 SvREADONLY_on(GvSVn(gv));
1191 case '\001': /* $^A */
1192 case '\003': /* $^C */
1193 case '\004': /* $^D */
1194 case '\005': /* $^E */
1195 case '\006': /* $^F */
1196 case '\010': /* $^H */
1197 case '\011': /* $^I, NOT \t in EBCDIC */
1198 case '\016': /* $^N */
1199 case '\017': /* $^O */
1200 case '\020': /* $^P */
1201 case '\024': /* $^T */
1202 case '\027': /* $^W */
1204 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1207 case '\014': /* $^L */
1208 sv_setpvn(GvSVn(gv),"\f",1);
1209 PL_formfeed = GvSVn(gv);
1212 sv_setpvn(GvSVn(gv),"\034",1);
1216 SV * const sv = GvSVn(gv);
1217 if (!sv_derived_from(PL_patchlevel, "version"))
1218 upg_version(PL_patchlevel);
1219 GvSV(gv) = vnumify(PL_patchlevel);
1220 SvREADONLY_on(GvSV(gv));
1224 case '\026': /* $^V */
1226 SV * const sv = GvSVn(gv);
1227 GvSV(gv) = new_version(PL_patchlevel);
1228 SvREADONLY_on(GvSV(gv));
1238 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1242 const HV * const hv = GvSTASH(gv);
1247 sv_setpv(sv, prefix ? prefix : "");
1249 name = HvNAME_get(hv);
1251 namelen = HvNAMELEN_get(hv);
1257 if (keepmain || strNE(name, "main")) {
1258 sv_catpvn(sv,name,namelen);
1261 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1265 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1267 const GV * const egv = GvEGV(gv);
1268 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1276 IO * const io = (IO*)newSV(0);
1278 sv_upgrade((SV *)io,SVt_PVIO);
1279 /* This used to read SvREFCNT(io) = 1;
1280 It's not clear why the reference count needed an explicit reset. NWC
1282 assert (SvREFCNT(io) == 1);
1284 /* Clear the stashcache because a new IO could overrule a package name */
1285 hv_clear(PL_stashcache);
1286 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1287 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1288 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1289 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1290 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1295 Perl_gv_check(pTHX_ HV *stash)
1300 if (!HvARRAY(stash))
1302 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1304 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1307 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1308 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1310 if (hv != PL_defstash && hv != stash)
1311 gv_check(hv); /* nested package */
1313 else if (isALPHA(*HeKEY(entry))) {
1315 gv = (GV*)HeVAL(entry);
1316 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1319 /* performance hack: if filename is absolute and it's a standard
1320 * module, don't bother warning */
1321 #ifdef MACOS_TRADITIONAL
1322 # define LIB_COMPONENT ":lib:"
1324 # define LIB_COMPONENT "/lib/"
1327 && PERL_FILE_IS_ABSOLUTE(file)
1328 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1332 CopLINE_set(PL_curcop, GvLINE(gv));
1334 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1336 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1338 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1339 "Name \"%s::%s\" used only once: possible typo",
1340 HvNAME_get(stash), GvNAME(gv));
1347 Perl_newGVgen(pTHX_ const char *pack)
1350 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1354 /* hopefully this is only called on local symbol table entries */
1357 Perl_gp_ref(pTHX_ GP *gp)
1365 /* multi-named GPs cannot be used for method cache */
1366 SvREFCNT_dec(gp->gp_cv);
1371 /* Adding a new name to a subroutine invalidates method cache */
1372 PL_sub_generation++;
1379 Perl_gp_free(pTHX_ GV *gv)
1384 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1386 if (gp->gp_refcnt == 0) {
1387 if (ckWARN_d(WARN_INTERNAL))
1388 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1389 "Attempt to free unreferenced glob pointers"
1390 pTHX__FORMAT pTHX__VALUE);
1394 /* Deleting the name of a subroutine invalidates method cache */
1395 PL_sub_generation++;
1397 if (--gp->gp_refcnt > 0) {
1398 if (gp->gp_egv == gv)
1404 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1405 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1406 /* FIXME - another reference loop GV -> symtab -> GV ?
1407 Somehow gp->gp_hv can end up pointing at freed garbage. */
1408 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1409 const char *hvname = HvNAME_get(gp->gp_hv);
1410 if (PL_stashcache && hvname)
1411 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1413 SvREFCNT_dec(gp->gp_hv);
1415 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1416 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1417 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1424 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1426 AMT * const amtp = (AMT*)mg->mg_ptr;
1427 PERL_UNUSED_ARG(sv);
1429 if (amtp && AMT_AMAGIC(amtp)) {
1431 for (i = 1; i < NofAMmeth; i++) {
1432 CV * const cv = amtp->table[i];
1434 SvREFCNT_dec((SV *) cv);
1435 amtp->table[i] = NULL;
1442 /* Updates and caches the CV's */
1445 Perl_Gv_AMupdate(pTHX_ HV *stash)
1448 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1449 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1452 if (mg && amtp->was_ok_am == PL_amagic_generation
1453 && amtp->was_ok_sub == PL_sub_generation)
1454 return (bool)AMT_OVERLOADED(amtp);
1455 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1457 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1460 amt.was_ok_am = PL_amagic_generation;
1461 amt.was_ok_sub = PL_sub_generation;
1462 amt.fallback = AMGfallNO;
1466 int filled = 0, have_ovl = 0;
1469 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1471 /* Try to find via inheritance. */
1472 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1473 SV * const sv = gv ? GvSV(gv) : NULL;
1477 lim = DESTROY_amg; /* Skip overloading entries. */
1478 #ifdef PERL_DONT_CREATE_GVSV
1480 /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */
1483 else if (SvTRUE(sv))
1484 amt.fallback=AMGfallYES;
1486 amt.fallback=AMGfallNEVER;
1488 for (i = 1; i < lim; i++)
1489 amt.table[i] = NULL;
1490 for (; i < NofAMmeth; i++) {
1491 const char * const cooky = PL_AMG_names[i];
1492 /* Human-readable form, for debugging: */
1493 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1494 const STRLEN l = strlen(cooky);
1496 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1497 cp, HvNAME_get(stash)) );
1498 /* don't fill the cache while looking up!
1499 Creation of inheritance stubs in intermediate packages may
1500 conflict with the logic of runtime method substitution.
1501 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1502 then we could have created stubs for "(+0" in A and C too.
1503 But if B overloads "bool", we may want to use it for
1504 numifying instead of C's "+0". */
1505 if (i >= DESTROY_amg)
1506 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1507 else /* Autoload taken care of below */
1508 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1510 if (gv && (cv = GvCV(gv))) {
1512 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1513 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1514 /* This is a hack to support autoloading..., while
1515 knowing *which* methods were declared as overloaded. */
1516 /* GvSV contains the name of the method. */
1518 SV *gvsv = GvSV(gv);
1520 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1521 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1522 GvSV(gv), cp, hvname) );
1523 if (!gvsv || !SvPOK(gvsv)
1524 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1527 /* Can be an import stub (created by "can"). */
1528 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1529 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1530 "in package \"%.256s\"",
1531 (GvCVGEN(gv) ? "Stub found while resolving"
1535 cv = GvCV(gv = ngv);
1537 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1538 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1539 GvNAME(CvGV(cv))) );
1541 if (i < DESTROY_amg)
1543 } else if (gv) { /* Autoloaded... */
1547 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1550 AMT_AMAGIC_on(&amt);
1552 AMT_OVERLOADED_on(&amt);
1553 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1554 (char*)&amt, sizeof(AMT));
1558 /* Here we have no table: */
1560 AMT_AMAGIC_off(&amt);
1561 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1562 (char*)&amt, sizeof(AMTS));
1568 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1574 if (!stash || !HvNAME_get(stash))
1576 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1580 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1582 amtp = (AMT*)mg->mg_ptr;
1583 if ( amtp->was_ok_am != PL_amagic_generation
1584 || amtp->was_ok_sub != PL_sub_generation )
1586 if (AMT_AMAGIC(amtp)) {
1587 CV * const ret = amtp->table[id];
1588 if (ret && isGV(ret)) { /* Autoloading stab */
1589 /* Passing it through may have resulted in a warning
1590 "Inherited AUTOLOAD for a non-method deprecated", since
1591 our caller is going through a function call, not a method call.
1592 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1593 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1606 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1611 CV **cvp=NULL, **ocvp=NULL;
1612 AMT *amtp=NULL, *oamtp=NULL;
1613 int off = 0, off1, lr = 0, notfound = 0;
1614 int postpr = 0, force_cpy = 0;
1615 int assign = AMGf_assign & flags;
1616 const int assignshift = assign ? 1 : 0;
1621 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1622 && (stash = SvSTASH(SvRV(left)))
1623 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1624 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1625 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1627 && ((cv = cvp[off=method+assignshift])
1628 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1634 cv = cvp[off=method])))) {
1635 lr = -1; /* Call method for left argument */
1637 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1640 /* look for substituted methods */
1641 /* In all the covered cases we should be called with assign==0. */
1645 if ((cv = cvp[off=add_ass_amg])
1646 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1647 right = &PL_sv_yes; lr = -1; assign = 1;
1652 if ((cv = cvp[off = subtr_ass_amg])
1653 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1654 right = &PL_sv_yes; lr = -1; assign = 1;
1658 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1661 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1664 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1667 (void)((cv = cvp[off=bool__amg])
1668 || (cv = cvp[off=numer_amg])
1669 || (cv = cvp[off=string_amg]));
1675 * SV* ref causes confusion with the interpreter variable of
1678 SV* const tmpRef=SvRV(left);
1679 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1681 * Just to be extra cautious. Maybe in some
1682 * additional cases sv_setsv is safe, too.
1684 SV* const newref = newSVsv(tmpRef);
1685 SvOBJECT_on(newref);
1686 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1692 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1693 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1694 SV* const nullsv=sv_2mortal(newSViv(0));
1696 SV* const lessp = amagic_call(left,nullsv,
1697 lt_amg,AMGf_noright);
1698 logic = SvTRUE(lessp);
1700 SV* const lessp = amagic_call(left,nullsv,
1701 ncmp_amg,AMGf_noright);
1702 logic = (SvNV(lessp) < 0);
1705 if (off==subtr_amg) {
1716 if ((cv = cvp[off=subtr_amg])) {
1718 left = sv_2mortal(newSViv(0));
1723 case iter_amg: /* XXXX Eventually should do to_gv. */
1725 return NULL; /* Delegate operation to standard mechanisms. */
1733 return left; /* Delegate operation to standard mechanisms. */
1738 if (!cv) goto not_found;
1739 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1740 && (stash = SvSTASH(SvRV(right)))
1741 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1742 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1743 ? (amtp = (AMT*)mg->mg_ptr)->table
1745 && (cv = cvp[off=method])) { /* Method for right
1748 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1749 && (cvp=ocvp) && (lr = -1))
1750 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1751 && !(flags & AMGf_unary)) {
1752 /* We look for substitution for
1753 * comparison operations and
1755 if (method==concat_amg || method==concat_ass_amg
1756 || method==repeat_amg || method==repeat_ass_amg) {
1757 return NULL; /* Delegate operation to string conversion */
1767 postpr = 1; off=ncmp_amg; break;
1774 postpr = 1; off=scmp_amg; break;
1776 if (off != -1) cv = cvp[off];
1781 not_found: /* No method found, either report or croak */
1789 return left; /* Delegate operation to standard mechanisms. */
1792 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1793 notfound = 1; lr = -1;
1794 } else if (cvp && (cv=cvp[nomethod_amg])) {
1795 notfound = 1; lr = 1;
1798 if (off==-1) off=method;
1799 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1800 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1801 AMG_id2name(method + assignshift),
1802 (flags & AMGf_unary ? " " : "\n\tleft "),
1804 "in overloaded package ":
1805 "has no overloaded magic",
1807 HvNAME_get(SvSTASH(SvRV(left))):
1810 ",\n\tright argument in overloaded package ":
1813 : ",\n\tright argument has no overloaded magic"),
1815 HvNAME_get(SvSTASH(SvRV(right))):
1817 if (amtp && amtp->fallback >= AMGfallYES) {
1818 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1820 Perl_croak(aTHX_ "%"SVf, msg);
1824 force_cpy = force_cpy || assign;
1829 DEBUG_o(Perl_deb(aTHX_
1830 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1832 method+assignshift==off? "" :
1834 method+assignshift==off? "" :
1835 AMG_id2name(method+assignshift),
1836 method+assignshift==off? "" : "\")",
1837 flags & AMGf_unary? "" :
1838 lr==1 ? " for right argument": " for left argument",
1839 flags & AMGf_unary? " for argument" : "",
1840 stash ? HvNAME_get(stash) : "null",
1841 fl? ",\n\tassignment variant used": "") );
1844 /* Since we use shallow copy during assignment, we need
1845 * to dublicate the contents, probably calling user-supplied
1846 * version of copy operator
1848 /* We need to copy in following cases:
1849 * a) Assignment form was called.
1850 * assignshift==1, assign==T, method + 1 == off
1851 * b) Increment or decrement, called directly.
1852 * assignshift==0, assign==0, method + 0 == off
1853 * c) Increment or decrement, translated to assignment add/subtr.
1854 * assignshift==0, assign==T,
1856 * d) Increment or decrement, translated to nomethod.
1857 * assignshift==0, assign==0,
1859 * e) Assignment form translated to nomethod.
1860 * assignshift==1, assign==T, method + 1 != off
1863 /* off is method, method+assignshift, or a result of opcode substitution.
1864 * In the latter case assignshift==0, so only notfound case is important.
1866 if (( (method + assignshift == off)
1867 && (assign || (method == inc_amg) || (method == dec_amg)))
1874 const bool oldcatch = CATCH_GET;
1877 Zero(&myop, 1, BINOP);
1878 myop.op_last = (OP *) &myop;
1879 myop.op_next = NULL;
1880 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1882 PUSHSTACKi(PERLSI_OVERLOAD);
1885 PL_op = (OP *) &myop;
1886 if (PERLDB_SUB && PL_curstash != PL_debstash)
1887 PL_op->op_private |= OPpENTERSUB_DB;
1891 EXTEND(SP, notfound + 5);
1892 PUSHs(lr>0? right: left);
1893 PUSHs(lr>0? left: right);
1894 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1896 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1901 if ((PL_op = Perl_pp_entersub(aTHX)))
1909 CATCH_SET(oldcatch);
1916 ans=SvIV(res)<=0; break;
1919 ans=SvIV(res)<0; break;
1922 ans=SvIV(res)>=0; break;
1925 ans=SvIV(res)>0; break;
1928 ans=SvIV(res)==0; break;
1931 ans=SvIV(res)!=0; break;
1934 SvSetSV(left,res); return left;
1936 ans=!SvTRUE(res); break;
1941 } else if (method==copy_amg) {
1943 Perl_croak(aTHX_ "Copy method did not return a reference");
1945 return SvREFCNT_inc(SvRV(res));
1953 =for apidoc is_gv_magical_sv
1955 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1961 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1964 const char * const temp = SvPV_const(name, len);
1965 return is_gv_magical(temp, len, flags);
1969 =for apidoc is_gv_magical
1971 Returns C<TRUE> if given the name of a magical GV.
1973 Currently only useful internally when determining if a GV should be
1974 created even in rvalue contexts.
1976 C<flags> is not used at present but available for future extension to
1977 allow selecting particular classes of magical variable.
1979 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1980 This assumption is met by all callers within the perl core, which all pass
1981 pointers returned by SvPV.
1986 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1988 PERL_UNUSED_CONTEXT;
1989 PERL_UNUSED_ARG(flags);
1992 const char * const name1 = name + 1;
1995 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1999 if (len == 8 && strEQ(name1, "VERLOAD"))
2003 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2006 /* Using ${^...} variables is likely to be sufficiently rare that
2007 it seems sensible to avoid the space hit of also checking the
2009 case '\017': /* ${^OPEN} */
2010 if (strEQ(name1, "PEN"))
2013 case '\024': /* ${^TAINT} */
2014 if (strEQ(name1, "AINT"))
2017 case '\025': /* ${^UNICODE} */
2018 if (strEQ(name1, "NICODE"))
2020 if (strEQ(name1, "TF8LOCALE"))
2023 case '\027': /* ${^WARNING_BITS} */
2024 if (strEQ(name1, "ARNING_BITS"))
2037 const char *end = name + len;
2038 while (--end > name) {
2046 /* Because we're already assuming that name is NUL terminated
2047 below, we can treat an empty name as "\0" */
2074 case '\001': /* $^A */
2075 case '\003': /* $^C */
2076 case '\004': /* $^D */
2077 case '\005': /* $^E */
2078 case '\006': /* $^F */
2079 case '\010': /* $^H */
2080 case '\011': /* $^I, NOT \t in EBCDIC */
2081 case '\014': /* $^L */
2082 case '\016': /* $^N */
2083 case '\017': /* $^O */
2084 case '\020': /* $^P */
2085 case '\023': /* $^S */
2086 case '\024': /* $^T */
2087 case '\026': /* $^V */
2088 case '\027': /* $^W */
2109 * c-indentation-style: bsd
2111 * indent-tabs-mode: t
2114 * ex: set ts=8 sts=4 sw=4 noet: