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 * const 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);
465 CV* const cv = GvCV(gv);
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 * const 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 * const 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 SV * const 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")) {
885 AV* const av = GvAVn(gv);
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")) {
908 HV* const hv = GvHVn(gv);
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++) {
926 SV ** const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
928 sv_setsv(*init, &PL_sv_undef);
936 if (strEQ(name2, "ERSION"))
939 case '\003': /* $^CHILD_ERROR_NATIVE */
940 if (strEQ(name2, "HILD_ERROR_NATIVE"))
943 case '\005': /* $^ENCODING */
944 if (strEQ(name2, "NCODING"))
947 case '\017': /* $^OPEN */
948 if (strEQ(name2, "PEN"))
951 case '\024': /* ${^TAINT} */
952 if (strEQ(name2, "AINT"))
955 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
956 if (strEQ(name2, "NICODE"))
958 if (strEQ(name2, "TF8LOCALE"))
961 case '\027': /* $^WARNING_BITS */
962 if (strEQ(name2, "ARNING_BITS"))
975 /* ensures variable is only digits */
976 /* ${"1foo"} fails this test (and is thus writeable) */
977 /* added by japhy, but borrowed from is_gv_magical */
978 const char *end = name + len;
979 while (--end > name) {
980 if (!isDIGIT(*end)) return gv;
987 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
988 be case '\0' in this switch statement (ie a default case) */
994 sv_type == SVt_PVAV ||
995 sv_type == SVt_PVHV ||
996 sv_type == SVt_PVCV ||
997 sv_type == SVt_PVFM ||
1000 PL_sawampersand = TRUE;
1004 sv_setpv(GvSV(gv),PL_chopset);
1008 #ifdef COMPLEX_STATUS
1009 SvUPGRADE(GvSV(gv), SVt_PVLV);
1015 /* If %! has been used, automatically load Errno.pm.
1016 The require will itself set errno, so in order to
1017 preserve its value we have to set up the magic
1018 now (rather than going to magicalize)
1021 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1023 if (sv_type == SVt_PVHV)
1029 AV* const av = GvAVn(gv);
1030 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1036 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1037 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1038 "$%c is no longer supported", *name);
1041 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1046 AV* const av = GvAVn(gv);
1047 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1051 case '\023': /* $^S */
1062 SvREADONLY_on(GvSV(gv));
1077 case '\001': /* $^A */
1078 case '\003': /* $^C */
1079 case '\004': /* $^D */
1080 case '\005': /* $^E */
1081 case '\006': /* $^F */
1082 case '\010': /* $^H */
1083 case '\011': /* $^I, NOT \t in EBCDIC */
1084 case '\016': /* $^N */
1085 case '\017': /* $^O */
1086 case '\020': /* $^P */
1087 case '\024': /* $^T */
1088 case '\027': /* $^W */
1090 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1093 case '\014': /* $^L */
1094 sv_setpvn(GvSV(gv),"\f",1);
1095 PL_formfeed = GvSV(gv);
1098 sv_setpvn(GvSV(gv),"\034",1);
1102 SV * const sv = GvSV(gv);
1103 if (!sv_derived_from(PL_patchlevel, "version"))
1104 (void *)upg_version(PL_patchlevel);
1105 GvSV(gv) = vnumify(PL_patchlevel);
1106 SvREADONLY_on(GvSV(gv));
1110 case '\026': /* $^V */
1112 SV * const sv = GvSV(gv);
1113 GvSV(gv) = new_version(PL_patchlevel);
1114 SvREADONLY_on(GvSV(gv));
1124 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1128 const HV * const hv = GvSTASH(gv);
1133 sv_setpv(sv, prefix ? prefix : "");
1135 name = HvNAME_get(hv);
1137 namelen = HvNAMELEN_get(hv);
1143 if (keepmain || strNE(name, "main")) {
1144 sv_catpvn(sv,name,namelen);
1145 sv_catpvn(sv,"::", 2);
1147 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1151 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1153 gv_fullname4(sv, gv, prefix, TRUE);
1157 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1159 const GV *egv = GvEGV(gv);
1162 gv_fullname4(sv, egv, prefix, keepmain);
1166 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1168 gv_efullname4(sv, gv, prefix, TRUE);
1171 /* compatibility with versions <= 5.003. */
1173 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1175 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1178 /* compatibility with versions <= 5.003. */
1180 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1182 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1189 IO * const io = (IO*)NEWSV(0,0);
1191 sv_upgrade((SV *)io,SVt_PVIO);
1194 /* Clear the stashcache because a new IO could overrule a package name */
1195 hv_clear(PL_stashcache);
1196 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1197 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1198 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1199 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1200 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1205 Perl_gv_check(pTHX_ HV *stash)
1209 if (!HvARRAY(stash))
1211 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1213 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1216 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1217 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1219 if (hv != PL_defstash && hv != stash)
1220 gv_check(hv); /* nested package */
1222 else if (isALPHA(*HeKEY(entry))) {
1224 gv = (GV*)HeVAL(entry);
1225 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1228 /* performance hack: if filename is absolute and it's a standard
1229 * module, don't bother warning */
1231 && PERL_FILE_IS_ABSOLUTE(file)
1232 #ifdef MACOS_TRADITIONAL
1233 && (instr(file, ":lib:")
1235 && (instr(file, "/lib/")
1237 || instr(file, ".pm")))
1241 CopLINE_set(PL_curcop, GvLINE(gv));
1243 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1245 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1247 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1248 "Name \"%s::%s\" used only once: possible typo",
1249 HvNAME_get(stash), GvNAME(gv));
1256 Perl_newGVgen(pTHX_ const char *pack)
1258 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1262 /* hopefully this is only called on local symbol table entries */
1265 Perl_gp_ref(pTHX_ GP *gp)
1272 /* multi-named GPs cannot be used for method cache */
1273 SvREFCNT_dec(gp->gp_cv);
1278 /* Adding a new name to a subroutine invalidates method cache */
1279 PL_sub_generation++;
1286 Perl_gp_free(pTHX_ GV *gv)
1290 if (!gv || !(gp = GvGP(gv)))
1292 if (gp->gp_refcnt == 0) {
1293 if (ckWARN_d(WARN_INTERNAL))
1294 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1295 "Attempt to free unreferenced glob pointers"
1296 pTHX__FORMAT pTHX__VALUE);
1300 /* Deleting the name of a subroutine invalidates method cache */
1301 PL_sub_generation++;
1303 if (--gp->gp_refcnt > 0) {
1304 if (gp->gp_egv == gv)
1309 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1310 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1311 /* FIXME - another reference loop GV -> symtab -> GV ?
1312 Somehow gp->gp_hv can end up pointing at freed garbage. */
1313 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1314 const char *hvname = HvNAME_get(gp->gp_hv);
1315 if (PL_stashcache && hvname)
1316 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1318 SvREFCNT_dec(gp->gp_hv);
1320 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1321 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1322 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1329 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1331 AMT * const amtp = (AMT*)mg->mg_ptr;
1332 PERL_UNUSED_ARG(sv);
1334 if (amtp && AMT_AMAGIC(amtp)) {
1336 for (i = 1; i < NofAMmeth; i++) {
1337 CV * const cv = amtp->table[i];
1339 SvREFCNT_dec((SV *) cv);
1340 amtp->table[i] = Nullcv;
1347 /* Updates and caches the CV's */
1350 Perl_Gv_AMupdate(pTHX_ HV *stash)
1352 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1353 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1356 if (mg && amtp->was_ok_am == PL_amagic_generation
1357 && amtp->was_ok_sub == PL_sub_generation)
1358 return (bool)AMT_OVERLOADED(amtp);
1359 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1361 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1364 amt.was_ok_am = PL_amagic_generation;
1365 amt.was_ok_sub = PL_sub_generation;
1366 amt.fallback = AMGfallNO;
1370 int filled = 0, have_ovl = 0;
1373 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1375 /* Try to find via inheritance. */
1376 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1377 SV * const sv = gv ? GvSV(gv) : NULL;
1381 lim = DESTROY_amg; /* Skip overloading entries. */
1382 else if (SvTRUE(sv))
1383 amt.fallback=AMGfallYES;
1385 amt.fallback=AMGfallNEVER;
1387 for (i = 1; i < lim; i++)
1388 amt.table[i] = Nullcv;
1389 for (; i < NofAMmeth; i++) {
1390 const char *cooky = PL_AMG_names[i];
1391 /* Human-readable form, for debugging: */
1392 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1393 const STRLEN l = strlen(cooky);
1395 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1396 cp, HvNAME_get(stash)) );
1397 /* don't fill the cache while looking up!
1398 Creation of inheritance stubs in intermediate packages may
1399 conflict with the logic of runtime method substitution.
1400 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1401 then we could have created stubs for "(+0" in A and C too.
1402 But if B overloads "bool", we may want to use it for
1403 numifying instead of C's "+0". */
1404 if (i >= DESTROY_amg)
1405 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1406 else /* Autoload taken care of below */
1407 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1409 if (gv && (cv = GvCV(gv))) {
1411 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1412 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1413 /* This is a hack to support autoloading..., while
1414 knowing *which* methods were declared as overloaded. */
1415 /* GvSV contains the name of the method. */
1418 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1419 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1420 GvSV(gv), cp, hvname) );
1421 if (!SvPOK(GvSV(gv))
1422 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
1425 /* Can be an import stub (created by "can"). */
1426 SV *gvsv = GvSV(gv);
1427 const char * const name = SvPOK(gvsv) ? SvPVX_const(gvsv) : "???";
1428 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1429 "in package \"%.256s\"",
1430 (GvCVGEN(gv) ? "Stub found while resolving"
1434 cv = GvCV(gv = ngv);
1436 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1437 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1438 GvNAME(CvGV(cv))) );
1440 if (i < DESTROY_amg)
1442 } else if (gv) { /* Autoloaded... */
1446 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1449 AMT_AMAGIC_on(&amt);
1451 AMT_OVERLOADED_on(&amt);
1452 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1453 (char*)&amt, sizeof(AMT));
1457 /* Here we have no table: */
1459 AMT_AMAGIC_off(&amt);
1460 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1461 (char*)&amt, sizeof(AMTS));
1467 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1472 if (!stash || !HvNAME_get(stash))
1474 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1478 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1480 amtp = (AMT*)mg->mg_ptr;
1481 if ( amtp->was_ok_am != PL_amagic_generation
1482 || amtp->was_ok_sub != PL_sub_generation )
1484 if (AMT_AMAGIC(amtp)) {
1485 CV * const ret = amtp->table[id];
1486 if (ret && isGV(ret)) { /* Autoloading stab */
1487 /* Passing it through may have resulted in a warning
1488 "Inherited AUTOLOAD for a non-method deprecated", since
1489 our caller is going through a function call, not a method call.
1490 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1491 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1504 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1509 CV **cvp=NULL, **ocvp=NULL;
1510 AMT *amtp=NULL, *oamtp=NULL;
1511 int off = 0, off1, lr = 0, notfound = 0;
1512 int postpr = 0, force_cpy = 0;
1513 int assign = AMGf_assign & flags;
1514 const int assignshift = assign ? 1 : 0;
1519 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1520 && (stash = SvSTASH(SvRV(left)))
1521 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1522 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1523 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1525 && ((cv = cvp[off=method+assignshift])
1526 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1532 cv = cvp[off=method])))) {
1533 lr = -1; /* Call method for left argument */
1535 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1538 /* look for substituted methods */
1539 /* In all the covered cases we should be called with assign==0. */
1543 if ((cv = cvp[off=add_ass_amg])
1544 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1545 right = &PL_sv_yes; lr = -1; assign = 1;
1550 if ((cv = cvp[off = subtr_ass_amg])
1551 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1552 right = &PL_sv_yes; lr = -1; assign = 1;
1556 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1559 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1562 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1565 (void)((cv = cvp[off=bool__amg])
1566 || (cv = cvp[off=numer_amg])
1567 || (cv = cvp[off=string_amg]));
1573 * SV* ref causes confusion with the interpreter variable of
1576 SV* tmpRef=SvRV(left);
1577 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1579 * Just to be extra cautious. Maybe in some
1580 * additional cases sv_setsv is safe, too.
1582 SV* newref = newSVsv(tmpRef);
1583 SvOBJECT_on(newref);
1584 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1590 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1591 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1592 SV* nullsv=sv_2mortal(newSViv(0));
1594 SV* lessp = amagic_call(left,nullsv,
1595 lt_amg,AMGf_noright);
1596 logic = SvTRUE(lessp);
1598 SV* lessp = amagic_call(left,nullsv,
1599 ncmp_amg,AMGf_noright);
1600 logic = (SvNV(lessp) < 0);
1603 if (off==subtr_amg) {
1614 if ((cv = cvp[off=subtr_amg])) {
1616 left = sv_2mortal(newSViv(0));
1621 case iter_amg: /* XXXX Eventually should do to_gv. */
1623 return NULL; /* Delegate operation to standard mechanisms. */
1631 return left; /* Delegate operation to standard mechanisms. */
1636 if (!cv) goto not_found;
1637 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1638 && (stash = SvSTASH(SvRV(right)))
1639 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1640 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1641 ? (amtp = (AMT*)mg->mg_ptr)->table
1643 && (cv = cvp[off=method])) { /* Method for right
1646 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1647 && (cvp=ocvp) && (lr = -1))
1648 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1649 && !(flags & AMGf_unary)) {
1650 /* We look for substitution for
1651 * comparison operations and
1653 if (method==concat_amg || method==concat_ass_amg
1654 || method==repeat_amg || method==repeat_ass_amg) {
1655 return NULL; /* Delegate operation to string conversion */
1665 postpr = 1; off=ncmp_amg; break;
1672 postpr = 1; off=scmp_amg; break;
1674 if (off != -1) cv = cvp[off];
1679 not_found: /* No method found, either report or croak */
1687 return left; /* Delegate operation to standard mechanisms. */
1690 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1691 notfound = 1; lr = -1;
1692 } else if (cvp && (cv=cvp[nomethod_amg])) {
1693 notfound = 1; lr = 1;
1696 if (off==-1) off=method;
1697 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1698 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1699 AMG_id2name(method + assignshift),
1700 (flags & AMGf_unary ? " " : "\n\tleft "),
1702 "in overloaded package ":
1703 "has no overloaded magic",
1705 HvNAME_get(SvSTASH(SvRV(left))):
1708 ",\n\tright argument in overloaded package ":
1711 : ",\n\tright argument has no overloaded magic"),
1713 HvNAME_get(SvSTASH(SvRV(right))):
1715 if (amtp && amtp->fallback >= AMGfallYES) {
1716 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1718 Perl_croak(aTHX_ "%"SVf, msg);
1722 force_cpy = force_cpy || assign;
1727 DEBUG_o(Perl_deb(aTHX_
1728 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1730 method+assignshift==off? "" :
1732 method+assignshift==off? "" :
1733 AMG_id2name(method+assignshift),
1734 method+assignshift==off? "" : "\")",
1735 flags & AMGf_unary? "" :
1736 lr==1 ? " for right argument": " for left argument",
1737 flags & AMGf_unary? " for argument" : "",
1738 stash ? HvNAME_get(stash) : "null",
1739 fl? ",\n\tassignment variant used": "") );
1742 /* Since we use shallow copy during assignment, we need
1743 * to dublicate the contents, probably calling user-supplied
1744 * version of copy operator
1746 /* We need to copy in following cases:
1747 * a) Assignment form was called.
1748 * assignshift==1, assign==T, method + 1 == off
1749 * b) Increment or decrement, called directly.
1750 * assignshift==0, assign==0, method + 0 == off
1751 * c) Increment or decrement, translated to assignment add/subtr.
1752 * assignshift==0, assign==T,
1754 * d) Increment or decrement, translated to nomethod.
1755 * assignshift==0, assign==0,
1757 * e) Assignment form translated to nomethod.
1758 * assignshift==1, assign==T, method + 1 != off
1761 /* off is method, method+assignshift, or a result of opcode substitution.
1762 * In the latter case assignshift==0, so only notfound case is important.
1764 if (( (method + assignshift == off)
1765 && (assign || (method == inc_amg) || (method == dec_amg)))
1772 const bool oldcatch = CATCH_GET;
1775 Zero(&myop, 1, BINOP);
1776 myop.op_last = (OP *) &myop;
1777 myop.op_next = Nullop;
1778 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1780 PUSHSTACKi(PERLSI_OVERLOAD);
1783 PL_op = (OP *) &myop;
1784 if (PERLDB_SUB && PL_curstash != PL_debstash)
1785 PL_op->op_private |= OPpENTERSUB_DB;
1789 EXTEND(SP, notfound + 5);
1790 PUSHs(lr>0? right: left);
1791 PUSHs(lr>0? left: right);
1792 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1794 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1799 if ((PL_op = Perl_pp_entersub(aTHX)))
1807 CATCH_SET(oldcatch);
1814 ans=SvIV(res)<=0; break;
1817 ans=SvIV(res)<0; break;
1820 ans=SvIV(res)>=0; break;
1823 ans=SvIV(res)>0; break;
1826 ans=SvIV(res)==0; break;
1829 ans=SvIV(res)!=0; break;
1832 SvSetSV(left,res); return left;
1834 ans=!SvTRUE(res); break;
1839 } else if (method==copy_amg) {
1841 Perl_croak(aTHX_ "Copy method did not return a reference");
1843 return SvREFCNT_inc(SvRV(res));
1851 =for apidoc is_gv_magical_sv
1853 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1859 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1862 const char *temp = SvPV_const(name, len);
1863 return is_gv_magical(temp, len, flags);
1867 =for apidoc is_gv_magical
1869 Returns C<TRUE> if given the name of a magical GV.
1871 Currently only useful internally when determining if a GV should be
1872 created even in rvalue contexts.
1874 C<flags> is not used at present but available for future extension to
1875 allow selecting particular classes of magical variable.
1877 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1878 This assumption is met by all callers within the perl core, which all pass
1879 pointers returned by SvPV.
1884 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1886 PERL_UNUSED_ARG(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: