3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 Perl_gv_AVadd(pTHX_ register GV *gv)
43 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
44 Perl_croak(aTHX_ "Bad symbol for array");
51 Perl_gv_HVadd(pTHX_ register GV *gv)
53 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
54 Perl_croak(aTHX_ "Bad symbol for hash");
61 Perl_gv_IOadd(pTHX_ register GV *gv)
63 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
64 Perl_croak(aTHX_ "Bad symbol for filehandle");
66 #ifdef GV_UNIQUE_CHECK
68 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
77 Perl_gv_fetchfile(pTHX_ const char *name)
87 tmplen = strlen(name) + 2;
88 if (tmplen < sizeof smallbuf)
91 New(603, tmpbuf, tmplen + 1, char);
92 /* This is where the debugger's %{"::_<$filename"} hash is created */
95 strcpy(tmpbuf + 2, name);
96 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
98 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
99 sv_setpv(GvSV(gv), name);
101 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
103 if (tmpbuf != smallbuf)
109 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
113 const bool doproto = SvTYPE(gv) > SVt_NULL;
114 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
116 sv_upgrade((SV*)gv, SVt_PVGV);
123 Safefree(SvPVX_mutable(gv));
125 Newz(602, gp, 1, GP);
126 GvGP(gv) = gp_ref(gp);
127 GvSV(gv) = NEWSV(72,0);
128 GvLINE(gv) = CopLINE(PL_curcop);
129 /* XXX Ideally this cast would be replaced with a change to const char*
131 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
134 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
137 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
138 GvNAME(gv) = savepvn(name, len);
140 if (multi || doproto) /* doproto means it _was_ mentioned */
142 if (doproto) { /* Replicate part of newSUB here. */
145 /* XXX unsafe for threads if eval_owner isn't held */
146 start_subparse(0,0); /* Create CV in compcv. */
147 GvCV(gv) = PL_compcv;
152 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
153 CvSTASH(GvCV(gv)) = PL_curstash;
155 sv_setpv((SV*)GvCV(gv), proto);
162 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
178 =for apidoc gv_fetchmeth
180 Returns the glob with the given C<name> and a defined subroutine or
181 C<NULL>. The glob lives in the given C<stash>, or in the stashes
182 accessible via @ISA and UNIVERSAL::.
184 The argument C<level> should be either 0 or -1. If C<level==0>, as a
185 side-effect creates a glob with the given C<name> in the given C<stash>
186 which in the case of success contains an alias for the subroutine, and sets
187 up caching info for this glob. Similarly for all the searched stashes.
189 This function grants C<"SUPER"> token as a postfix of the stash name. The
190 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
191 visible to Perl code. So when calling C<call_sv>, you should not use
192 the GV directly; instead, you should use the method's CV, which can be
193 obtained from the GV with the C<GvCV> macro.
199 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
208 /* UNIVERSAL methods should be callable without a stash */
210 level = -1; /* probably appropriate */
211 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
215 hvname = HvNAME_get(stash);
218 "Can't use anonymous symbol table for method lookup");
220 if ((level > 100) || (level < -100))
221 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
224 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
226 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
231 if (SvTYPE(topgv) != SVt_PVGV)
232 gv_init(topgv, stash, name, len, TRUE);
233 if ((cv = GvCV(topgv))) {
234 /* If genuine method or valid cache entry, use it */
235 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
237 /* Stale cached entry: junk it */
239 GvCV(topgv) = cv = Nullcv;
242 else if (GvCVGEN(topgv) == PL_sub_generation)
243 return 0; /* cache indicates sub doesn't exist */
246 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
247 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
249 /* create and re-create @.*::SUPER::ISA on demand */
250 if (!av || !SvMAGIC(av)) {
251 STRLEN packlen = HvNAMELEN_get(stash);
253 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
257 basestash = gv_stashpvn(hvname, packlen, TRUE);
258 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
259 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
260 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
261 if (!gvp || !(gv = *gvp))
262 Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
263 if (SvTYPE(gv) != SVt_PVGV)
264 gv_init(gv, stash, "ISA", 3, TRUE);
265 SvREFCNT_dec(GvAV(gv));
266 GvAV(gv) = (AV*)SvREFCNT_inc(av);
272 SV** svp = AvARRAY(av);
273 /* NOTE: No support for tied ISA */
274 I32 items = AvFILLp(av) + 1;
277 HV* basestash = gv_stashsv(sv, FALSE);
279 if (ckWARN(WARN_MISC))
280 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
284 gv = gv_fetchmeth(basestash, name, len,
285 (level >= 0) ? level + 1 : level - 1);
291 /* if at top level, try UNIVERSAL */
293 if (level == 0 || level == -1) {
296 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
297 if ((gv = gv_fetchmeth(lastchance, name, len,
298 (level >= 0) ? level + 1 : level - 1)))
302 * Cache method in topgv if:
303 * 1. topgv has no synonyms (else inheritance crosses wires)
304 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
307 GvREFCNT(topgv) == 1 &&
309 (CvROOT(cv) || CvXSUB(cv)))
311 if ((cv = GvCV(topgv)))
313 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
314 GvCVGEN(topgv) = PL_sub_generation;
318 else if (topgv && GvREFCNT(topgv) == 1) {
319 /* cache the fact that the method is not defined */
320 GvCVGEN(topgv) = PL_sub_generation;
329 =for apidoc gv_fetchmeth_autoload
331 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
332 Returns a glob for the subroutine.
334 For an autoloaded subroutine without a GV, will create a GV even
335 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
336 of the result may be zero.
342 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
344 GV *gv = gv_fetchmeth(stash, name, len, level);
351 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
352 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
354 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
357 if (!(CvROOT(cv) || CvXSUB(cv)))
359 /* Have an autoload */
360 if (level < 0) /* Cannot do without a stub */
361 gv_fetchmeth(stash, name, len, 0);
362 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
371 =for apidoc gv_fetchmethod
373 See L<gv_fetchmethod_autoload>.
379 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
381 return gv_fetchmethod_autoload(stash, name, TRUE);
385 =for apidoc gv_fetchmethod_autoload
387 Returns the glob which contains the subroutine to call to invoke the method
388 on the C<stash>. In fact in the presence of autoloading this may be the
389 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
392 The third parameter of C<gv_fetchmethod_autoload> determines whether
393 AUTOLOAD lookup is performed if the given method is not present: non-zero
394 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
395 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
396 with a non-zero C<autoload> parameter.
398 These functions grant C<"SUPER"> token as a prefix of the method name. Note
399 that if you want to keep the returned glob for a long time, you need to
400 check for it being "AUTOLOAD", since at the later time the call may load a
401 different subroutine due to $AUTOLOAD changing its value. Use the glob
402 created via a side effect to do this.
404 These functions have the same side-effects and as C<gv_fetchmeth> with
405 C<level==0>. C<name> should be writable if contains C<':'> or C<'
406 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
407 C<call_sv> apply equally to these functions.
413 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
415 register const char *nend;
416 const char *nsplit = 0;
420 if (stash && SvTYPE(stash) < SVt_PVHV)
423 for (nend = name; *nend; nend++) {
426 else if (*nend == ':' && *(nend + 1) == ':')
430 const char *origname = name;
434 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
435 /* ->SUPER::method should really be looked up in original stash */
436 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
437 CopSTASHPV(PL_curcop)));
438 /* __PACKAGE__::SUPER stash should be autovivified */
439 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
440 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
441 origname, HvNAME_get(stash), name) );
444 /* don't autovifify if ->NoSuchStash::method */
445 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
447 /* however, explicit calls to Pkg::SUPER::method may
448 happen, and may require autovivification to work */
449 if (!stash && (nsplit - origname) >= 7 &&
450 strnEQ(nsplit - 7, "::SUPER", 7) &&
451 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
452 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
457 gv = gv_fetchmeth(stash, name, nend - name, 0);
459 if (strEQ(name,"import") || strEQ(name,"unimport"))
460 gv = (GV*)&PL_sv_yes;
462 gv = gv_autoload4(ostash, name, nend - name, TRUE);
466 if (!CvROOT(cv) && !CvXSUB(cv)) {
474 if (GvCV(stubgv) != cv) /* orphaned import */
477 autogv = gv_autoload4(GvSTASH(stubgv),
478 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
488 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
496 const char *packname = "";
499 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
502 if (SvTYPE(stash) < SVt_PVHV) {
503 packname = SvPV_const((SV*)stash, packname_len);
507 packname = HvNAME_get(stash);
508 packname_len = HvNAMELEN_get(stash);
511 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
515 if (!(CvROOT(cv) || CvXSUB(cv)))
519 * Inheriting AUTOLOAD for non-methods works ... for now.
521 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
522 (GvCVGEN(gv) || GvSTASH(gv) != stash))
523 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
524 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
525 packname, (int)len, name);
528 /* rather than lookup/init $AUTOLOAD here
529 * only to have the XSUB do another lookup for $AUTOLOAD
530 * and split that value on the last '::',
531 * pass along the same data via some unused fields in the CV
534 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
540 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
541 * The subroutine's original name may not be "AUTOLOAD", so we don't
542 * use that, but for lack of anything better we will use the sub's
543 * original package to look up $AUTOLOAD.
545 varstash = GvSTASH(CvGV(cv));
546 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
550 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
553 sv_setpvn(varsv, packname, packname_len);
554 sv_catpvn(varsv, "::", 2);
555 sv_catpvn(varsv, name, len);
556 SvTAINTED_off(varsv);
560 /* The "gv" parameter should be the glob known to Perl code as *!
561 * The scalar must already have been magicalized.
564 S_require_errno(pTHX_ GV *gv)
567 HV* stash = gv_stashpvn("Errno",5,FALSE);
569 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
573 save_scalar(gv); /* keep the value of $! */
574 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
575 newSVpvn("Errno",5), Nullsv);
578 stash = gv_stashpvn("Errno",5,FALSE);
579 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
580 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
585 =for apidoc gv_stashpv
587 Returns a pointer to the stash for a specified package. C<name> should
588 be a valid UTF-8 string and must be null-terminated. If C<create> is set
589 then the package will be created if it does not already exist. If C<create>
590 is not set and the package does not exist then NULL is returned.
596 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
598 return gv_stashpvn(name, strlen(name), create);
602 =for apidoc gv_stashpvn
604 Returns a pointer to the stash for a specified package. C<name> should
605 be a valid UTF-8 string. The C<namelen> parameter indicates the length of
606 the C<name>, in bytes. If C<create> is set then the package will be
607 created if it does not already exist. If C<create> is not set and the
608 package does not exist then NULL is returned.
614 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
621 if (namelen + 3 < sizeof smallbuf)
624 New(606, tmpbuf, namelen + 3, char);
625 Copy(name,tmpbuf,namelen,char);
626 tmpbuf[namelen++] = ':';
627 tmpbuf[namelen++] = ':';
628 tmpbuf[namelen] = '\0';
629 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
630 if (tmpbuf != smallbuf)
635 GvHV(tmpgv) = newHV();
637 if (!HvNAME_get(stash))
638 Perl_hv_name_set(aTHX_ stash, name, namelen, 0);
643 =for apidoc gv_stashsv
645 Returns a pointer to the stash for a specified package, which must be a
646 valid UTF-8 string. See C<gv_stashpv>.
652 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
655 const char *ptr = SvPV_const(sv,len);
656 return gv_stashpvn(ptr, len, create);
661 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
662 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
666 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
668 const char *nambeg = SvPV_const(name, len);
669 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
673 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
676 register const char *name = nambeg;
680 register const char *namend;
682 const I32 add = flags & ~SVf_UTF8;
685 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
688 for (namend = name; *namend; namend++) {
689 if ((*namend == ':' && namend[1] == ':')
690 || (*namend == '\'' && namend[1]))
694 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
702 if (len + 3 < sizeof (smallbuf))
705 New(601, tmpbuf, len+3, char);
706 Copy(name, tmpbuf, len, char);
710 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
711 gv = gvp ? *gvp : Nullgv;
712 if (gv && gv != (GV*)&PL_sv_undef) {
713 if (SvTYPE(gv) != SVt_PVGV)
714 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
718 if (tmpbuf != smallbuf)
720 if (!gv || gv == (GV*)&PL_sv_undef)
723 if (!(stash = GvHV(gv)))
724 stash = GvHV(gv) = newHV();
726 if (!HvNAME_get(stash))
727 Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0);
735 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
740 /* No stash in name, so see how we can default */
743 if (isIDFIRST_lazy(name)) {
746 /* name is always \0 terminated, and initial \0 wouldn't return
747 true from isIDFIRST_lazy, so we know that name[1] is defined */
754 if (strEQ(name, "INC") || strEQ(name, "ENV"))
758 if (strEQ(name, "SIG"))
762 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
763 strEQ(name, "STDERR"))
767 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
774 else if (IN_PERL_COMPILETIME) {
776 if (add && (PL_hints & HINT_STRICT_VARS) &&
777 sv_type != SVt_PVCV &&
778 sv_type != SVt_PVGV &&
779 sv_type != SVt_PVFM &&
780 sv_type != SVt_PVIO &&
781 !(len == 1 && sv_type == SVt_PV &&
782 (*name == 'a' || *name == 'b')) )
784 gvp = (GV**)hv_fetch(stash,name,len,0);
786 *gvp == (GV*)&PL_sv_undef ||
787 SvTYPE(*gvp) != SVt_PVGV)
791 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
792 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
793 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
795 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
796 sv_type == SVt_PVAV ? '@' :
797 sv_type == SVt_PVHV ? '%' : '$',
800 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
806 stash = CopSTASH(PL_curcop);
812 /* By this point we should have a stash and a name */
816 register SV *err = Perl_mess(aTHX_
817 "Global symbol \"%s%s\" requires explicit package name",
818 (sv_type == SVt_PV ? "$"
819 : sv_type == SVt_PVAV ? "@"
820 : sv_type == SVt_PVHV ? "%"
822 if (USE_UTF8_IN_NAMES)
825 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
831 if (!SvREFCNT(stash)) /* symbol table under destruction */
834 gvp = (GV**)hv_fetch(stash,name,len,add);
835 if (!gvp || *gvp == (GV*)&PL_sv_undef)
838 if (SvTYPE(gv) == SVt_PVGV) {
841 gv_init_sv(gv, sv_type);
842 if (*name=='!' && sv_type == SVt_PVHV && len==1)
846 } else if (add & GV_NOINIT) {
850 /* Adding a new symbol */
852 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
853 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
854 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
855 gv_init_sv(gv, sv_type);
857 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
858 : (PL_dowarn & G_WARN_ON ) ) )
861 /* set up magic where warranted */
865 /* Nothing else to do.
866 The compiler will probably turn the switch statement into a
867 branch table. Make sure we avoid even that small overhead for
868 the common case of lower case variable names. */
872 const char * const name2 = name + 1;
875 if (strEQ(name2, "RGV")) {
876 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
880 if (strnEQ(name2, "XPORT", 5))
884 if (strEQ(name2, "SA")) {
887 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
888 /* NOTE: No support for tied ISA */
889 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
890 && AvFILLp(av) == -1)
893 av_push(av, newSVpvn(pname = "NDBM_File",9));
894 gv_stashpvn(pname, 9, TRUE);
895 av_push(av, newSVpvn(pname = "DB_File",7));
896 gv_stashpvn(pname, 7, TRUE);
897 av_push(av, newSVpvn(pname = "GDBM_File",9));
898 gv_stashpvn(pname, 9, TRUE);
899 av_push(av, newSVpvn(pname = "SDBM_File",9));
900 gv_stashpvn(pname, 9, TRUE);
901 av_push(av, newSVpvn(pname = "ODBM_File",9));
902 gv_stashpvn(pname, 9, TRUE);
907 if (strEQ(name2, "VERLOAD")) {
910 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
914 if (strEQ(name2, "IG")) {
918 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
919 Newz(73, PL_psig_name, SIG_SIZE, SV*);
920 Newz(73, PL_psig_pend, SIG_SIZE, int);
924 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
925 for (i = 1; i < SIG_SIZE; i++) {
927 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
929 sv_setsv(*init, &PL_sv_undef);
937 if (strEQ(name2, "ERSION"))
940 case '\003': /* $^CHILD_ERROR_NATIVE */
941 if (strEQ(name2, "HILD_ERROR_NATIVE"))
944 case '\005': /* $^ENCODING */
945 if (strEQ(name2, "NCODING"))
948 case '\017': /* $^OPEN */
949 if (strEQ(name2, "PEN"))
952 case '\024': /* ${^TAINT} */
953 if (strEQ(name2, "AINT"))
956 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
957 if (strEQ(name2, "NICODE"))
959 if (strEQ(name2, "TF8LOCALE"))
962 case '\027': /* $^WARNING_BITS */
963 if (strEQ(name2, "ARNING_BITS"))
976 /* ensures variable is only digits */
977 /* ${"1foo"} fails this test (and is thus writeable) */
978 /* added by japhy, but borrowed from is_gv_magical */
979 const char *end = name + len;
980 while (--end > name) {
981 if (!isDIGIT(*end)) return gv;
988 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
989 be case '\0' in this switch statement (ie a default case) */
995 sv_type == SVt_PVAV ||
996 sv_type == SVt_PVHV ||
997 sv_type == SVt_PVCV ||
998 sv_type == SVt_PVFM ||
1001 PL_sawampersand = TRUE;
1005 sv_setpv(GvSV(gv),PL_chopset);
1009 #ifdef COMPLEX_STATUS
1010 SvUPGRADE(GvSV(gv), SVt_PVLV);
1016 /* If %! has been used, automatically load Errno.pm.
1017 The require will itself set errno, so in order to
1018 preserve its value we have to set up the magic
1019 now (rather than going to magicalize)
1022 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1024 if (sv_type == SVt_PVHV)
1031 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1037 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1038 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1039 "$%c is no longer supported", *name);
1042 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1048 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1052 case '\023': /* $^S */
1063 SvREADONLY_on(GvSV(gv));
1078 case '\001': /* $^A */
1079 case '\003': /* $^C */
1080 case '\004': /* $^D */
1081 case '\005': /* $^E */
1082 case '\006': /* $^F */
1083 case '\010': /* $^H */
1084 case '\011': /* $^I, NOT \t in EBCDIC */
1085 case '\016': /* $^N */
1086 case '\017': /* $^O */
1087 case '\020': /* $^P */
1088 case '\024': /* $^T */
1089 case '\027': /* $^W */
1091 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1094 case '\014': /* $^L */
1095 sv_setpvn(GvSV(gv),"\f",1);
1096 PL_formfeed = GvSV(gv);
1099 sv_setpvn(GvSV(gv),"\034",1);
1104 if (!sv_derived_from(PL_patchlevel, "version"))
1105 (void *)upg_version(PL_patchlevel);
1106 GvSV(gv) = vnumify(PL_patchlevel);
1107 SvREADONLY_on(GvSV(gv));
1111 case '\026': /* $^V */
1113 SV * const sv = GvSV(gv);
1114 GvSV(gv) = new_version(PL_patchlevel);
1115 SvREADONLY_on(GvSV(gv));
1125 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1129 const HV * const hv = GvSTASH(gv);
1134 sv_setpv(sv, prefix ? prefix : "");
1136 name = HvNAME_get(hv);
1138 namelen = HvNAMELEN_get(hv);
1144 if (keepmain || strNE(name, "main")) {
1145 sv_catpvn(sv,name,namelen);
1146 sv_catpvn(sv,"::", 2);
1148 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1152 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1154 gv_fullname4(sv, gv, prefix, TRUE);
1158 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1160 const GV *egv = GvEGV(gv);
1163 gv_fullname4(sv, egv, prefix, keepmain);
1167 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1169 gv_efullname4(sv, gv, prefix, TRUE);
1172 /* compatibility with versions <= 5.003. */
1174 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1176 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1179 /* compatibility with versions <= 5.003. */
1181 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1183 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1190 IO * const io = (IO*)NEWSV(0,0);
1192 sv_upgrade((SV *)io,SVt_PVIO);
1195 /* Clear the stashcache because a new IO could overrule a package name */
1196 hv_clear(PL_stashcache);
1197 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1198 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1199 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1200 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1201 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1206 Perl_gv_check(pTHX_ HV *stash)
1210 if (!HvARRAY(stash))
1212 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1214 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1217 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1218 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1220 if (hv != PL_defstash && hv != stash)
1221 gv_check(hv); /* nested package */
1223 else if (isALPHA(*HeKEY(entry))) {
1225 gv = (GV*)HeVAL(entry);
1226 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1229 /* performance hack: if filename is absolute and it's a standard
1230 * module, don't bother warning */
1232 && PERL_FILE_IS_ABSOLUTE(file)
1233 #ifdef MACOS_TRADITIONAL
1234 && (instr(file, ":lib:")
1236 && (instr(file, "/lib/")
1238 || instr(file, ".pm")))
1242 CopLINE_set(PL_curcop, GvLINE(gv));
1244 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1246 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1248 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1249 "Name \"%s::%s\" used only once: possible typo",
1250 HvNAME_get(stash), GvNAME(gv));
1257 Perl_newGVgen(pTHX_ const char *pack)
1259 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1263 /* hopefully this is only called on local symbol table entries */
1266 Perl_gp_ref(pTHX_ GP *gp)
1273 /* multi-named GPs cannot be used for method cache */
1274 SvREFCNT_dec(gp->gp_cv);
1279 /* Adding a new name to a subroutine invalidates method cache */
1280 PL_sub_generation++;
1287 Perl_gp_free(pTHX_ GV *gv)
1291 if (!gv || !(gp = GvGP(gv)))
1293 if (gp->gp_refcnt == 0) {
1294 if (ckWARN_d(WARN_INTERNAL))
1295 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1296 "Attempt to free unreferenced glob pointers"
1297 pTHX__FORMAT pTHX__VALUE);
1301 /* Deleting the name of a subroutine invalidates method cache */
1302 PL_sub_generation++;
1304 if (--gp->gp_refcnt > 0) {
1305 if (gp->gp_egv == gv)
1310 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1311 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1312 /* FIXME - another reference loop GV -> symtab -> GV ?
1313 Somehow gp->gp_hv can end up pointing at freed garbage. */
1314 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1315 const char *hvname = HvNAME_get(gp->gp_hv);
1316 if (PL_stashcache && hvname)
1317 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1319 SvREFCNT_dec(gp->gp_hv);
1321 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1322 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1323 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1330 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1332 AMT * const amtp = (AMT*)mg->mg_ptr;
1333 PERL_UNUSED_ARG(sv);
1335 if (amtp && AMT_AMAGIC(amtp)) {
1337 for (i = 1; i < NofAMmeth; i++) {
1338 CV * const cv = amtp->table[i];
1340 SvREFCNT_dec((SV *) cv);
1341 amtp->table[i] = Nullcv;
1348 /* Updates and caches the CV's */
1351 Perl_Gv_AMupdate(pTHX_ HV *stash)
1353 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1354 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1357 if (mg && amtp->was_ok_am == PL_amagic_generation
1358 && amtp->was_ok_sub == PL_sub_generation)
1359 return (bool)AMT_OVERLOADED(amtp);
1360 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1362 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1365 amt.was_ok_am = PL_amagic_generation;
1366 amt.was_ok_sub = PL_sub_generation;
1367 amt.fallback = AMGfallNO;
1371 int filled = 0, have_ovl = 0;
1374 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1376 /* Try to find via inheritance. */
1377 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1378 SV * const sv = gv ? GvSV(gv) : NULL;
1382 lim = DESTROY_amg; /* Skip overloading entries. */
1383 else if (SvTRUE(sv))
1384 amt.fallback=AMGfallYES;
1386 amt.fallback=AMGfallNEVER;
1388 for (i = 1; i < lim; i++)
1389 amt.table[i] = Nullcv;
1390 for (; i < NofAMmeth; i++) {
1391 const char *cooky = PL_AMG_names[i];
1392 /* Human-readable form, for debugging: */
1393 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1394 const STRLEN l = strlen(cooky);
1396 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1397 cp, HvNAME_get(stash)) );
1398 /* don't fill the cache while looking up!
1399 Creation of inheritance stubs in intermediate packages may
1400 conflict with the logic of runtime method substitution.
1401 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1402 then we could have created stubs for "(+0" in A and C too.
1403 But if B overloads "bool", we may want to use it for
1404 numifying instead of C's "+0". */
1405 if (i >= DESTROY_amg)
1406 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1407 else /* Autoload taken care of below */
1408 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1410 if (gv && (cv = GvCV(gv))) {
1412 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1413 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1414 /* This is a hack to support autoloading..., while
1415 knowing *which* methods were declared as overloaded. */
1416 /* GvSV contains the name of the method. */
1419 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1420 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1421 GvSV(gv), cp, hvname) );
1422 if (!SvPOK(GvSV(gv))
1423 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
1426 /* Can be an import stub (created by "can"). */
1427 SV *gvsv = GvSV(gv);
1428 const char * const name = SvPOK(gvsv) ? SvPVX_const(gvsv) : "???";
1429 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1430 "in package \"%.256s\"",
1431 (GvCVGEN(gv) ? "Stub found while resolving"
1435 cv = GvCV(gv = ngv);
1437 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1438 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1439 GvNAME(CvGV(cv))) );
1441 if (i < DESTROY_amg)
1443 } else if (gv) { /* Autoloaded... */
1447 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1450 AMT_AMAGIC_on(&amt);
1452 AMT_OVERLOADED_on(&amt);
1453 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1454 (char*)&amt, sizeof(AMT));
1458 /* Here we have no table: */
1460 AMT_AMAGIC_off(&amt);
1461 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1462 (char*)&amt, sizeof(AMTS));
1468 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1473 if (!stash || !HvNAME_get(stash))
1475 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1479 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1481 amtp = (AMT*)mg->mg_ptr;
1482 if ( amtp->was_ok_am != PL_amagic_generation
1483 || amtp->was_ok_sub != PL_sub_generation )
1485 if (AMT_AMAGIC(amtp)) {
1486 CV * const ret = amtp->table[id];
1487 if (ret && isGV(ret)) { /* Autoloading stab */
1488 /* Passing it through may have resulted in a warning
1489 "Inherited AUTOLOAD for a non-method deprecated", since
1490 our caller is going through a function call, not a method call.
1491 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1492 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1505 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1510 CV **cvp=NULL, **ocvp=NULL;
1511 AMT *amtp=NULL, *oamtp=NULL;
1512 int off = 0, off1, lr = 0, notfound = 0;
1513 int postpr = 0, force_cpy = 0;
1514 int assign = AMGf_assign & flags;
1515 const int assignshift = assign ? 1 : 0;
1520 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1521 && (stash = SvSTASH(SvRV(left)))
1522 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1523 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1524 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1526 && ((cv = cvp[off=method+assignshift])
1527 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1533 cv = cvp[off=method])))) {
1534 lr = -1; /* Call method for left argument */
1536 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1539 /* look for substituted methods */
1540 /* In all the covered cases we should be called with assign==0. */
1544 if ((cv = cvp[off=add_ass_amg])
1545 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1546 right = &PL_sv_yes; lr = -1; assign = 1;
1551 if ((cv = cvp[off = subtr_ass_amg])
1552 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1553 right = &PL_sv_yes; lr = -1; assign = 1;
1557 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1560 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1563 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1566 (void)((cv = cvp[off=bool__amg])
1567 || (cv = cvp[off=numer_amg])
1568 || (cv = cvp[off=string_amg]));
1574 * SV* ref causes confusion with the interpreter variable of
1577 SV* tmpRef=SvRV(left);
1578 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1580 * Just to be extra cautious. Maybe in some
1581 * additional cases sv_setsv is safe, too.
1583 SV* newref = newSVsv(tmpRef);
1584 SvOBJECT_on(newref);
1585 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1591 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1592 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1593 SV* nullsv=sv_2mortal(newSViv(0));
1595 SV* lessp = amagic_call(left,nullsv,
1596 lt_amg,AMGf_noright);
1597 logic = SvTRUE(lessp);
1599 SV* lessp = amagic_call(left,nullsv,
1600 ncmp_amg,AMGf_noright);
1601 logic = (SvNV(lessp) < 0);
1604 if (off==subtr_amg) {
1615 if ((cv = cvp[off=subtr_amg])) {
1617 left = sv_2mortal(newSViv(0));
1622 case iter_amg: /* XXXX Eventually should do to_gv. */
1624 return NULL; /* Delegate operation to standard mechanisms. */
1632 return left; /* Delegate operation to standard mechanisms. */
1637 if (!cv) goto not_found;
1638 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1639 && (stash = SvSTASH(SvRV(right)))
1640 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1641 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1642 ? (amtp = (AMT*)mg->mg_ptr)->table
1644 && (cv = cvp[off=method])) { /* Method for right
1647 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1648 && (cvp=ocvp) && (lr = -1))
1649 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1650 && !(flags & AMGf_unary)) {
1651 /* We look for substitution for
1652 * comparison operations and
1654 if (method==concat_amg || method==concat_ass_amg
1655 || method==repeat_amg || method==repeat_ass_amg) {
1656 return NULL; /* Delegate operation to string conversion */
1666 postpr = 1; off=ncmp_amg; break;
1673 postpr = 1; off=scmp_amg; break;
1675 if (off != -1) cv = cvp[off];
1680 not_found: /* No method found, either report or croak */
1688 return left; /* Delegate operation to standard mechanisms. */
1691 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1692 notfound = 1; lr = -1;
1693 } else if (cvp && (cv=cvp[nomethod_amg])) {
1694 notfound = 1; lr = 1;
1697 if (off==-1) off=method;
1698 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1699 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1700 AMG_id2name(method + assignshift),
1701 (flags & AMGf_unary ? " " : "\n\tleft "),
1703 "in overloaded package ":
1704 "has no overloaded magic",
1706 HvNAME_get(SvSTASH(SvRV(left))):
1709 ",\n\tright argument in overloaded package ":
1712 : ",\n\tright argument has no overloaded magic"),
1714 HvNAME_get(SvSTASH(SvRV(right))):
1716 if (amtp && amtp->fallback >= AMGfallYES) {
1717 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1719 Perl_croak(aTHX_ "%"SVf, msg);
1723 force_cpy = force_cpy || assign;
1728 DEBUG_o(Perl_deb(aTHX_
1729 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1731 method+assignshift==off? "" :
1733 method+assignshift==off? "" :
1734 AMG_id2name(method+assignshift),
1735 method+assignshift==off? "" : "\")",
1736 flags & AMGf_unary? "" :
1737 lr==1 ? " for right argument": " for left argument",
1738 flags & AMGf_unary? " for argument" : "",
1739 stash ? HvNAME_get(stash) : "null",
1740 fl? ",\n\tassignment variant used": "") );
1743 /* Since we use shallow copy during assignment, we need
1744 * to dublicate the contents, probably calling user-supplied
1745 * version of copy operator
1747 /* We need to copy in following cases:
1748 * a) Assignment form was called.
1749 * assignshift==1, assign==T, method + 1 == off
1750 * b) Increment or decrement, called directly.
1751 * assignshift==0, assign==0, method + 0 == off
1752 * c) Increment or decrement, translated to assignment add/subtr.
1753 * assignshift==0, assign==T,
1755 * d) Increment or decrement, translated to nomethod.
1756 * assignshift==0, assign==0,
1758 * e) Assignment form translated to nomethod.
1759 * assignshift==1, assign==T, method + 1 != off
1762 /* off is method, method+assignshift, or a result of opcode substitution.
1763 * In the latter case assignshift==0, so only notfound case is important.
1765 if (( (method + assignshift == off)
1766 && (assign || (method == inc_amg) || (method == dec_amg)))
1773 const bool oldcatch = CATCH_GET;
1776 Zero(&myop, 1, BINOP);
1777 myop.op_last = (OP *) &myop;
1778 myop.op_next = Nullop;
1779 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1781 PUSHSTACKi(PERLSI_OVERLOAD);
1784 PL_op = (OP *) &myop;
1785 if (PERLDB_SUB && PL_curstash != PL_debstash)
1786 PL_op->op_private |= OPpENTERSUB_DB;
1790 EXTEND(SP, notfound + 5);
1791 PUSHs(lr>0? right: left);
1792 PUSHs(lr>0? left: right);
1793 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1795 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1800 if ((PL_op = Perl_pp_entersub(aTHX)))
1808 CATCH_SET(oldcatch);
1815 ans=SvIV(res)<=0; break;
1818 ans=SvIV(res)<0; break;
1821 ans=SvIV(res)>=0; break;
1824 ans=SvIV(res)>0; break;
1827 ans=SvIV(res)==0; break;
1830 ans=SvIV(res)!=0; break;
1833 SvSetSV(left,res); return left;
1835 ans=!SvTRUE(res); break;
1840 } else if (method==copy_amg) {
1842 Perl_croak(aTHX_ "Copy method did not return a reference");
1844 return SvREFCNT_inc(SvRV(res));
1852 =for apidoc is_gv_magical_sv
1854 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1860 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1863 const char *temp = SvPV_const(name, len);
1864 return is_gv_magical(temp, len, flags);
1868 =for apidoc is_gv_magical
1870 Returns C<TRUE> if given the name of a magical GV.
1872 Currently only useful internally when determining if a GV should be
1873 created even in rvalue contexts.
1875 C<flags> is not used at present but available for future extension to
1876 allow selecting particular classes of magical variable.
1878 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1879 This assumption is met by all callers within the perl core, which all pass
1880 pointers returned by SvPV.
1885 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1889 const char * const name1 = name + 1;
1892 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1896 if (len == 8 && strEQ(name1, "VERLOAD"))
1900 if (len == 3 && name[1] == 'I' && name[2] == 'G')
1903 /* Using ${^...} variables is likely to be sufficiently rare that
1904 it seems sensible to avoid the space hit of also checking the
1906 case '\017': /* ${^OPEN} */
1907 if (strEQ(name1, "PEN"))
1910 case '\024': /* ${^TAINT} */
1911 if (strEQ(name1, "AINT"))
1914 case '\025': /* ${^UNICODE} */
1915 if (strEQ(name1, "NICODE"))
1917 if (strEQ(name1, "TF8LOCALE"))
1920 case '\027': /* ${^WARNING_BITS} */
1921 if (strEQ(name1, "ARNING_BITS"))
1934 const char *end = name + len;
1935 while (--end > name) {
1943 /* Because we're already assuming that name is NUL terminated
1944 below, we can treat an empty name as "\0" */
1971 case '\001': /* $^A */
1972 case '\003': /* $^C */
1973 case '\004': /* $^D */
1974 case '\005': /* $^E */
1975 case '\006': /* $^F */
1976 case '\010': /* $^H */
1977 case '\011': /* $^I, NOT \t in EBCDIC */
1978 case '\014': /* $^L */
1979 case '\016': /* $^N */
1980 case '\017': /* $^O */
1981 case '\020': /* $^P */
1982 case '\023': /* $^S */
1983 case '\024': /* $^T */
1984 case '\026': /* $^V */
1985 case '\027': /* $^W */
2006 * c-indentation-style: bsd
2008 * indent-tabs-mode: t
2011 * ex: set ts=8 sts=4 sw=4 noet: