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(gv) : NULL;
116 sv_upgrade((SV*)gv, SVt_PVGV);
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);
135 GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
136 GvNAME(gv) = savepvn(name, len);
138 if (multi || doproto) /* doproto means it _was_ mentioned */
140 if (doproto) { /* Replicate part of newSUB here. */
143 /* XXX unsafe for threads if eval_owner isn't held */
144 start_subparse(0,0); /* Create CV in compcv. */
145 GvCV(gv) = PL_compcv;
150 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
151 CvSTASH(GvCV(gv)) = PL_curstash;
153 sv_setpv((SV*)GvCV(gv), proto);
160 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
176 =for apidoc gv_fetchmeth
178 Returns the glob with the given C<name> and a defined subroutine or
179 C<NULL>. The glob lives in the given C<stash>, or in the stashes
180 accessible via @ISA and UNIVERSAL::.
182 The argument C<level> should be either 0 or -1. If C<level==0>, as a
183 side-effect creates a glob with the given C<name> in the given C<stash>
184 which in the case of success contains an alias for the subroutine, and sets
185 up caching info for this glob. Similarly for all the searched stashes.
187 This function grants C<"SUPER"> token as a postfix of the stash name. The
188 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
189 visible to Perl code. So when calling C<call_sv>, you should not use
190 the GV directly; instead, you should use the method's CV, which can be
191 obtained from the GV with the C<GvCV> macro.
197 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
205 /* UNIVERSAL methods should be callable without a stash */
207 level = -1; /* probably appropriate */
208 if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
214 "Can't use anonymous symbol table for method lookup");
216 if ((level > 100) || (level < -100))
217 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
218 name, HvNAME(stash));
220 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
222 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
227 if (SvTYPE(topgv) != SVt_PVGV)
228 gv_init(topgv, stash, name, len, TRUE);
229 if ((cv = GvCV(topgv))) {
230 /* If genuine method or valid cache entry, use it */
231 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
233 /* Stale cached entry: junk it */
235 GvCV(topgv) = cv = Nullcv;
238 else if (GvCVGEN(topgv) == PL_sub_generation)
239 return 0; /* cache indicates sub doesn't exist */
242 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
243 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
245 /* create and re-create @.*::SUPER::ISA on demand */
246 if (!av || !SvMAGIC(av)) {
247 const char* packname = HvNAME(stash);
248 STRLEN packlen = strlen(packname);
250 if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
254 basestash = gv_stashpvn(packname, packlen, TRUE);
255 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
256 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
257 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
258 if (!gvp || !(gv = *gvp))
259 Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
260 if (SvTYPE(gv) != SVt_PVGV)
261 gv_init(gv, stash, "ISA", 3, TRUE);
262 SvREFCNT_dec(GvAV(gv));
263 GvAV(gv) = (AV*)SvREFCNT_inc(av);
269 SV** svp = AvARRAY(av);
270 /* NOTE: No support for tied ISA */
271 I32 items = AvFILLp(av) + 1;
274 HV* basestash = gv_stashsv(sv, FALSE);
276 if (ckWARN(WARN_MISC))
277 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
281 gv = gv_fetchmeth(basestash, name, len,
282 (level >= 0) ? level + 1 : level - 1);
288 /* if at top level, try UNIVERSAL */
290 if (level == 0 || level == -1) {
293 if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
294 if ((gv = gv_fetchmeth(lastchance, name, len,
295 (level >= 0) ? level + 1 : level - 1)))
299 * Cache method in topgv if:
300 * 1. topgv has no synonyms (else inheritance crosses wires)
301 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
304 GvREFCNT(topgv) == 1 &&
306 (CvROOT(cv) || CvXSUB(cv)))
308 if ((cv = GvCV(topgv)))
310 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
311 GvCVGEN(topgv) = PL_sub_generation;
315 else if (topgv && GvREFCNT(topgv) == 1) {
316 /* cache the fact that the method is not defined */
317 GvCVGEN(topgv) = PL_sub_generation;
326 =for apidoc gv_fetchmeth_autoload
328 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
329 Returns a glob for the subroutine.
331 For an autoloaded subroutine without a GV, will create a GV even
332 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
333 of the result may be zero.
339 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
341 GV *gv = gv_fetchmeth(stash, name, len, level);
348 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
349 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
351 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
354 if (!(CvROOT(cv) || CvXSUB(cv)))
356 /* Have an autoload */
357 if (level < 0) /* Cannot do without a stub */
358 gv_fetchmeth(stash, name, len, 0);
359 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
368 =for apidoc gv_fetchmethod
370 See L<gv_fetchmethod_autoload>.
376 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
378 return gv_fetchmethod_autoload(stash, name, TRUE);
382 =for apidoc gv_fetchmethod_autoload
384 Returns the glob which contains the subroutine to call to invoke the method
385 on the C<stash>. In fact in the presence of autoloading this may be the
386 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
389 The third parameter of C<gv_fetchmethod_autoload> determines whether
390 AUTOLOAD lookup is performed if the given method is not present: non-zero
391 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
392 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
393 with a non-zero C<autoload> parameter.
395 These functions grant C<"SUPER"> token as a prefix of the method name. Note
396 that if you want to keep the returned glob for a long time, you need to
397 check for it being "AUTOLOAD", since at the later time the call may load a
398 different subroutine due to $AUTOLOAD changing its value. Use the glob
399 created via a side effect to do this.
401 These functions have the same side-effects and as C<gv_fetchmeth> with
402 C<level==0>. C<name> should be writable if contains C<':'> or C<'
403 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
404 C<call_sv> apply equally to these functions.
410 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
412 register const char *nend;
413 const char *nsplit = 0;
417 if (stash && SvTYPE(stash) < SVt_PVHV)
420 for (nend = name; *nend; nend++) {
423 else if (*nend == ':' && *(nend + 1) == ':')
427 const char *origname = name;
431 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
432 /* ->SUPER::method should really be looked up in original stash */
433 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
434 CopSTASHPV(PL_curcop)));
435 /* __PACKAGE__::SUPER stash should be autovivified */
436 stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
437 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
438 origname, HvNAME(stash), name) );
441 /* don't autovifify if ->NoSuchStash::method */
442 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
444 /* however, explicit calls to Pkg::SUPER::method may
445 happen, and may require autovivification to work */
446 if (!stash && (nsplit - origname) >= 7 &&
447 strnEQ(nsplit - 7, "::SUPER", 7) &&
448 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
449 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
454 gv = gv_fetchmeth(stash, name, nend - name, 0);
456 if (strEQ(name,"import") || strEQ(name,"unimport"))
457 gv = (GV*)&PL_sv_yes;
459 gv = gv_autoload4(ostash, name, nend - name, TRUE);
463 if (!CvROOT(cv) && !CvXSUB(cv)) {
471 if (GvCV(stubgv) != cv) /* orphaned import */
474 autogv = gv_autoload4(GvSTASH(stubgv),
475 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
485 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
493 const char *packname = "";
495 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
498 if (SvTYPE(stash) < SVt_PVHV) {
499 packname = SvPV_nolen((SV*)stash);
503 packname = HvNAME(stash);
506 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
510 if (!(CvROOT(cv) || CvXSUB(cv)))
514 * Inheriting AUTOLOAD for non-methods works ... for now.
516 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
517 (GvCVGEN(gv) || GvSTASH(gv) != stash))
518 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
519 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
520 packname, (int)len, name);
523 /* rather than lookup/init $AUTOLOAD here
524 * only to have the XSUB do another lookup for $AUTOLOAD
525 * and split that value on the last '::',
526 * pass along the same data via some unused fields in the CV
529 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
535 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
536 * The subroutine's original name may not be "AUTOLOAD", so we don't
537 * use that, but for lack of anything better we will use the sub's
538 * original package to look up $AUTOLOAD.
540 varstash = GvSTASH(CvGV(cv));
541 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
545 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
548 sv_setpv(varsv, packname);
549 sv_catpvn(varsv, "::", 2);
550 sv_catpvn(varsv, name, len);
551 SvTAINTED_off(varsv);
555 /* The "gv" parameter should be the glob known to Perl code as *!
556 * The scalar must already have been magicalized.
559 S_require_errno(pTHX_ GV *gv)
562 HV* stash = gv_stashpvn("Errno",5,FALSE);
564 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
568 save_scalar(gv); /* keep the value of $! */
569 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
570 newSVpvn("Errno",5), Nullsv);
573 stash = gv_stashpvn("Errno",5,FALSE);
574 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
575 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
580 =for apidoc gv_stashpv
582 Returns a pointer to the stash for a specified package. C<name> should
583 be a valid UTF-8 string and must be null-terminated. If C<create> is set
584 then the package will be created if it does not already exist. If C<create>
585 is not set and the package does not exist then NULL is returned.
591 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
593 return gv_stashpvn(name, strlen(name), create);
597 =for apidoc gv_stashpvn
599 Returns a pointer to the stash for a specified package. C<name> should
600 be a valid UTF-8 string. The C<namelen> parameter indicates the length of
601 the C<name>, in bytes. If C<create> is set then the package will be
602 created if it does not already exist. If C<create> is not set and the
603 package does not exist then NULL is returned.
609 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
616 if (namelen + 3 < sizeof smallbuf)
619 New(606, tmpbuf, namelen + 3, char);
620 Copy(name,tmpbuf,namelen,char);
621 tmpbuf[namelen++] = ':';
622 tmpbuf[namelen++] = ':';
623 tmpbuf[namelen] = '\0';
624 tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
625 if (tmpbuf != smallbuf)
630 GvHV(tmpgv) = newHV();
633 HvNAME(stash) = savepv(name);
638 =for apidoc gv_stashsv
640 Returns a pointer to the stash for a specified package, which must be a
641 valid UTF-8 string. See C<gv_stashpv>.
647 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
650 const char *ptr = SvPV(sv,len);
651 return gv_stashpvn(ptr, len, create);
656 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
657 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
661 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
663 const char *nambeg = SvPV(name, len);
664 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
668 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
671 register const char *name = nambeg;
675 register const char *namend;
677 const I32 add = flags & ~SVf_UTF8;
680 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
683 for (namend = name; *namend; namend++) {
684 if ((*namend == ':' && namend[1] == ':')
685 || (*namend == '\'' && namend[1]))
689 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
697 if (len + 3 < sizeof (smallbuf))
700 New(601, tmpbuf, len+3, char);
701 Copy(name, tmpbuf, len, char);
705 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
706 gv = gvp ? *gvp : Nullgv;
707 if (gv && gv != (GV*)&PL_sv_undef) {
708 if (SvTYPE(gv) != SVt_PVGV)
709 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
713 if (tmpbuf != smallbuf)
715 if (!gv || gv == (GV*)&PL_sv_undef)
718 if (!(stash = GvHV(gv)))
719 stash = GvHV(gv) = newHV();
722 HvNAME(stash) = savepvn(nambeg, namend - nambeg);
730 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
735 /* No stash in name, so see how we can default */
738 if (isIDFIRST_lazy(name)) {
741 /* name is always \0 terminated, and initial \0 wouldn't return
742 true from isIDFIRST_lazy, so we know that name[1] is defined */
749 if (strEQ(name, "INC") || strEQ(name, "ENV"))
753 if (strEQ(name, "SIG"))
757 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
758 strEQ(name, "STDERR"))
762 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
769 else if (IN_PERL_COMPILETIME) {
771 if (add && (PL_hints & HINT_STRICT_VARS) &&
772 sv_type != SVt_PVCV &&
773 sv_type != SVt_PVGV &&
774 sv_type != SVt_PVFM &&
775 sv_type != SVt_PVIO &&
776 !(len == 1 && sv_type == SVt_PV &&
777 (*name == 'a' || *name == 'b')) )
779 gvp = (GV**)hv_fetch(stash,name,len,0);
781 *gvp == (GV*)&PL_sv_undef ||
782 SvTYPE(*gvp) != SVt_PVGV)
786 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
787 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
788 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
790 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
791 sv_type == SVt_PVAV ? '@' :
792 sv_type == SVt_PVHV ? '%' : '$',
795 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
801 stash = CopSTASH(PL_curcop);
807 /* By this point we should have a stash and a name */
811 register SV *err = Perl_mess(aTHX_
812 "Global symbol \"%s%s\" requires explicit package name",
813 (sv_type == SVt_PV ? "$"
814 : sv_type == SVt_PVAV ? "@"
815 : sv_type == SVt_PVHV ? "%"
817 if (USE_UTF8_IN_NAMES)
820 stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
826 if (!SvREFCNT(stash)) /* symbol table under destruction */
829 gvp = (GV**)hv_fetch(stash,name,len,add);
830 if (!gvp || *gvp == (GV*)&PL_sv_undef)
833 if (SvTYPE(gv) == SVt_PVGV) {
836 gv_init_sv(gv, sv_type);
837 if (*name=='!' && sv_type == SVt_PVHV && len==1)
841 } else if (add & GV_NOINIT) {
845 /* Adding a new symbol */
847 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
848 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
849 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
850 gv_init_sv(gv, sv_type);
852 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
853 : (PL_dowarn & G_WARN_ON ) ) )
856 /* set up magic where warranted */
860 /* Nothing else to do.
861 The compiler will probably turn the switch statement into a
862 branch table. Make sure we avoid even that small overhead for
863 the common case of lower case variable names. */
867 const char *name2 = name + 1;
870 if (strEQ(name2, "RGV")) {
871 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
875 if (strnEQ(name2, "XPORT", 5))
879 if (strEQ(name2, "SA")) {
882 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
883 /* NOTE: No support for tied ISA */
884 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
885 && AvFILLp(av) == -1)
888 av_push(av, newSVpvn(pname = "NDBM_File",9));
889 gv_stashpvn(pname, 9, TRUE);
890 av_push(av, newSVpvn(pname = "DB_File",7));
891 gv_stashpvn(pname, 7, TRUE);
892 av_push(av, newSVpvn(pname = "GDBM_File",9));
893 gv_stashpvn(pname, 9, TRUE);
894 av_push(av, newSVpvn(pname = "SDBM_File",9));
895 gv_stashpvn(pname, 9, TRUE);
896 av_push(av, newSVpvn(pname = "ODBM_File",9));
897 gv_stashpvn(pname, 9, TRUE);
902 if (strEQ(name2, "VERLOAD")) {
905 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
909 if (strEQ(name2, "IG")) {
913 Newz(73, PL_psig_ptr, SIG_SIZE, SV*);
914 Newz(73, PL_psig_name, SIG_SIZE, SV*);
915 Newz(73, PL_psig_pend, SIG_SIZE, int);
919 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
920 for (i = 1; i < SIG_SIZE; i++) {
922 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
924 sv_setsv(*init, &PL_sv_undef);
932 if (strEQ(name2, "ERSION"))
935 case '\003': /* $^CHILD_ERROR_NATIVE */
936 if (strEQ(name2, "HILD_ERROR_NATIVE"))
939 case '\005': /* $^ENCODING */
940 if (strEQ(name2, "NCODING"))
943 case '\017': /* $^OPEN */
944 if (strEQ(name2, "PEN"))
947 case '\024': /* ${^TAINT} */
948 if (strEQ(name2, "AINT"))
951 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
952 if (strEQ(name2, "NICODE"))
954 if (strEQ(name2, "TF8LOCALE"))
957 case '\027': /* $^WARNING_BITS */
958 if (strEQ(name2, "ARNING_BITS"))
971 /* ensures variable is only digits */
972 /* ${"1foo"} fails this test (and is thus writeable) */
973 /* added by japhy, but borrowed from is_gv_magical */
974 const char *end = name + len;
975 while (--end > name) {
976 if (!isDIGIT(*end)) return gv;
983 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
984 be case '\0' in this switch statement (ie a default case) */
990 sv_type == SVt_PVAV ||
991 sv_type == SVt_PVHV ||
992 sv_type == SVt_PVCV ||
993 sv_type == SVt_PVFM ||
996 PL_sawampersand = TRUE;
1000 sv_setpv(GvSV(gv),PL_chopset);
1004 #ifdef COMPLEX_STATUS
1005 (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
1011 /* If %! has been used, automatically load Errno.pm.
1012 The require will itself set errno, so in order to
1013 preserve its value we have to set up the magic
1014 now (rather than going to magicalize)
1017 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1019 if (sv_type == SVt_PVHV)
1026 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1031 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1032 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1033 "$* is no longer supported");
1036 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1037 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1038 "Use of $# is deprecated");
1041 sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
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_setpv(GvSV(gv),"\f");
1095 PL_formfeed = GvSV(gv);
1098 sv_setpv(GvSV(gv),"\034");
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)
1127 const HV * const hv = GvSTASH(gv);
1132 sv_setpv(sv, prefix ? prefix : "");
1138 if (keepmain || strNE(name, "main")) {
1140 sv_catpvn(sv,"::", 2);
1142 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1146 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1148 gv_fullname4(sv, gv, prefix, TRUE);
1152 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1154 const GV *egv = GvEGV(gv);
1157 gv_fullname4(sv, egv, prefix, keepmain);
1161 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1163 gv_efullname4(sv, gv, prefix, TRUE);
1166 /* compatibility with versions <= 5.003. */
1168 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1170 gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1173 /* compatibility with versions <= 5.003. */
1175 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1177 gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1184 IO * const io = (IO*)NEWSV(0,0);
1186 sv_upgrade((SV *)io,SVt_PVIO);
1189 /* Clear the stashcache because a new IO could overrule a
1191 hv_clear(PL_stashcache);
1192 iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1193 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1194 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1195 iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1196 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1201 Perl_gv_check(pTHX_ HV *stash)
1205 if (!HvARRAY(stash))
1207 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1209 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1212 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1213 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1215 if (hv != PL_defstash && hv != stash)
1216 gv_check(hv); /* nested package */
1218 else if (isALPHA(*HeKEY(entry))) {
1220 gv = (GV*)HeVAL(entry);
1221 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1224 /* performance hack: if filename is absolute and it's a standard
1225 * module, don't bother warning */
1227 && PERL_FILE_IS_ABSOLUTE(file)
1228 #ifdef MACOS_TRADITIONAL
1229 && (instr(file, ":lib:")
1231 && (instr(file, "/lib/")
1233 || instr(file, ".pm")))
1237 CopLINE_set(PL_curcop, GvLINE(gv));
1239 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1241 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1243 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1244 "Name \"%s::%s\" used only once: possible typo",
1245 HvNAME(stash), GvNAME(gv));
1252 Perl_newGVgen(pTHX_ const char *pack)
1254 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1258 /* hopefully this is only called on local symbol table entries */
1261 Perl_gp_ref(pTHX_ GP *gp)
1268 /* multi-named GPs cannot be used for method cache */
1269 SvREFCNT_dec(gp->gp_cv);
1274 /* Adding a new name to a subroutine invalidates method cache */
1275 PL_sub_generation++;
1282 Perl_gp_free(pTHX_ GV *gv)
1286 if (!gv || !(gp = GvGP(gv)))
1288 if (gp->gp_refcnt == 0) {
1289 if (ckWARN_d(WARN_INTERNAL))
1290 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1291 "Attempt to free unreferenced glob pointers"
1292 pTHX__FORMAT pTHX__VALUE);
1296 /* Deleting the name of a subroutine invalidates method cache */
1297 PL_sub_generation++;
1299 if (--gp->gp_refcnt > 0) {
1300 if (gp->gp_egv == gv)
1305 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1306 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1308 if (PL_stashcache && HvNAME(gp->gp_hv))
1309 hv_delete(PL_stashcache,
1310 HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1312 SvREFCNT_dec(gp->gp_hv);
1314 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1315 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1316 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1323 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1325 AMT *amtp = (AMT*)mg->mg_ptr;
1328 if (amtp && AMT_AMAGIC(amtp)) {
1330 for (i = 1; i < NofAMmeth; i++) {
1331 CV *cv = amtp->table[i];
1333 SvREFCNT_dec((SV *) cv);
1334 amtp->table[i] = Nullcv;
1341 /* Updates and caches the CV's */
1344 Perl_Gv_AMupdate(pTHX_ HV *stash)
1348 MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1349 AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1352 if (mg && amtp->was_ok_am == PL_amagic_generation
1353 && amtp->was_ok_sub == PL_sub_generation)
1354 return (bool)AMT_OVERLOADED(amtp);
1355 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1357 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1360 amt.was_ok_am = PL_amagic_generation;
1361 amt.was_ok_sub = PL_sub_generation;
1362 amt.fallback = AMGfallNO;
1366 int filled = 0, have_ovl = 0;
1370 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1372 /* Try to find via inheritance. */
1373 gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1378 lim = DESTROY_amg; /* Skip overloading entries. */
1379 else if (SvTRUE(sv))
1380 amt.fallback=AMGfallYES;
1382 amt.fallback=AMGfallNEVER;
1384 for (i = 1; i < lim; i++)
1385 amt.table[i] = Nullcv;
1386 for (; i < NofAMmeth; i++) {
1387 const char *cooky = PL_AMG_names[i];
1388 /* Human-readable form, for debugging: */
1389 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1390 const STRLEN l = strlen(cooky);
1392 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1393 cp, HvNAME(stash)) );
1394 /* don't fill the cache while looking up!
1395 Creation of inheritance stubs in intermediate packages may
1396 conflict with the logic of runtime method substitution.
1397 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1398 then we could have created stubs for "(+0" in A and C too.
1399 But if B overloads "bool", we may want to use it for
1400 numifying instead of C's "+0". */
1401 if (i >= DESTROY_amg)
1402 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1403 else /* Autoload taken care of below */
1404 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1406 if (gv && (cv = GvCV(gv))) {
1407 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1408 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1409 /* This is a hack to support autoloading..., while
1410 knowing *which* methods were declared as overloaded. */
1411 /* GvSV contains the name of the method. */
1414 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1415 "' for overloaded `%s' in package `%.256s'\n",
1416 GvSV(gv), cp, HvNAME(stash)) );
1417 if (!SvPOK(GvSV(gv))
1418 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1421 /* Can be an import stub (created by `can'). */
1422 SV *gvsv = GvSV(gv);
1423 const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
1424 Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1425 "in package `%.256s'",
1426 (GvCVGEN(gv) ? "Stub found while resolving"
1428 name, cp, HvNAME(stash));
1430 cv = GvCV(gv = ngv);
1432 DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1433 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1434 GvNAME(CvGV(cv))) );
1436 if (i < DESTROY_amg)
1438 } else if (gv) { /* Autoloaded... */
1442 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1445 AMT_AMAGIC_on(&amt);
1447 AMT_OVERLOADED_on(&amt);
1448 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1449 (char*)&amt, sizeof(AMT));
1453 /* Here we have no table: */
1455 AMT_AMAGIC_off(&amt);
1456 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1457 (char*)&amt, sizeof(AMTS));
1463 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1468 if (!stash || !HvNAME(stash))
1470 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1474 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1476 amtp = (AMT*)mg->mg_ptr;
1477 if ( amtp->was_ok_am != PL_amagic_generation
1478 || amtp->was_ok_sub != PL_sub_generation )
1480 if (AMT_AMAGIC(amtp)) {
1481 CV * const ret = amtp->table[id];
1482 if (ret && isGV(ret)) { /* Autoloading stab */
1483 /* Passing it through may have resulted in a warning
1484 "Inherited AUTOLOAD for a non-method deprecated", since
1485 our caller is going through a function call, not a method call.
1486 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1487 GV *gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1500 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1505 CV **cvp=NULL, **ocvp=NULL;
1506 AMT *amtp=NULL, *oamtp=NULL;
1507 int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1508 int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1513 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1514 && (stash = SvSTASH(SvRV(left)))
1515 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1516 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1517 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1519 && ((cv = cvp[off=method+assignshift])
1520 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1526 cv = cvp[off=method])))) {
1527 lr = -1; /* Call method for left argument */
1529 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1532 /* look for substituted methods */
1533 /* In all the covered cases we should be called with assign==0. */
1537 if ((cv = cvp[off=add_ass_amg])
1538 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1539 right = &PL_sv_yes; lr = -1; assign = 1;
1544 if ((cv = cvp[off = subtr_ass_amg])
1545 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1546 right = &PL_sv_yes; lr = -1; assign = 1;
1550 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1553 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1556 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1559 (void)((cv = cvp[off=bool__amg])
1560 || (cv = cvp[off=numer_amg])
1561 || (cv = cvp[off=string_amg]));
1567 * SV* ref causes confusion with the interpreter variable of
1570 SV* tmpRef=SvRV(left);
1571 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1573 * Just to be extra cautious. Maybe in some
1574 * additional cases sv_setsv is safe, too.
1576 SV* newref = newSVsv(tmpRef);
1577 SvOBJECT_on(newref);
1578 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1584 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1585 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1586 SV* nullsv=sv_2mortal(newSViv(0));
1588 SV* lessp = amagic_call(left,nullsv,
1589 lt_amg,AMGf_noright);
1590 logic = SvTRUE(lessp);
1592 SV* lessp = amagic_call(left,nullsv,
1593 ncmp_amg,AMGf_noright);
1594 logic = (SvNV(lessp) < 0);
1597 if (off==subtr_amg) {
1608 if ((cv = cvp[off=subtr_amg])) {
1610 left = sv_2mortal(newSViv(0));
1615 case iter_amg: /* XXXX Eventually should do to_gv. */
1617 return NULL; /* Delegate operation to standard mechanisms. */
1625 return left; /* Delegate operation to standard mechanisms. */
1630 if (!cv) goto not_found;
1631 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1632 && (stash = SvSTASH(SvRV(right)))
1633 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1634 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1635 ? (amtp = (AMT*)mg->mg_ptr)->table
1637 && (cv = cvp[off=method])) { /* Method for right
1640 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1641 && (cvp=ocvp) && (lr = -1))
1642 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1643 && !(flags & AMGf_unary)) {
1644 /* We look for substitution for
1645 * comparison operations and
1647 if (method==concat_amg || method==concat_ass_amg
1648 || method==repeat_amg || method==repeat_ass_amg) {
1649 return NULL; /* Delegate operation to string conversion */
1659 postpr = 1; off=ncmp_amg; break;
1666 postpr = 1; off=scmp_amg; break;
1668 if (off != -1) cv = cvp[off];
1673 not_found: /* No method found, either report or croak */
1681 return left; /* Delegate operation to standard mechanisms. */
1684 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1685 notfound = 1; lr = -1;
1686 } else if (cvp && (cv=cvp[nomethod_amg])) {
1687 notfound = 1; lr = 1;
1690 if (off==-1) off=method;
1691 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1692 "Operation `%s': no method found,%sargument %s%s%s%s",
1693 AMG_id2name(method + assignshift),
1694 (flags & AMGf_unary ? " " : "\n\tleft "),
1696 "in overloaded package ":
1697 "has no overloaded magic",
1699 HvNAME(SvSTASH(SvRV(left))):
1702 ",\n\tright argument in overloaded package ":
1705 : ",\n\tright argument has no overloaded magic"),
1707 HvNAME(SvSTASH(SvRV(right))):
1709 if (amtp && amtp->fallback >= AMGfallYES) {
1710 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1712 Perl_croak(aTHX_ "%"SVf, msg);
1716 force_cpy = force_cpy || assign;
1721 DEBUG_o(Perl_deb(aTHX_
1722 "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1724 method+assignshift==off? "" :
1726 method+assignshift==off? "" :
1727 AMG_id2name(method+assignshift),
1728 method+assignshift==off? "" : "')",
1729 flags & AMGf_unary? "" :
1730 lr==1 ? " for right argument": " for left argument",
1731 flags & AMGf_unary? " for argument" : "",
1732 stash ? HvNAME(stash) : "null",
1733 fl? ",\n\tassignment variant used": "") );
1736 /* Since we use shallow copy during assignment, we need
1737 * to dublicate the contents, probably calling user-supplied
1738 * version of copy operator
1740 /* We need to copy in following cases:
1741 * a) Assignment form was called.
1742 * assignshift==1, assign==T, method + 1 == off
1743 * b) Increment or decrement, called directly.
1744 * assignshift==0, assign==0, method + 0 == off
1745 * c) Increment or decrement, translated to assignment add/subtr.
1746 * assignshift==0, assign==T,
1748 * d) Increment or decrement, translated to nomethod.
1749 * assignshift==0, assign==0,
1751 * e) Assignment form translated to nomethod.
1752 * assignshift==1, assign==T, method + 1 != off
1755 /* off is method, method+assignshift, or a result of opcode substitution.
1756 * In the latter case assignshift==0, so only notfound case is important.
1758 if (( (method + assignshift == off)
1759 && (assign || (method == inc_amg) || (method == dec_amg)))
1766 const bool oldcatch = CATCH_GET;
1769 Zero(&myop, 1, BINOP);
1770 myop.op_last = (OP *) &myop;
1771 myop.op_next = Nullop;
1772 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1774 PUSHSTACKi(PERLSI_OVERLOAD);
1777 PL_op = (OP *) &myop;
1778 if (PERLDB_SUB && PL_curstash != PL_debstash)
1779 PL_op->op_private |= OPpENTERSUB_DB;
1783 EXTEND(SP, notfound + 5);
1784 PUSHs(lr>0? right: left);
1785 PUSHs(lr>0? left: right);
1786 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1788 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1793 if ((PL_op = Perl_pp_entersub(aTHX)))
1801 CATCH_SET(oldcatch);
1808 ans=SvIV(res)<=0; break;
1811 ans=SvIV(res)<0; break;
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 SvSetSV(left,res); return left;
1828 ans=!SvTRUE(res); break;
1833 } else if (method==copy_amg) {
1835 Perl_croak(aTHX_ "Copy method did not return a reference");
1837 return SvREFCNT_inc(SvRV(res));
1845 =for apidoc is_gv_magical_sv
1847 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1853 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1856 const char *temp = SvPV(name, len);
1857 return is_gv_magical(temp, len, flags);
1861 =for apidoc is_gv_magical
1863 Returns C<TRUE> if given the name of a magical GV.
1865 Currently only useful internally when determining if a GV should be
1866 created even in rvalue contexts.
1868 C<flags> is not used at present but available for future extension to
1869 allow selecting particular classes of magical variable.
1871 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1872 This assumption is met by all callers within the perl core, which all pass
1873 pointers returned by SvPV.
1878 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1882 const char *name1 = name + 1;
1885 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1889 if (len == 8 && strEQ(name1, "VERLOAD"))
1893 if (len == 3 && name[1] == 'I' && name[2] == 'G')
1896 /* Using ${^...} variables is likely to be sufficiently rare that
1897 it seems sensible to avoid the space hit of also checking the
1899 case '\017': /* ${^OPEN} */
1900 if (strEQ(name1, "PEN"))
1903 case '\024': /* ${^TAINT} */
1904 if (strEQ(name1, "AINT"))
1907 case '\025': /* ${^UNICODE} */
1908 if (strEQ(name1, "NICODE"))
1910 if (strEQ(name1, "TF8LOCALE"))
1913 case '\027': /* ${^WARNING_BITS} */
1914 if (strEQ(name1, "ARNING_BITS"))
1927 const char *end = name + len;
1928 while (--end > name) {
1936 /* Because we're already assuming that name is NUL terminated
1937 below, we can treat an empty name as "\0" */
1964 case '\001': /* $^A */
1965 case '\003': /* $^C */
1966 case '\004': /* $^D */
1967 case '\005': /* $^E */
1968 case '\006': /* $^F */
1969 case '\010': /* $^H */
1970 case '\011': /* $^I, NOT \t in EBCDIC */
1971 case '\014': /* $^L */
1972 case '\016': /* $^N */
1973 case '\017': /* $^O */
1974 case '\020': /* $^P */
1975 case '\023': /* $^S */
1976 case '\024': /* $^T */
1977 case '\026': /* $^V */
1978 case '\027': /* $^W */
1999 * c-indentation-style: bsd
2001 * indent-tabs-mode: t
2004 * ex: set ts=8 sts=4 sw=4 noet: