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 #ifdef PERL_DONT_CREATE_GVSV
43 Perl_gv_SVadd(pTHX_ GV *gv)
45 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
46 Perl_croak(aTHX_ "Bad symbol for scalar");
48 GvSV(gv) = NEWSV(72,0);
54 Perl_gv_AVadd(pTHX_ register GV *gv)
56 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
57 Perl_croak(aTHX_ "Bad symbol for array");
64 Perl_gv_HVadd(pTHX_ register GV *gv)
66 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
67 Perl_croak(aTHX_ "Bad symbol for hash");
74 Perl_gv_IOadd(pTHX_ register GV *gv)
76 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
79 * if it walks like a dirhandle, then let's assume that
80 * this is a dirhandle.
82 const char *fh = PL_op->op_type == OP_READDIR ||
83 PL_op->op_type == OP_TELLDIR ||
84 PL_op->op_type == OP_SEEKDIR ||
85 PL_op->op_type == OP_REWINDDIR ||
86 PL_op->op_type == OP_CLOSEDIR ?
87 "dirhandle" : "filehandle";
88 Perl_croak(aTHX_ "Bad symbol for %s", fh);
92 #ifdef GV_UNIQUE_CHECK
94 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
103 Perl_gv_fetchfile(pTHX_ const char *name)
113 tmplen = strlen(name) + 2;
114 if (tmplen < sizeof smallbuf)
117 Newx(tmpbuf, tmplen + 1, char);
118 /* This is where the debugger's %{"::_<$filename"} hash is created */
121 memcpy(tmpbuf + 2, name, tmplen - 1);
122 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
124 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
125 #ifdef PERL_DONT_CREATE_GVSV
126 GvSV(gv) = newSVpvn(name, tmplen - 2);
128 sv_setpvn(GvSV(gv), name, tmplen - 2);
131 hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
133 if (tmpbuf != smallbuf)
139 =for apidoc gv_const_sv
141 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
142 inlining, or C<gv> is a placeholder reference that would be promoted to such
143 a typeglob, then returns the value returned by the sub. Otherwise, returns
150 Perl_gv_const_sv(pTHX_ GV *gv)
152 if (SvTYPE(gv) == SVt_PVGV)
153 return cv_const_sv(GvCVu(gv));
154 return SvROK(gv) ? SvRV(gv) : NULL;
158 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
162 const bool doproto = SvTYPE(gv) > SVt_NULL;
163 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
164 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
166 assert (!(proto && has_constant));
169 /* The constant has to be a simple scalar type. */
170 switch (SvTYPE(has_constant)) {
176 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
177 sv_reftype(has_constant, 0));
183 sv_upgrade((SV*)gv, SVt_PVGV);
190 Safefree(SvPVX_mutable(gv));
193 GvGP(gv) = gp_ref(gp);
194 #ifdef PERL_DONT_CREATE_GVSV
197 GvSV(gv) = NEWSV(72,0);
199 GvLINE(gv) = CopLINE(PL_curcop);
200 /* XXX Ideally this cast would be replaced with a change to const char*
202 GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
205 sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
208 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
209 GvNAME(gv) = savepvn(name, len);
211 if (multi || doproto) /* doproto means it _was_ mentioned */
213 if (doproto) { /* Replicate part of newSUB here. */
217 /* newCONSTSUB takes ownership of the reference from us. */
218 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
220 /* XXX unsafe for threads if eval_owner isn't held */
221 (void) start_subparse(0,0); /* Create empty CV in compcv. */
222 GvCV(gv) = PL_compcv;
228 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
229 CvSTASH(GvCV(gv)) = PL_curstash;
231 sv_setpv((SV*)GvCV(gv), proto);
238 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
250 #ifdef PERL_DONT_CREATE_GVSV
262 =for apidoc gv_fetchmeth
264 Returns the glob with the given C<name> and a defined subroutine or
265 C<NULL>. The glob lives in the given C<stash>, or in the stashes
266 accessible via @ISA and UNIVERSAL::.
268 The argument C<level> should be either 0 or -1. If C<level==0>, as a
269 side-effect creates a glob with the given C<name> in the given C<stash>
270 which in the case of success contains an alias for the subroutine, and sets
271 up caching info for this glob. Similarly for all the searched stashes.
273 This function grants C<"SUPER"> token as a postfix of the stash name. The
274 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
275 visible to Perl code. So when calling C<call_sv>, you should not use
276 the GV directly; instead, you should use the method's CV, which can be
277 obtained from the GV with the C<GvCV> macro.
283 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
292 /* UNIVERSAL methods should be callable without a stash */
294 level = -1; /* probably appropriate */
295 if(!(stash = gv_stashpvn(STR_WITH_LEN("UNIVERSAL"), FALSE)))
299 hvname = HvNAME_get(stash);
302 "Can't use anonymous symbol table for method lookup");
304 if ((level > 100) || (level < -100))
305 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
308 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
310 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
315 if (SvTYPE(topgv) != SVt_PVGV)
316 gv_init(topgv, stash, name, len, TRUE);
317 if ((cv = GvCV(topgv))) {
318 /* If genuine method or valid cache entry, use it */
319 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
321 /* Stale cached entry: junk it */
323 GvCV(topgv) = cv = Nullcv;
326 else if (GvCVGEN(topgv) == PL_sub_generation)
327 return 0; /* cache indicates sub doesn't exist */
330 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
331 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
333 /* create and re-create @.*::SUPER::ISA on demand */
334 if (!av || !SvMAGIC(av)) {
335 STRLEN packlen = HvNAMELEN_get(stash);
337 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
341 basestash = gv_stashpvn(hvname, packlen, TRUE);
342 gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
343 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
344 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
345 if (!gvp || !(gv = *gvp))
346 Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
347 if (SvTYPE(gv) != SVt_PVGV)
348 gv_init(gv, stash, "ISA", 3, TRUE);
349 SvREFCNT_dec(GvAV(gv));
350 GvAV(gv) = (AV*)SvREFCNT_inc(av);
356 SV** svp = AvARRAY(av);
357 /* NOTE: No support for tied ISA */
358 I32 items = AvFILLp(av) + 1;
360 SV* const sv = *svp++;
361 HV* const basestash = gv_stashsv(sv, FALSE);
363 if (ckWARN(WARN_MISC))
364 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
368 gv = gv_fetchmeth(basestash, name, len,
369 (level >= 0) ? level + 1 : level - 1);
375 /* if at top level, try UNIVERSAL */
377 if (level == 0 || level == -1) {
378 HV* const lastchance = gv_stashpvn(STR_WITH_LEN("UNIVERSAL"), FALSE);
381 if ((gv = gv_fetchmeth(lastchance, name, len,
382 (level >= 0) ? level + 1 : level - 1)))
386 * Cache method in topgv if:
387 * 1. topgv has no synonyms (else inheritance crosses wires)
388 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
391 GvREFCNT(topgv) == 1 &&
393 (CvROOT(cv) || CvXSUB(cv)))
395 if ((cv = GvCV(topgv)))
397 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
398 GvCVGEN(topgv) = PL_sub_generation;
402 else if (topgv && GvREFCNT(topgv) == 1) {
403 /* cache the fact that the method is not defined */
404 GvCVGEN(topgv) = PL_sub_generation;
413 =for apidoc gv_fetchmeth_autoload
415 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
416 Returns a glob for the subroutine.
418 For an autoloaded subroutine without a GV, will create a GV even
419 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
420 of the result may be zero.
426 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
428 GV *gv = gv_fetchmeth(stash, name, len, level);
435 return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
436 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
438 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
441 if (!(CvROOT(cv) || CvXSUB(cv)))
443 /* Have an autoload */
444 if (level < 0) /* Cannot do without a stub */
445 gv_fetchmeth(stash, name, len, 0);
446 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
455 =for apidoc gv_fetchmethod_autoload
457 Returns the glob which contains the subroutine to call to invoke the method
458 on the C<stash>. In fact in the presence of autoloading this may be the
459 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
462 The third parameter of C<gv_fetchmethod_autoload> determines whether
463 AUTOLOAD lookup is performed if the given method is not present: non-zero
464 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
465 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
466 with a non-zero C<autoload> parameter.
468 These functions grant C<"SUPER"> token as a prefix of the method name. Note
469 that if you want to keep the returned glob for a long time, you need to
470 check for it being "AUTOLOAD", since at the later time the call may load a
471 different subroutine due to $AUTOLOAD changing its value. Use the glob
472 created via a side effect to do this.
474 These functions have the same side-effects and as C<gv_fetchmeth> with
475 C<level==0>. C<name> should be writable if contains C<':'> or C<'
476 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
477 C<call_sv> apply equally to these functions.
483 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
485 register const char *nend;
486 const char *nsplit = NULL;
490 if (stash && SvTYPE(stash) < SVt_PVHV)
493 for (nend = name; *nend; nend++) {
496 else if (*nend == ':' && *(nend + 1) == ':')
500 const char * const origname = name;
504 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
505 /* ->SUPER::method should really be looked up in original stash */
506 SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
507 CopSTASHPV(PL_curcop)));
508 /* __PACKAGE__::SUPER stash should be autovivified */
509 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
510 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
511 origname, HvNAME_get(stash), name) );
514 /* don't autovifify if ->NoSuchStash::method */
515 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
517 /* however, explicit calls to Pkg::SUPER::method may
518 happen, and may require autovivification to work */
519 if (!stash && (nsplit - origname) >= 7 &&
520 strnEQ(nsplit - 7, "::SUPER", 7) &&
521 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
522 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
527 gv = gv_fetchmeth(stash, name, nend - name, 0);
529 if (strEQ(name,"import") || strEQ(name,"unimport"))
530 gv = (GV*)&PL_sv_yes;
532 gv = gv_autoload4(ostash, name, nend - name, TRUE);
535 CV* const cv = GvCV(gv);
536 if (!CvROOT(cv) && !CvXSUB(cv)) {
544 if (GvCV(stubgv) != cv) /* orphaned import */
547 autogv = gv_autoload4(GvSTASH(stubgv),
548 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
558 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
566 const char *packname = "";
569 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
572 if (SvTYPE(stash) < SVt_PVHV) {
573 packname = SvPV_const((SV*)stash, packname_len);
577 packname = HvNAME_get(stash);
578 packname_len = HvNAMELEN_get(stash);
581 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
585 if (!(CvROOT(cv) || CvXSUB(cv)))
589 * Inheriting AUTOLOAD for non-methods works ... for now.
591 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
592 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
594 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
595 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
596 packname, (int)len, name);
599 /* rather than lookup/init $AUTOLOAD here
600 * only to have the XSUB do another lookup for $AUTOLOAD
601 * and split that value on the last '::',
602 * pass along the same data via some unused fields in the CV
605 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
611 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
612 * The subroutine's original name may not be "AUTOLOAD", so we don't
613 * use that, but for lack of anything better we will use the sub's
614 * original package to look up $AUTOLOAD.
616 varstash = GvSTASH(CvGV(cv));
617 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
621 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
622 #ifdef PERL_DONT_CREATE_GVSV
623 GvSV(vargv) = NEWSV(72,0);
627 varsv = GvSVn(vargv);
628 sv_setpvn(varsv, packname, packname_len);
629 sv_catpvs(varsv, "::");
630 sv_catpvn(varsv, name, len);
631 SvTAINTED_off(varsv);
635 /* The "gv" parameter should be the glob known to Perl code as *!
636 * The scalar must already have been magicalized.
639 S_require_errno(pTHX_ GV *gv)
642 HV* stash = gv_stashpvn(STR_WITH_LEN("Errno"), FALSE);
644 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
648 save_scalar(gv); /* keep the value of $! */
649 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
650 newSVpvs("Errno"), Nullsv);
653 stash = gv_stashpvn(STR_WITH_LEN("Errno"), FALSE);
654 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
655 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
660 =for apidoc gv_stashpv
662 Returns a pointer to the stash for a specified package. C<name> should
663 be a valid UTF-8 string and must be null-terminated. If C<create> is set
664 then the package will be created if it does not already exist. If C<create>
665 is not set and the package does not exist then NULL is returned.
671 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
673 return gv_stashpvn(name, strlen(name), create);
677 =for apidoc gv_stashpvn
679 Returns a pointer to the stash for a specified package. C<name> should
680 be a valid UTF-8 string. The C<namelen> parameter indicates the length of
681 the C<name>, in bytes. If C<create> is set then the package will be
682 created if it does not already exist. If C<create> is not set and the
683 package does not exist then NULL is returned.
689 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
696 if (namelen + 3 < sizeof smallbuf)
699 Newx(tmpbuf, namelen + 3, char);
700 Copy(name,tmpbuf,namelen,char);
701 tmpbuf[namelen++] = ':';
702 tmpbuf[namelen++] = ':';
703 tmpbuf[namelen] = '\0';
704 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
705 if (tmpbuf != smallbuf)
710 GvHV(tmpgv) = newHV();
712 if (!HvNAME_get(stash))
713 hv_name_set(stash, name, namelen, 0);
718 =for apidoc gv_stashsv
720 Returns a pointer to the stash for a specified package, which must be a
721 valid UTF-8 string. See C<gv_stashpv>.
727 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
730 const char * const ptr = SvPV_const(sv,len);
731 return gv_stashpvn(ptr, len, create);
736 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
737 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
741 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
743 const char * const nambeg = SvPV_const(name, len);
744 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
748 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
751 register const char *name = nambeg;
752 register GV *gv = NULL;
755 register const char *namend;
757 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
758 const I32 no_expand = flags & GV_NOEXPAND;
759 const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND;
761 PERL_UNUSED_ARG(full_len);
763 if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
766 for (namend = name; *namend; namend++) {
767 if ((*namend == ':' && namend[1] == ':')
768 || (*namend == '\'' && namend[1]))
772 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
780 if (len + 3 < sizeof (smallbuf))
783 Newx(tmpbuf, len+3, char);
784 Copy(name, tmpbuf, len, char);
788 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
789 gv = gvp ? *gvp : Nullgv;
790 if (gv && gv != (GV*)&PL_sv_undef) {
791 if (SvTYPE(gv) != SVt_PVGV)
792 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
796 if (tmpbuf != smallbuf)
798 if (!gv || gv == (GV*)&PL_sv_undef)
801 if (!(stash = GvHV(gv)))
802 stash = GvHV(gv) = newHV();
804 if (!HvNAME_get(stash))
805 hv_name_set(stash, nambeg, namend - nambeg, 0);
813 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
818 /* No stash in name, so see how we can default */
821 if (isIDFIRST_lazy(name)) {
824 /* name is always \0 terminated, and initial \0 wouldn't return
825 true from isIDFIRST_lazy, so we know that name[1] is defined */
832 if (strEQ(name, "INC") || strEQ(name, "ENV"))
836 if (strEQ(name, "SIG"))
840 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
841 strEQ(name, "STDERR"))
845 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
852 else if (IN_PERL_COMPILETIME) {
854 if (add && (PL_hints & HINT_STRICT_VARS) &&
855 sv_type != SVt_PVCV &&
856 sv_type != SVt_PVGV &&
857 sv_type != SVt_PVFM &&
858 sv_type != SVt_PVIO &&
859 !(len == 1 && sv_type == SVt_PV &&
860 (*name == 'a' || *name == 'b')) )
862 gvp = (GV**)hv_fetch(stash,name,len,0);
864 *gvp == (GV*)&PL_sv_undef ||
865 SvTYPE(*gvp) != SVt_PVGV)
869 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
870 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
871 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
873 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
874 sv_type == SVt_PVAV ? '@' :
875 sv_type == SVt_PVHV ? '%' : '$',
878 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
884 stash = CopSTASH(PL_curcop);
890 /* By this point we should have a stash and a name */
894 SV * const err = Perl_mess(aTHX_
895 "Global symbol \"%s%s\" requires explicit package name",
896 (sv_type == SVt_PV ? "$"
897 : sv_type == SVt_PVAV ? "@"
898 : sv_type == SVt_PVHV ? "%"
900 if (USE_UTF8_IN_NAMES)
903 stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
909 if (!SvREFCNT(stash)) /* symbol table under destruction */
912 gvp = (GV**)hv_fetch(stash,name,len,add);
913 if (!gvp || *gvp == (GV*)&PL_sv_undef)
916 if (SvTYPE(gv) == SVt_PVGV) {
919 gv_init_sv(gv, sv_type);
920 if (*name=='!' && sv_type == SVt_PVHV && len==1)
924 } else if (no_init) {
926 } else if (no_expand && SvROK(gv)) {
930 /* Adding a new symbol */
932 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
933 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
934 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
935 gv_init_sv(gv, sv_type);
937 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
938 : (PL_dowarn & G_WARN_ON ) ) )
941 /* set up magic where warranted */
945 /* Nothing else to do.
946 The compiler will probably turn the switch statement into a
947 branch table. Make sure we avoid even that small overhead for
948 the common case of lower case variable names. */
952 const char * const name2 = name + 1;
955 if (strEQ(name2, "RGV")) {
956 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
960 if (strnEQ(name2, "XPORT", 5))
964 if (strEQ(name2, "SA")) {
965 AV* const av = GvAVn(gv);
967 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
968 /* NOTE: No support for tied ISA */
969 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
970 && AvFILLp(av) == -1)
973 av_push(av, newSVpvn(pname = "NDBM_File",9));
974 gv_stashpvn(pname, 9, TRUE);
975 av_push(av, newSVpvn(pname = "DB_File",7));
976 gv_stashpvn(pname, 7, TRUE);
977 av_push(av, newSVpvn(pname = "GDBM_File",9));
978 gv_stashpvn(pname, 9, TRUE);
979 av_push(av, newSVpvn(pname = "SDBM_File",9));
980 gv_stashpvn(pname, 9, TRUE);
981 av_push(av, newSVpvn(pname = "ODBM_File",9));
982 gv_stashpvn(pname, 9, TRUE);
987 if (strEQ(name2, "VERLOAD")) {
988 HV* const hv = GvHVn(gv);
990 hv_magic(hv, Nullgv, PERL_MAGIC_overload);
994 if (strEQ(name2, "IG")) {
998 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
999 Newxz(PL_psig_name, SIG_SIZE, SV*);
1000 Newxz(PL_psig_pend, SIG_SIZE, int);
1004 hv_magic(hv, Nullgv, PERL_MAGIC_sig);
1005 for (i = 1; i < SIG_SIZE; i++) {
1006 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1008 sv_setsv(*init, &PL_sv_undef);
1010 PL_psig_name[i] = 0;
1011 PL_psig_pend[i] = 0;
1016 if (strEQ(name2, "ERSION"))
1019 case '\003': /* $^CHILD_ERROR_NATIVE */
1020 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1023 case '\005': /* $^ENCODING */
1024 if (strEQ(name2, "NCODING"))
1027 case '\017': /* $^OPEN */
1028 if (strEQ(name2, "PEN"))
1031 case '\024': /* ${^TAINT} */
1032 if (strEQ(name2, "AINT"))
1035 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1036 if (strEQ(name2, "NICODE"))
1038 if (strEQ(name2, "TF8LOCALE"))
1041 case '\027': /* $^WARNING_BITS */
1042 if (strEQ(name2, "ARNING_BITS"))
1055 /* ensures variable is only digits */
1056 /* ${"1foo"} fails this test (and is thus writeable) */
1057 /* added by japhy, but borrowed from is_gv_magical */
1058 const char *end = name + len;
1059 while (--end > name) {
1060 if (!isDIGIT(*end)) return gv;
1067 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1068 be case '\0' in this switch statement (ie a default case) */
1074 sv_type == SVt_PVAV ||
1075 sv_type == SVt_PVHV ||
1076 sv_type == SVt_PVCV ||
1077 sv_type == SVt_PVFM ||
1080 PL_sawampersand = TRUE;
1084 sv_setpv(GvSVn(gv),PL_chopset);
1088 #ifdef COMPLEX_STATUS
1089 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1095 /* If %! has been used, automatically load Errno.pm.
1096 The require will itself set errno, so in order to
1097 preserve its value we have to set up the magic
1098 now (rather than going to magicalize)
1101 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1103 if (sv_type == SVt_PVHV)
1109 AV* const av = GvAVn(gv);
1110 sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1116 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1117 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1118 "$%c is no longer supported", *name);
1121 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1126 AV* const av = GvAVn(gv);
1127 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1131 case '\023': /* $^S */
1142 SvREADONLY_on(GvSVn(gv));
1157 case '\001': /* $^A */
1158 case '\003': /* $^C */
1159 case '\004': /* $^D */
1160 case '\005': /* $^E */
1161 case '\006': /* $^F */
1162 case '\010': /* $^H */
1163 case '\011': /* $^I, NOT \t in EBCDIC */
1164 case '\016': /* $^N */
1165 case '\017': /* $^O */
1166 case '\020': /* $^P */
1167 case '\024': /* $^T */
1168 case '\027': /* $^W */
1170 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1173 case '\014': /* $^L */
1174 sv_setpvn(GvSVn(gv),"\f",1);
1175 PL_formfeed = GvSVn(gv);
1178 sv_setpvn(GvSVn(gv),"\034",1);
1182 SV * const sv = GvSVn(gv);
1183 if (!sv_derived_from(PL_patchlevel, "version"))
1184 upg_version(PL_patchlevel);
1185 GvSV(gv) = vnumify(PL_patchlevel);
1186 SvREADONLY_on(GvSV(gv));
1190 case '\026': /* $^V */
1192 SV * const sv = GvSVn(gv);
1193 GvSV(gv) = new_version(PL_patchlevel);
1194 SvREADONLY_on(GvSV(gv));
1204 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1208 const HV * const hv = GvSTASH(gv);
1213 sv_setpv(sv, prefix ? prefix : "");
1215 name = HvNAME_get(hv);
1217 namelen = HvNAMELEN_get(hv);
1223 if (keepmain || strNE(name, "main")) {
1224 sv_catpvn(sv,name,namelen);
1227 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1231 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1233 const GV * const egv = GvEGV(gv);
1234 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1241 IO * const io = (IO*)NEWSV(0,0);
1243 sv_upgrade((SV *)io,SVt_PVIO);
1244 /* This used to read SvREFCNT(io) = 1;
1245 It's not clear why the reference count needed an explicit reset. NWC
1247 assert (SvREFCNT(io) == 1);
1249 /* Clear the stashcache because a new IO could overrule a package name */
1250 hv_clear(PL_stashcache);
1251 iogv = gv_fetchpvn_flags("FileHandle::", 12, 0, SVt_PVHV);
1252 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1253 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1254 iogv = gv_fetchpvn_flags("IO::Handle::", 12, TRUE, SVt_PVHV);
1255 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1260 Perl_gv_check(pTHX_ HV *stash)
1264 if (!HvARRAY(stash))
1266 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1268 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1271 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1272 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1274 if (hv != PL_defstash && hv != stash)
1275 gv_check(hv); /* nested package */
1277 else if (isALPHA(*HeKEY(entry))) {
1279 gv = (GV*)HeVAL(entry);
1280 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1283 /* performance hack: if filename is absolute and it's a standard
1284 * module, don't bother warning */
1285 #ifdef MACOS_TRADITIONAL
1286 # define LIB_COMPONENT ":lib:"
1288 # define LIB_COMPONENT "/lib/"
1291 && PERL_FILE_IS_ABSOLUTE(file)
1292 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1296 CopLINE_set(PL_curcop, GvLINE(gv));
1298 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1300 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1302 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1303 "Name \"%s::%s\" used only once: possible typo",
1304 HvNAME_get(stash), GvNAME(gv));
1311 Perl_newGVgen(pTHX_ const char *pack)
1313 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1317 /* hopefully this is only called on local symbol table entries */
1320 Perl_gp_ref(pTHX_ GP *gp)
1327 /* multi-named GPs cannot be used for method cache */
1328 SvREFCNT_dec(gp->gp_cv);
1333 /* Adding a new name to a subroutine invalidates method cache */
1334 PL_sub_generation++;
1341 Perl_gp_free(pTHX_ GV *gv)
1345 if (!gv || !(gp = GvGP(gv)))
1347 if (gp->gp_refcnt == 0) {
1348 if (ckWARN_d(WARN_INTERNAL))
1349 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1350 "Attempt to free unreferenced glob pointers"
1351 pTHX__FORMAT pTHX__VALUE);
1355 /* Deleting the name of a subroutine invalidates method cache */
1356 PL_sub_generation++;
1358 if (--gp->gp_refcnt > 0) {
1359 if (gp->gp_egv == gv)
1364 if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1365 if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1366 /* FIXME - another reference loop GV -> symtab -> GV ?
1367 Somehow gp->gp_hv can end up pointing at freed garbage. */
1368 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1369 const char *hvname = HvNAME_get(gp->gp_hv);
1370 if (PL_stashcache && hvname)
1371 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1373 SvREFCNT_dec(gp->gp_hv);
1375 if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
1376 if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
1377 if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1384 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1386 AMT * const amtp = (AMT*)mg->mg_ptr;
1387 PERL_UNUSED_ARG(sv);
1389 if (amtp && AMT_AMAGIC(amtp)) {
1391 for (i = 1; i < NofAMmeth; i++) {
1392 CV * const cv = amtp->table[i];
1394 SvREFCNT_dec((SV *) cv);
1395 amtp->table[i] = Nullcv;
1402 /* Updates and caches the CV's */
1405 Perl_Gv_AMupdate(pTHX_ HV *stash)
1407 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1408 AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1411 if (mg && amtp->was_ok_am == PL_amagic_generation
1412 && amtp->was_ok_sub == PL_sub_generation)
1413 return (bool)AMT_OVERLOADED(amtp);
1414 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1416 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1419 amt.was_ok_am = PL_amagic_generation;
1420 amt.was_ok_sub = PL_sub_generation;
1421 amt.fallback = AMGfallNO;
1425 int filled = 0, have_ovl = 0;
1428 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1430 /* Try to find via inheritance. */
1431 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1432 SV * const sv = gv ? GvSV(gv) : NULL;
1436 lim = DESTROY_amg; /* Skip overloading entries. */
1437 #ifdef PERL_DONT_CREATE_GVSV
1439 /* Equivalent to !SvTRUE and !SvOK */
1442 else if (SvTRUE(sv))
1443 amt.fallback=AMGfallYES;
1445 amt.fallback=AMGfallNEVER;
1447 for (i = 1; i < lim; i++)
1448 amt.table[i] = Nullcv;
1449 for (; i < NofAMmeth; i++) {
1450 const char *cooky = PL_AMG_names[i];
1451 /* Human-readable form, for debugging: */
1452 const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1453 const STRLEN l = strlen(cooky);
1455 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1456 cp, HvNAME_get(stash)) );
1457 /* don't fill the cache while looking up!
1458 Creation of inheritance stubs in intermediate packages may
1459 conflict with the logic of runtime method substitution.
1460 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1461 then we could have created stubs for "(+0" in A and C too.
1462 But if B overloads "bool", we may want to use it for
1463 numifying instead of C's "+0". */
1464 if (i >= DESTROY_amg)
1465 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1466 else /* Autoload taken care of below */
1467 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1469 if (gv && (cv = GvCV(gv))) {
1471 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1472 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1473 /* This is a hack to support autoloading..., while
1474 knowing *which* methods were declared as overloaded. */
1475 /* GvSV contains the name of the method. */
1477 SV *gvsv = GvSV(gv);
1479 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1480 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1481 GvSV(gv), cp, hvname) );
1482 if (!gvsv || !SvPOK(gvsv)
1483 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1486 /* Can be an import stub (created by "can"). */
1487 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1488 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1489 "in package \"%.256s\"",
1490 (GvCVGEN(gv) ? "Stub found while resolving"
1494 cv = GvCV(gv = ngv);
1496 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1497 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1498 GvNAME(CvGV(cv))) );
1500 if (i < DESTROY_amg)
1502 } else if (gv) { /* Autoloaded... */
1506 amt.table[i]=(CV*)SvREFCNT_inc(cv);
1509 AMT_AMAGIC_on(&amt);
1511 AMT_OVERLOADED_on(&amt);
1512 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1513 (char*)&amt, sizeof(AMT));
1517 /* Here we have no table: */
1519 AMT_AMAGIC_off(&amt);
1520 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1521 (char*)&amt, sizeof(AMTS));
1527 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1532 if (!stash || !HvNAME_get(stash))
1534 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1538 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1540 amtp = (AMT*)mg->mg_ptr;
1541 if ( amtp->was_ok_am != PL_amagic_generation
1542 || amtp->was_ok_sub != PL_sub_generation )
1544 if (AMT_AMAGIC(amtp)) {
1545 CV * const ret = amtp->table[id];
1546 if (ret && isGV(ret)) { /* Autoloading stab */
1547 /* Passing it through may have resulted in a warning
1548 "Inherited AUTOLOAD for a non-method deprecated", since
1549 our caller is going through a function call, not a method call.
1550 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1551 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1564 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1569 CV **cvp=NULL, **ocvp=NULL;
1570 AMT *amtp=NULL, *oamtp=NULL;
1571 int off = 0, off1, lr = 0, notfound = 0;
1572 int postpr = 0, force_cpy = 0;
1573 int assign = AMGf_assign & flags;
1574 const int assignshift = assign ? 1 : 0;
1579 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1580 && (stash = SvSTASH(SvRV(left)))
1581 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1582 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1583 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1585 && ((cv = cvp[off=method+assignshift])
1586 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1592 cv = cvp[off=method])))) {
1593 lr = -1; /* Call method for left argument */
1595 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1598 /* look for substituted methods */
1599 /* In all the covered cases we should be called with assign==0. */
1603 if ((cv = cvp[off=add_ass_amg])
1604 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1605 right = &PL_sv_yes; lr = -1; assign = 1;
1610 if ((cv = cvp[off = subtr_ass_amg])
1611 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1612 right = &PL_sv_yes; lr = -1; assign = 1;
1616 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1619 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1622 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1625 (void)((cv = cvp[off=bool__amg])
1626 || (cv = cvp[off=numer_amg])
1627 || (cv = cvp[off=string_amg]));
1633 * SV* ref causes confusion with the interpreter variable of
1636 SV* const tmpRef=SvRV(left);
1637 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1639 * Just to be extra cautious. Maybe in some
1640 * additional cases sv_setsv is safe, too.
1642 SV* const newref = newSVsv(tmpRef);
1643 SvOBJECT_on(newref);
1644 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1650 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1651 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1652 SV* const nullsv=sv_2mortal(newSViv(0));
1654 SV* const lessp = amagic_call(left,nullsv,
1655 lt_amg,AMGf_noright);
1656 logic = SvTRUE(lessp);
1658 SV* const lessp = amagic_call(left,nullsv,
1659 ncmp_amg,AMGf_noright);
1660 logic = (SvNV(lessp) < 0);
1663 if (off==subtr_amg) {
1674 if ((cv = cvp[off=subtr_amg])) {
1676 left = sv_2mortal(newSViv(0));
1681 case iter_amg: /* XXXX Eventually should do to_gv. */
1683 return NULL; /* Delegate operation to standard mechanisms. */
1691 return left; /* Delegate operation to standard mechanisms. */
1696 if (!cv) goto not_found;
1697 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1698 && (stash = SvSTASH(SvRV(right)))
1699 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1700 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1701 ? (amtp = (AMT*)mg->mg_ptr)->table
1703 && (cv = cvp[off=method])) { /* Method for right
1706 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1707 && (cvp=ocvp) && (lr = -1))
1708 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1709 && !(flags & AMGf_unary)) {
1710 /* We look for substitution for
1711 * comparison operations and
1713 if (method==concat_amg || method==concat_ass_amg
1714 || method==repeat_amg || method==repeat_ass_amg) {
1715 return NULL; /* Delegate operation to string conversion */
1725 postpr = 1; off=ncmp_amg; break;
1732 postpr = 1; off=scmp_amg; break;
1734 if (off != -1) cv = cvp[off];
1739 not_found: /* No method found, either report or croak */
1747 return left; /* Delegate operation to standard mechanisms. */
1750 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1751 notfound = 1; lr = -1;
1752 } else if (cvp && (cv=cvp[nomethod_amg])) {
1753 notfound = 1; lr = 1;
1756 if (off==-1) off=method;
1757 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1758 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1759 AMG_id2name(method + assignshift),
1760 (flags & AMGf_unary ? " " : "\n\tleft "),
1762 "in overloaded package ":
1763 "has no overloaded magic",
1765 HvNAME_get(SvSTASH(SvRV(left))):
1768 ",\n\tright argument in overloaded package ":
1771 : ",\n\tright argument has no overloaded magic"),
1773 HvNAME_get(SvSTASH(SvRV(right))):
1775 if (amtp && amtp->fallback >= AMGfallYES) {
1776 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1778 Perl_croak(aTHX_ "%"SVf, msg);
1782 force_cpy = force_cpy || assign;
1787 DEBUG_o(Perl_deb(aTHX_
1788 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1790 method+assignshift==off? "" :
1792 method+assignshift==off? "" :
1793 AMG_id2name(method+assignshift),
1794 method+assignshift==off? "" : "\")",
1795 flags & AMGf_unary? "" :
1796 lr==1 ? " for right argument": " for left argument",
1797 flags & AMGf_unary? " for argument" : "",
1798 stash ? HvNAME_get(stash) : "null",
1799 fl? ",\n\tassignment variant used": "") );
1802 /* Since we use shallow copy during assignment, we need
1803 * to dublicate the contents, probably calling user-supplied
1804 * version of copy operator
1806 /* We need to copy in following cases:
1807 * a) Assignment form was called.
1808 * assignshift==1, assign==T, method + 1 == off
1809 * b) Increment or decrement, called directly.
1810 * assignshift==0, assign==0, method + 0 == off
1811 * c) Increment or decrement, translated to assignment add/subtr.
1812 * assignshift==0, assign==T,
1814 * d) Increment or decrement, translated to nomethod.
1815 * assignshift==0, assign==0,
1817 * e) Assignment form translated to nomethod.
1818 * assignshift==1, assign==T, method + 1 != off
1821 /* off is method, method+assignshift, or a result of opcode substitution.
1822 * In the latter case assignshift==0, so only notfound case is important.
1824 if (( (method + assignshift == off)
1825 && (assign || (method == inc_amg) || (method == dec_amg)))
1832 const bool oldcatch = CATCH_GET;
1835 Zero(&myop, 1, BINOP);
1836 myop.op_last = (OP *) &myop;
1837 myop.op_next = Nullop;
1838 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1840 PUSHSTACKi(PERLSI_OVERLOAD);
1843 PL_op = (OP *) &myop;
1844 if (PERLDB_SUB && PL_curstash != PL_debstash)
1845 PL_op->op_private |= OPpENTERSUB_DB;
1849 EXTEND(SP, notfound + 5);
1850 PUSHs(lr>0? right: left);
1851 PUSHs(lr>0? left: right);
1852 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1854 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1859 if ((PL_op = Perl_pp_entersub(aTHX)))
1867 CATCH_SET(oldcatch);
1874 ans=SvIV(res)<=0; break;
1877 ans=SvIV(res)<0; break;
1880 ans=SvIV(res)>=0; break;
1883 ans=SvIV(res)>0; break;
1886 ans=SvIV(res)==0; break;
1889 ans=SvIV(res)!=0; break;
1892 SvSetSV(left,res); return left;
1894 ans=!SvTRUE(res); break;
1899 } else if (method==copy_amg) {
1901 Perl_croak(aTHX_ "Copy method did not return a reference");
1903 return SvREFCNT_inc(SvRV(res));
1911 =for apidoc is_gv_magical_sv
1913 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1919 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1922 const char * const temp = SvPV_const(name, len);
1923 return is_gv_magical(temp, len, flags);
1927 =for apidoc is_gv_magical
1929 Returns C<TRUE> if given the name of a magical GV.
1931 Currently only useful internally when determining if a GV should be
1932 created even in rvalue contexts.
1934 C<flags> is not used at present but available for future extension to
1935 allow selecting particular classes of magical variable.
1937 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1938 This assumption is met by all callers within the perl core, which all pass
1939 pointers returned by SvPV.
1944 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1946 PERL_UNUSED_ARG(flags);
1949 const char * const name1 = name + 1;
1952 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1956 if (len == 8 && strEQ(name1, "VERLOAD"))
1960 if (len == 3 && name[1] == 'I' && name[2] == 'G')
1963 /* Using ${^...} variables is likely to be sufficiently rare that
1964 it seems sensible to avoid the space hit of also checking the
1966 case '\017': /* ${^OPEN} */
1967 if (strEQ(name1, "PEN"))
1970 case '\024': /* ${^TAINT} */
1971 if (strEQ(name1, "AINT"))
1974 case '\025': /* ${^UNICODE} */
1975 if (strEQ(name1, "NICODE"))
1977 if (strEQ(name1, "TF8LOCALE"))
1980 case '\027': /* ${^WARNING_BITS} */
1981 if (strEQ(name1, "ARNING_BITS"))
1994 const char *end = name + len;
1995 while (--end > name) {
2003 /* Because we're already assuming that name is NUL terminated
2004 below, we can treat an empty name as "\0" */
2031 case '\001': /* $^A */
2032 case '\003': /* $^C */
2033 case '\004': /* $^D */
2034 case '\005': /* $^E */
2035 case '\006': /* $^F */
2036 case '\010': /* $^H */
2037 case '\011': /* $^I, NOT \t in EBCDIC */
2038 case '\014': /* $^L */
2039 case '\016': /* $^N */
2040 case '\017': /* $^O */
2041 case '\020': /* $^P */
2042 case '\023': /* $^S */
2043 case '\024': /* $^T */
2044 case '\026': /* $^V */
2045 case '\027': /* $^W */
2066 * c-indentation-style: bsd
2068 * indent-tabs-mode: t
2071 * ex: set ts=8 sts=4 sw=4 noet: