3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
13 * of your inquisitiveness, I shall spend all the rest of my days answering
14 * you. What more do you want to know?'
15 * 'The names of all the stars, and of all living things, and the whole
16 * history of Middle-earth and Over-heaven and of the Sundering Seas,'
23 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
24 It is a structure that holds a pointer to a scalar, an array, a hash etc,
25 corresponding to $foo, @foo, %foo.
27 GVs are usually found as values in stashes (symbol table hashes) where
28 Perl stores its global variables.
37 static const char S_autoload[] = "AUTOLOAD";
38 static const STRLEN S_autolen = sizeof(S_autoload)-1;
41 #ifdef PERL_DONT_CREATE_GVSV
43 Perl_gv_SVadd(pTHX_ GV *gv)
45 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
46 Perl_croak(aTHX_ "Bad symbol for scalar");
54 Perl_gv_AVadd(pTHX_ register GV *gv)
56 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
57 Perl_croak(aTHX_ "Bad symbol for array");
64 Perl_gv_HVadd(pTHX_ register GV *gv)
66 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
67 Perl_croak(aTHX_ "Bad symbol for hash");
74 Perl_gv_IOadd(pTHX_ register GV *gv)
77 if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
80 * if it walks like a dirhandle, then let's assume that
81 * this is a dirhandle.
83 const char * const fh =
84 PL_op->op_type == OP_READDIR ||
85 PL_op->op_type == OP_TELLDIR ||
86 PL_op->op_type == OP_SEEKDIR ||
87 PL_op->op_type == OP_REWINDDIR ||
88 PL_op->op_type == OP_CLOSEDIR ?
89 "dirhandle" : "filehandle";
90 Perl_croak(aTHX_ "Bad symbol for %s", fh);
94 #ifdef GV_UNIQUE_CHECK
96 Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
105 Perl_gv_fetchfile(pTHX_ const char *name)
116 tmplen = strlen(name) + 2;
117 if (tmplen < sizeof smallbuf)
120 Newx(tmpbuf, tmplen + 1, char);
121 /* This is where the debugger's %{"::_<$filename"} hash is created */
124 memcpy(tmpbuf + 2, name, tmplen - 1);
125 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
127 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
128 #ifdef PERL_DONT_CREATE_GVSV
129 GvSV(gv) = newSVpvn(name, tmplen - 2);
131 sv_setpvn(GvSV(gv), name, tmplen - 2);
134 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
136 if (tmpbuf != smallbuf)
142 =for apidoc gv_const_sv
144 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
145 inlining, or C<gv> is a placeholder reference that would be promoted to such
146 a typeglob, then returns the value returned by the sub. Otherwise, returns
153 Perl_gv_const_sv(pTHX_ GV *gv)
155 if (SvTYPE(gv) == SVt_PVGV)
156 return cv_const_sv(GvCVu(gv));
157 return SvROK(gv) ? SvRV(gv) : NULL;
161 Perl_newGP(pTHX_ GV *const gv)
164 const char *const file = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
165 STRLEN len = strlen(file);
168 PERL_HASH(hash, file, len);
172 #ifndef PERL_DONT_CREATE_GVSV
173 gp->gv_sv = newSV(0);
176 gp->gp_line = CopLINE(PL_curcop);
177 /* XXX Ideally this cast would be replaced with a change to const char*
179 gp->gp_file_hek = share_hek(file, len, hash);
187 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
190 const U32 old_type = SvTYPE(gv);
191 const bool doproto = old_type > SVt_NULL;
192 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
193 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
195 assert (!(proto && has_constant));
198 /* The constant has to be a simple scalar type. */
199 switch (SvTYPE(has_constant)) {
205 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
206 sv_reftype(has_constant, 0));
214 if (old_type < SVt_PVGV) {
215 if (old_type >= SVt_PV)
217 sv_upgrade((SV*)gv, SVt_PVGV);
225 Safefree(SvPVX_mutable(gv));
229 GvGP(gv) = Perl_newGP(aTHX_ gv);
232 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
233 gv_name_set(gv, name, len, GV_ADD);
234 if (multi || doproto) /* doproto means it _was_ mentioned */
236 if (doproto) { /* Replicate part of newSUB here. */
240 /* newCONSTSUB takes ownership of the reference from us. */
241 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
243 /* XXX unsafe for threads if eval_owner isn't held */
244 (void) start_subparse(0,0); /* Create empty CV in compcv. */
245 GvCV(gv) = PL_compcv;
251 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
252 CvSTASH(GvCV(gv)) = PL_curstash;
254 sv_setpv((SV*)GvCV(gv), proto);
261 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
273 #ifdef PERL_DONT_CREATE_GVSV
286 =for apidoc gv_fetchmeth
288 Returns the glob with the given C<name> and a defined subroutine or
289 C<NULL>. The glob lives in the given C<stash>, or in the stashes
290 accessible via @ISA and UNIVERSAL::.
292 The argument C<level> should be either 0 or -1. If C<level==0>, as a
293 side-effect creates a glob with the given C<name> in the given C<stash>
294 which in the case of success contains an alias for the subroutine, and sets
295 up caching info for this glob. Similarly for all the searched stashes.
297 This function grants C<"SUPER"> token as a postfix of the stash name. The
298 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
299 visible to Perl code. So when calling C<call_sv>, you should not use
300 the GV directly; instead, you should use the method's CV, which can be
301 obtained from the GV with the C<GvCV> macro.
307 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
316 HV* lastchance = NULL;
318 /* UNIVERSAL methods should be callable without a stash */
320 level = -1; /* probably appropriate */
321 if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
325 hvname = HvNAME_get(stash);
328 "Can't use anonymous symbol table for method lookup");
330 if ((level > 100) || (level < -100))
331 Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
334 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
336 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
341 if (SvTYPE(topgv) != SVt_PVGV)
342 gv_init(topgv, stash, name, len, TRUE);
343 if ((cv = GvCV(topgv))) {
344 /* If genuine method or valid cache entry, use it */
345 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
347 /* Stale cached entry: junk it */
349 GvCV(topgv) = cv = NULL;
352 else if (GvCVGEN(topgv) == PL_sub_generation)
353 return 0; /* cache indicates sub doesn't exist */
356 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
357 av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
359 /* create and re-create @.*::SUPER::ISA on demand */
360 if (!av || !SvMAGIC(av)) {
361 STRLEN packlen = HvNAMELEN_get(stash);
363 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
367 basestash = gv_stashpvn(hvname, packlen, TRUE);
368 gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
369 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
370 gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
371 if (!gvp || !(gv = *gvp))
372 Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
373 if (SvTYPE(gv) != SVt_PVGV)
374 gv_init(gv, stash, "ISA", 3, TRUE);
375 SvREFCNT_dec(GvAV(gv));
376 GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
382 SV** svp = AvARRAY(av);
383 /* NOTE: No support for tied ISA */
384 I32 items = AvFILLp(av) + 1;
386 SV* const sv = *svp++;
387 HV* const basestash = gv_stashsv(sv, FALSE);
389 if (ckWARN(WARN_MISC))
390 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
394 gv = gv_fetchmeth(basestash, name, len,
395 (level >= 0) ? level + 1 : level - 1);
401 /* if at top level, try UNIVERSAL */
403 if (level == 0 || level == -1) {
404 lastchance = gv_stashpvs("UNIVERSAL", FALSE);
407 if ((gv = gv_fetchmeth(lastchance, name, len,
408 (level >= 0) ? level + 1 : level - 1)))
412 * Cache method in topgv if:
413 * 1. topgv has no synonyms (else inheritance crosses wires)
414 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
417 GvREFCNT(topgv) == 1 &&
419 (CvROOT(cv) || CvXSUB(cv)))
421 if ((cv = GvCV(topgv)))
423 GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
424 GvCVGEN(topgv) = PL_sub_generation;
428 else if (topgv && GvREFCNT(topgv) == 1) {
429 /* cache the fact that the method is not defined */
430 GvCVGEN(topgv) = PL_sub_generation;
439 =for apidoc gv_fetchmeth_autoload
441 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
442 Returns a glob for the subroutine.
444 For an autoloaded subroutine without a GV, will create a GV even
445 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
446 of the result may be zero.
452 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
454 GV *gv = gv_fetchmeth(stash, name, len, level);
461 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
462 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
464 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
467 if (!(CvROOT(cv) || CvXSUB(cv)))
469 /* Have an autoload */
470 if (level < 0) /* Cannot do without a stub */
471 gv_fetchmeth(stash, name, len, 0);
472 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
481 =for apidoc gv_fetchmethod_autoload
483 Returns the glob which contains the subroutine to call to invoke the method
484 on the C<stash>. In fact in the presence of autoloading this may be the
485 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
488 The third parameter of C<gv_fetchmethod_autoload> determines whether
489 AUTOLOAD lookup is performed if the given method is not present: non-zero
490 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
491 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
492 with a non-zero C<autoload> parameter.
494 These functions grant C<"SUPER"> token as a prefix of the method name. Note
495 that if you want to keep the returned glob for a long time, you need to
496 check for it being "AUTOLOAD", since at the later time the call may load a
497 different subroutine due to $AUTOLOAD changing its value. Use the glob
498 created via a side effect to do this.
500 These functions have the same side-effects and as C<gv_fetchmeth> with
501 C<level==0>. C<name> should be writable if contains C<':'> or C<'
502 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
503 C<call_sv> apply equally to these functions.
509 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
512 register const char *nend;
513 const char *nsplit = NULL;
517 if (stash && SvTYPE(stash) < SVt_PVHV)
520 for (nend = name; *nend; nend++) {
523 else if (*nend == ':' && *(nend + 1) == ':')
527 const char * const origname = name;
531 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
532 /* ->SUPER::method should really be looked up in original stash */
533 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
534 CopSTASHPV(PL_curcop)));
535 /* __PACKAGE__::SUPER stash should be autovivified */
536 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
537 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
538 origname, HvNAME_get(stash), name) );
541 /* don't autovifify if ->NoSuchStash::method */
542 stash = gv_stashpvn(origname, nsplit - origname, FALSE);
544 /* however, explicit calls to Pkg::SUPER::method may
545 happen, and may require autovivification to work */
546 if (!stash && (nsplit - origname) >= 7 &&
547 strnEQ(nsplit - 7, "::SUPER", 7) &&
548 gv_stashpvn(origname, nsplit - origname - 7, FALSE))
549 stash = gv_stashpvn(origname, nsplit - origname, TRUE);
554 gv = gv_fetchmeth(stash, name, nend - name, 0);
556 if (strEQ(name,"import") || strEQ(name,"unimport"))
557 gv = (GV*)&PL_sv_yes;
559 gv = gv_autoload4(ostash, name, nend - name, TRUE);
562 CV* const cv = GvCV(gv);
563 if (!CvROOT(cv) && !CvXSUB(cv)) {
571 if (GvCV(stubgv) != cv) /* orphaned import */
574 autogv = gv_autoload4(GvSTASH(stubgv),
575 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
585 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
593 const char *packname = "";
594 STRLEN packname_len = 0;
596 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
599 if (SvTYPE(stash) < SVt_PVHV) {
600 packname = SvPV_const((SV*)stash, packname_len);
604 packname = HvNAME_get(stash);
605 packname_len = HvNAMELEN_get(stash);
608 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
612 if (!(CvROOT(cv) || CvXSUB(cv)))
616 * Inheriting AUTOLOAD for non-methods works ... for now.
618 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
619 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
621 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
622 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
623 packname, (int)len, name);
626 /* rather than lookup/init $AUTOLOAD here
627 * only to have the XSUB do another lookup for $AUTOLOAD
628 * and split that value on the last '::',
629 * pass along the same data via some unused fields in the CV
632 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
638 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
639 * The subroutine's original name may not be "AUTOLOAD", so we don't
640 * use that, but for lack of anything better we will use the sub's
641 * original package to look up $AUTOLOAD.
643 varstash = GvSTASH(CvGV(cv));
644 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
648 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
649 #ifdef PERL_DONT_CREATE_GVSV
650 GvSV(vargv) = newSV(0);
654 varsv = GvSVn(vargv);
655 sv_setpvn(varsv, packname, packname_len);
656 sv_catpvs(varsv, "::");
657 sv_catpvn(varsv, name, len);
661 /* The "gv" parameter should be the glob known to Perl code as *!
662 * The scalar must already have been magicalized.
665 S_require_errno(pTHX_ GV *gv)
668 HV* stash = gv_stashpvs("Errno", FALSE);
670 if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
674 save_scalar(gv); /* keep the value of $! */
675 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
676 newSVpvs("Errno"), NULL);
679 stash = gv_stashpvs("Errno", FALSE);
680 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
681 Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
686 =for apidoc gv_stashpv
688 Returns a pointer to the stash for a specified package. C<name> should
689 be a valid UTF-8 string and must be null-terminated. If C<create> is set
690 then the package will be created if it does not already exist. If C<create>
691 is not set and the package does not exist then NULL is returned.
697 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
699 return gv_stashpvn(name, strlen(name), create);
703 =for apidoc gv_stashpvn
705 Returns a pointer to the stash for a specified package. C<name> should
706 be a valid UTF-8 string. The C<namelen> parameter indicates the length of
707 the C<name>, in bytes. If C<create> is set then the package will be
708 created if it does not already exist. If C<create> is not set and the
709 package does not exist then NULL is returned.
715 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
722 if (namelen + 3 < sizeof smallbuf)
725 Newx(tmpbuf, namelen + 3, char);
726 Copy(name,tmpbuf,namelen,char);
727 tmpbuf[namelen++] = ':';
728 tmpbuf[namelen++] = ':';
729 tmpbuf[namelen] = '\0';
730 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
731 if (tmpbuf != smallbuf)
736 GvHV(tmpgv) = newHV();
738 if (!HvNAME_get(stash))
739 hv_name_set(stash, name, namelen, 0);
744 =for apidoc gv_stashsv
746 Returns a pointer to the stash for a specified package, which must be a
747 valid UTF-8 string. See C<gv_stashpv>.
753 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
756 const char * const ptr = SvPV_const(sv,len);
757 return gv_stashpvn(ptr, len, create);
762 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
763 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
767 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
769 const char * const nambeg = SvPV_const(name, len);
770 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
774 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
778 register const char *name = nambeg;
779 register GV *gv = NULL;
782 register const char *name_cursor;
784 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
785 const I32 no_expand = flags & GV_NOEXPAND;
787 flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL;
788 const char *const name_end = nambeg + full_len;
789 const char *const name_em1 = name_end - 1;
791 if (flags & GV_NOTQUAL) {
792 /* Caller promised that there is no stash, so we can skip the check. */
797 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
798 /* accidental stringify on a GV? */
802 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
803 if ((*name_cursor == ':' && name_cursor < name_em1
804 && name_cursor[1] == ':')
805 || (*name_cursor == '\'' && name_cursor[1]))
809 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
812 len = name_cursor - name;
817 if (len + 3 < (I32)sizeof (smallbuf))
820 Newx(tmpbuf, len+3, char);
821 Copy(name, tmpbuf, len, char);
825 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
826 gv = gvp ? *gvp : NULL;
827 if (gv && gv != (GV*)&PL_sv_undef) {
828 if (SvTYPE(gv) != SVt_PVGV)
829 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
833 if (tmpbuf != smallbuf)
835 if (!gv || gv == (GV*)&PL_sv_undef)
838 if (!(stash = GvHV(gv)))
839 stash = GvHV(gv) = newHV();
841 if (!HvNAME_get(stash))
842 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
845 if (*name_cursor == ':')
849 if (name == name_end)
850 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
853 len = name_cursor - name;
855 /* No stash in name, so see how we can default */
859 if (len && isIDFIRST_lazy(name)) {
868 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
869 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
870 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
874 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
879 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
880 && name[3] == 'I' && name[4] == 'N')
884 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
885 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
886 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
890 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
891 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
899 else if (IN_PERL_COMPILETIME) {
901 if (add && (PL_hints & HINT_STRICT_VARS) &&
902 sv_type != SVt_PVCV &&
903 sv_type != SVt_PVGV &&
904 sv_type != SVt_PVFM &&
905 sv_type != SVt_PVIO &&
906 !(len == 1 && sv_type == SVt_PV &&
907 (*name == 'a' || *name == 'b')) )
909 gvp = (GV**)hv_fetch(stash,name,len,0);
911 *gvp == (GV*)&PL_sv_undef ||
912 SvTYPE(*gvp) != SVt_PVGV)
916 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
917 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
918 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
920 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
921 sv_type == SVt_PVAV ? '@' :
922 sv_type == SVt_PVHV ? '%' : '$',
925 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
931 stash = CopSTASH(PL_curcop);
937 /* By this point we should have a stash and a name */
941 SV * const err = Perl_mess(aTHX_
942 "Global symbol \"%s%s\" requires explicit package name",
943 (sv_type == SVt_PV ? "$"
944 : sv_type == SVt_PVAV ? "@"
945 : sv_type == SVt_PVHV ? "%"
948 if (USE_UTF8_IN_NAMES)
951 gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
953 /* symbol table under destruction */
962 if (!SvREFCNT(stash)) /* symbol table under destruction */
965 gvp = (GV**)hv_fetch(stash,name,len,add);
966 if (!gvp || *gvp == (GV*)&PL_sv_undef)
969 if (SvTYPE(gv) == SVt_PVGV) {
972 gv_init_sv(gv, sv_type);
973 if (*name=='!' && sv_type == SVt_PVHV && len==1)
977 } else if (no_init) {
979 } else if (no_expand && SvROK(gv)) {
983 /* Adding a new symbol */
985 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
986 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
987 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
988 gv_init_sv(gv, sv_type);
990 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
991 : (PL_dowarn & G_WARN_ON ) ) )
994 /* set up magic where warranted */
999 /* Nothing else to do.
1000 The compiler will probably turn the switch statement into a
1001 branch table. Make sure we avoid even that small overhead for
1002 the common case of lower case variable names. */
1006 const char * const name2 = name + 1;
1009 if (strEQ(name2, "RGV")) {
1010 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1012 else if (strEQ(name2, "RGVOUT")) {
1017 if (strnEQ(name2, "XPORT", 5))
1021 if (strEQ(name2, "SA")) {
1022 AV* const av = GvAVn(gv);
1024 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1025 /* NOTE: No support for tied ISA */
1026 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1027 && AvFILLp(av) == -1)
1030 av_push(av, newSVpvn(pname = "NDBM_File",9));
1031 gv_stashpvn(pname, 9, TRUE);
1032 av_push(av, newSVpvn(pname = "DB_File",7));
1033 gv_stashpvn(pname, 7, TRUE);
1034 av_push(av, newSVpvn(pname = "GDBM_File",9));
1035 gv_stashpvn(pname, 9, TRUE);
1036 av_push(av, newSVpvn(pname = "SDBM_File",9));
1037 gv_stashpvn(pname, 9, TRUE);
1038 av_push(av, newSVpvn(pname = "ODBM_File",9));
1039 gv_stashpvn(pname, 9, TRUE);
1044 if (strEQ(name2, "VERLOAD")) {
1045 HV* const hv = GvHVn(gv);
1047 hv_magic(hv, NULL, PERL_MAGIC_overload);
1051 if (strEQ(name2, "IG")) {
1055 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
1056 Newxz(PL_psig_name, SIG_SIZE, SV*);
1057 Newxz(PL_psig_pend, SIG_SIZE, int);
1061 hv_magic(hv, NULL, PERL_MAGIC_sig);
1062 for (i = 1; i < SIG_SIZE; i++) {
1063 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1065 sv_setsv(*init, &PL_sv_undef);
1067 PL_psig_name[i] = 0;
1068 PL_psig_pend[i] = 0;
1073 if (strEQ(name2, "ERSION"))
1076 case '\003': /* $^CHILD_ERROR_NATIVE */
1077 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1080 case '\005': /* $^ENCODING */
1081 if (strEQ(name2, "NCODING"))
1084 case '\017': /* $^OPEN */
1085 if (strEQ(name2, "PEN"))
1088 case '\024': /* ${^TAINT} */
1089 if (strEQ(name2, "AINT"))
1092 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1093 if (strEQ(name2, "NICODE"))
1095 if (strEQ(name2, "TF8LOCALE"))
1097 if (strEQ(name2, "TF8CACHE"))
1100 case '\027': /* $^WARNING_BITS */
1101 if (strEQ(name2, "ARNING_BITS"))
1114 /* ensures variable is only digits */
1115 /* ${"1foo"} fails this test (and is thus writeable) */
1116 /* added by japhy, but borrowed from is_gv_magical */
1117 const char *end = name + len;
1118 while (--end > name) {
1119 if (!isDIGIT(*end)) return gv;
1126 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1127 be case '\0' in this switch statement (ie a default case) */
1133 sv_type == SVt_PVAV ||
1134 sv_type == SVt_PVHV ||
1135 sv_type == SVt_PVCV ||
1136 sv_type == SVt_PVFM ||
1139 PL_sawampersand = TRUE;
1143 sv_setpv(GvSVn(gv),PL_chopset);
1147 #ifdef COMPLEX_STATUS
1148 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1154 /* If %! has been used, automatically load Errno.pm.
1155 The require will itself set errno, so in order to
1156 preserve its value we have to set up the magic
1157 now (rather than going to magicalize)
1160 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1162 if (sv_type == SVt_PVHV)
1168 AV* const av = GvAVn(gv);
1169 sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
1175 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1176 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1177 "$%c is no longer supported", *name);
1180 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1183 case '\010': /* $^H */
1185 HV *const hv = GvHVn(gv);
1186 hv_magic(hv, NULL, PERL_MAGIC_hints);
1193 AV* const av = GvAVn(gv);
1194 HV* const hv = GvHVn(gv);
1195 sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1197 hv_magic(hv, NULL, PERL_MAGIC_regdata_names);
1201 case '\023': /* $^S */
1212 SvREADONLY_on(GvSVn(gv));
1227 case '\001': /* $^A */
1228 case '\003': /* $^C */
1229 case '\004': /* $^D */
1230 case '\005': /* $^E */
1231 case '\006': /* $^F */
1232 case '\011': /* $^I, NOT \t in EBCDIC */
1233 case '\016': /* $^N */
1234 case '\017': /* $^O */
1235 case '\020': /* $^P */
1236 case '\024': /* $^T */
1237 case '\027': /* $^W */
1239 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1242 case '\014': /* $^L */
1243 sv_setpvn(GvSVn(gv),"\f",1);
1244 PL_formfeed = GvSVn(gv);
1247 sv_setpvn(GvSVn(gv),"\034",1);
1251 SV * const sv = GvSVn(gv);
1252 if (!sv_derived_from(PL_patchlevel, "version"))
1253 upg_version(PL_patchlevel);
1254 GvSV(gv) = vnumify(PL_patchlevel);
1255 SvREADONLY_on(GvSV(gv));
1259 case '\026': /* $^V */
1261 SV * const sv = GvSVn(gv);
1262 GvSV(gv) = new_version(PL_patchlevel);
1263 SvREADONLY_on(GvSV(gv));
1273 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1277 const HV * const hv = GvSTASH(gv);
1282 sv_setpv(sv, prefix ? prefix : "");
1284 name = HvNAME_get(hv);
1286 namelen = HvNAMELEN_get(hv);
1292 if (keepmain || strNE(name, "main")) {
1293 sv_catpvn(sv,name,namelen);
1296 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1300 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1302 const GV * const egv = GvEGV(gv);
1303 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1311 IO * const io = (IO*)newSV(0);
1313 sv_upgrade((SV *)io,SVt_PVIO);
1314 /* This used to read SvREFCNT(io) = 1;
1315 It's not clear why the reference count needed an explicit reset. NWC
1317 assert (SvREFCNT(io) == 1);
1319 /* Clear the stashcache because a new IO could overrule a package name */
1320 hv_clear(PL_stashcache);
1321 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1322 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1323 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1324 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1325 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1330 Perl_gv_check(pTHX_ const HV *stash)
1335 if (!HvARRAY(stash))
1337 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1339 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1342 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1343 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1345 if (hv != PL_defstash && hv != stash)
1346 gv_check(hv); /* nested package */
1348 else if (isALPHA(*HeKEY(entry))) {
1350 gv = (GV*)HeVAL(entry);
1351 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1354 /* performance hack: if filename is absolute and it's a standard
1355 * module, don't bother warning */
1356 #ifdef MACOS_TRADITIONAL
1357 # define LIB_COMPONENT ":lib:"
1359 # define LIB_COMPONENT "/lib/"
1362 && PERL_FILE_IS_ABSOLUTE(file)
1363 && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1367 CopLINE_set(PL_curcop, GvLINE(gv));
1369 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1371 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1373 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1374 "Name \"%s::%s\" used only once: possible typo",
1375 HvNAME_get(stash), GvNAME(gv));
1382 Perl_newGVgen(pTHX_ const char *pack)
1385 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1389 /* hopefully this is only called on local symbol table entries */
1392 Perl_gp_ref(pTHX_ GP *gp)
1400 /* multi-named GPs cannot be used for method cache */
1401 SvREFCNT_dec(gp->gp_cv);
1406 /* Adding a new name to a subroutine invalidates method cache */
1407 PL_sub_generation++;
1414 Perl_gp_free(pTHX_ GV *gv)
1419 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1421 if (gp->gp_refcnt == 0) {
1422 if (ckWARN_d(WARN_INTERNAL))
1423 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1424 "Attempt to free unreferenced glob pointers"
1425 pTHX__FORMAT pTHX__VALUE);
1429 /* Deleting the name of a subroutine invalidates method cache */
1430 PL_sub_generation++;
1432 if (--gp->gp_refcnt > 0) {
1433 if (gp->gp_egv == gv)
1439 unshare_hek(gp->gp_file_hek);
1440 SvREFCNT_dec(gp->gp_sv);
1441 SvREFCNT_dec(gp->gp_av);
1442 /* FIXME - another reference loop GV -> symtab -> GV ?
1443 Somehow gp->gp_hv can end up pointing at freed garbage. */
1444 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1445 const char *hvname = HvNAME_get(gp->gp_hv);
1446 if (PL_stashcache && hvname)
1447 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1449 SvREFCNT_dec(gp->gp_hv);
1451 SvREFCNT_dec(gp->gp_io);
1452 SvREFCNT_dec(gp->gp_cv);
1453 SvREFCNT_dec(gp->gp_form);
1460 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1462 AMT * const amtp = (AMT*)mg->mg_ptr;
1463 PERL_UNUSED_ARG(sv);
1465 if (amtp && AMT_AMAGIC(amtp)) {
1467 for (i = 1; i < NofAMmeth; i++) {
1468 CV * const cv = amtp->table[i];
1470 SvREFCNT_dec((SV *) cv);
1471 amtp->table[i] = NULL;
1478 /* Updates and caches the CV's */
1481 Perl_Gv_AMupdate(pTHX_ HV *stash)
1484 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1488 const AMT * const amtp = (AMT*)mg->mg_ptr;
1489 if (amtp->was_ok_am == PL_amagic_generation
1490 && amtp->was_ok_sub == PL_sub_generation) {
1491 return (bool)AMT_OVERLOADED(amtp);
1493 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1496 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1499 amt.was_ok_am = PL_amagic_generation;
1500 amt.was_ok_sub = PL_sub_generation;
1501 amt.fallback = AMGfallNO;
1505 int filled = 0, have_ovl = 0;
1508 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1510 /* Try to find via inheritance. */
1511 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1512 SV * const sv = gv ? GvSV(gv) : NULL;
1516 lim = DESTROY_amg; /* Skip overloading entries. */
1517 #ifdef PERL_DONT_CREATE_GVSV
1519 NOOP; /* Equivalent to !SvTRUE and !SvOK */
1522 else if (SvTRUE(sv))
1523 amt.fallback=AMGfallYES;
1525 amt.fallback=AMGfallNEVER;
1527 for (i = 1; i < lim; i++)
1528 amt.table[i] = NULL;
1529 for (; i < NofAMmeth; i++) {
1530 const char * const cooky = PL_AMG_names[i];
1531 /* Human-readable form, for debugging: */
1532 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1533 const STRLEN l = strlen(cooky);
1535 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1536 cp, HvNAME_get(stash)) );
1537 /* don't fill the cache while looking up!
1538 Creation of inheritance stubs in intermediate packages may
1539 conflict with the logic of runtime method substitution.
1540 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1541 then we could have created stubs for "(+0" in A and C too.
1542 But if B overloads "bool", we may want to use it for
1543 numifying instead of C's "+0". */
1544 if (i >= DESTROY_amg)
1545 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1546 else /* Autoload taken care of below */
1547 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1549 if (gv && (cv = GvCV(gv))) {
1551 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1552 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1553 /* This is a hack to support autoloading..., while
1554 knowing *which* methods were declared as overloaded. */
1555 /* GvSV contains the name of the method. */
1557 SV *gvsv = GvSV(gv);
1559 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1560 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1561 (void*)GvSV(gv), cp, hvname) );
1562 if (!gvsv || !SvPOK(gvsv)
1563 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1566 /* Can be an import stub (created by "can"). */
1567 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1568 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1569 "in package \"%.256s\"",
1570 (GvCVGEN(gv) ? "Stub found while resolving"
1574 cv = GvCV(gv = ngv);
1576 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1577 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1578 GvNAME(CvGV(cv))) );
1580 if (i < DESTROY_amg)
1582 } else if (gv) { /* Autoloaded... */
1586 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1589 AMT_AMAGIC_on(&amt);
1591 AMT_OVERLOADED_on(&amt);
1592 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1593 (char*)&amt, sizeof(AMT));
1597 /* Here we have no table: */
1599 AMT_AMAGIC_off(&amt);
1600 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1601 (char*)&amt, sizeof(AMTS));
1607 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1613 if (!stash || !HvNAME_get(stash))
1615 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1619 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1622 amtp = (AMT*)mg->mg_ptr;
1623 if ( amtp->was_ok_am != PL_amagic_generation
1624 || amtp->was_ok_sub != PL_sub_generation )
1626 if (AMT_AMAGIC(amtp)) {
1627 CV * const ret = amtp->table[id];
1628 if (ret && isGV(ret)) { /* Autoloading stab */
1629 /* Passing it through may have resulted in a warning
1630 "Inherited AUTOLOAD for a non-method deprecated", since
1631 our caller is going through a function call, not a method call.
1632 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1633 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1646 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1651 CV **cvp=NULL, **ocvp=NULL;
1652 AMT *amtp=NULL, *oamtp=NULL;
1653 int off = 0, off1, lr = 0, notfound = 0;
1654 int postpr = 0, force_cpy = 0;
1655 int assign = AMGf_assign & flags;
1656 const int assignshift = assign ? 1 : 0;
1661 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1662 && (stash = SvSTASH(SvRV(left)))
1663 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1664 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1665 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1667 && ((cv = cvp[off=method+assignshift])
1668 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1674 cv = cvp[off=method])))) {
1675 lr = -1; /* Call method for left argument */
1677 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1680 /* look for substituted methods */
1681 /* In all the covered cases we should be called with assign==0. */
1685 if ((cv = cvp[off=add_ass_amg])
1686 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1687 right = &PL_sv_yes; lr = -1; assign = 1;
1692 if ((cv = cvp[off = subtr_ass_amg])
1693 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1694 right = &PL_sv_yes; lr = -1; assign = 1;
1698 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1701 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1704 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1707 (void)((cv = cvp[off=bool__amg])
1708 || (cv = cvp[off=numer_amg])
1709 || (cv = cvp[off=string_amg]));
1715 * SV* ref causes confusion with the interpreter variable of
1718 SV* const tmpRef=SvRV(left);
1719 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1721 * Just to be extra cautious. Maybe in some
1722 * additional cases sv_setsv is safe, too.
1724 SV* const newref = newSVsv(tmpRef);
1725 SvOBJECT_on(newref);
1726 /* As a bit of a source compatibility hack, SvAMAGIC() and
1727 friends dereference an RV, to behave the same was as when
1728 overloading was stored on the reference, not the referant.
1729 Hence we can't use SvAMAGIC_on()
1731 SvFLAGS(newref) |= SVf_AMAGIC;
1732 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1738 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1739 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1740 SV* const nullsv=sv_2mortal(newSViv(0));
1742 SV* const lessp = amagic_call(left,nullsv,
1743 lt_amg,AMGf_noright);
1744 logic = SvTRUE(lessp);
1746 SV* const lessp = amagic_call(left,nullsv,
1747 ncmp_amg,AMGf_noright);
1748 logic = (SvNV(lessp) < 0);
1751 if (off==subtr_amg) {
1762 if ((cv = cvp[off=subtr_amg])) {
1764 left = sv_2mortal(newSViv(0));
1769 case iter_amg: /* XXXX Eventually should do to_gv. */
1771 return NULL; /* Delegate operation to standard mechanisms. */
1779 return left; /* Delegate operation to standard mechanisms. */
1784 if (!cv) goto not_found;
1785 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1786 && (stash = SvSTASH(SvRV(right)))
1787 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1788 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1789 ? (amtp = (AMT*)mg->mg_ptr)->table
1791 && (cv = cvp[off=method])) { /* Method for right
1794 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1795 && (cvp=ocvp) && (lr = -1))
1796 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1797 && !(flags & AMGf_unary)) {
1798 /* We look for substitution for
1799 * comparison operations and
1801 if (method==concat_amg || method==concat_ass_amg
1802 || method==repeat_amg || method==repeat_ass_amg) {
1803 return NULL; /* Delegate operation to string conversion */
1813 postpr = 1; off=ncmp_amg; break;
1820 postpr = 1; off=scmp_amg; break;
1822 if (off != -1) cv = cvp[off];
1827 not_found: /* No method found, either report or croak */
1835 return left; /* Delegate operation to standard mechanisms. */
1838 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1839 notfound = 1; lr = -1;
1840 } else if (cvp && (cv=cvp[nomethod_amg])) {
1841 notfound = 1; lr = 1;
1842 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1843 /* Skip generating the "no method found" message. */
1847 if (off==-1) off=method;
1848 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1849 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1850 AMG_id2name(method + assignshift),
1851 (flags & AMGf_unary ? " " : "\n\tleft "),
1853 "in overloaded package ":
1854 "has no overloaded magic",
1856 HvNAME_get(SvSTASH(SvRV(left))):
1859 ",\n\tright argument in overloaded package ":
1862 : ",\n\tright argument has no overloaded magic"),
1864 HvNAME_get(SvSTASH(SvRV(right))):
1866 if (amtp && amtp->fallback >= AMGfallYES) {
1867 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1869 Perl_croak(aTHX_ "%"SVf, (void*)msg);
1873 force_cpy = force_cpy || assign;
1878 DEBUG_o(Perl_deb(aTHX_
1879 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1881 method+assignshift==off? "" :
1883 method+assignshift==off? "" :
1884 AMG_id2name(method+assignshift),
1885 method+assignshift==off? "" : "\")",
1886 flags & AMGf_unary? "" :
1887 lr==1 ? " for right argument": " for left argument",
1888 flags & AMGf_unary? " for argument" : "",
1889 stash ? HvNAME_get(stash) : "null",
1890 fl? ",\n\tassignment variant used": "") );
1893 /* Since we use shallow copy during assignment, we need
1894 * to dublicate the contents, probably calling user-supplied
1895 * version of copy operator
1897 /* We need to copy in following cases:
1898 * a) Assignment form was called.
1899 * assignshift==1, assign==T, method + 1 == off
1900 * b) Increment or decrement, called directly.
1901 * assignshift==0, assign==0, method + 0 == off
1902 * c) Increment or decrement, translated to assignment add/subtr.
1903 * assignshift==0, assign==T,
1905 * d) Increment or decrement, translated to nomethod.
1906 * assignshift==0, assign==0,
1908 * e) Assignment form translated to nomethod.
1909 * assignshift==1, assign==T, method + 1 != off
1912 /* off is method, method+assignshift, or a result of opcode substitution.
1913 * In the latter case assignshift==0, so only notfound case is important.
1915 if (( (method + assignshift == off)
1916 && (assign || (method == inc_amg) || (method == dec_amg)))
1923 const bool oldcatch = CATCH_GET;
1926 Zero(&myop, 1, BINOP);
1927 myop.op_last = (OP *) &myop;
1928 myop.op_next = NULL;
1929 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1931 PUSHSTACKi(PERLSI_OVERLOAD);
1934 PL_op = (OP *) &myop;
1935 if (PERLDB_SUB && PL_curstash != PL_debstash)
1936 PL_op->op_private |= OPpENTERSUB_DB;
1940 EXTEND(SP, notfound + 5);
1941 PUSHs(lr>0? right: left);
1942 PUSHs(lr>0? left: right);
1943 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1945 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1950 if ((PL_op = Perl_pp_entersub(aTHX)))
1958 CATCH_SET(oldcatch);
1965 ans=SvIV(res)<=0; break;
1968 ans=SvIV(res)<0; break;
1971 ans=SvIV(res)>=0; break;
1974 ans=SvIV(res)>0; break;
1977 ans=SvIV(res)==0; break;
1980 ans=SvIV(res)!=0; break;
1983 SvSetSV(left,res); return left;
1985 ans=!SvTRUE(res); break;
1990 } else if (method==copy_amg) {
1992 Perl_croak(aTHX_ "Copy method did not return a reference");
1994 return SvREFCNT_inc(SvRV(res));
2002 =for apidoc is_gv_magical_sv
2004 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2010 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2013 const char * const temp = SvPV_const(name, len);
2014 return is_gv_magical(temp, len, flags);
2018 =for apidoc is_gv_magical
2020 Returns C<TRUE> if given the name of a magical GV.
2022 Currently only useful internally when determining if a GV should be
2023 created even in rvalue contexts.
2025 C<flags> is not used at present but available for future extension to
2026 allow selecting particular classes of magical variable.
2028 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2029 This assumption is met by all callers within the perl core, which all pass
2030 pointers returned by SvPV.
2035 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2037 PERL_UNUSED_CONTEXT;
2038 PERL_UNUSED_ARG(flags);
2041 const char * const name1 = name + 1;
2044 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2048 if (len == 8 && strEQ(name1, "VERLOAD"))
2052 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2055 /* Using ${^...} variables is likely to be sufficiently rare that
2056 it seems sensible to avoid the space hit of also checking the
2058 case '\017': /* ${^OPEN} */
2059 if (strEQ(name1, "PEN"))
2062 case '\024': /* ${^TAINT} */
2063 if (strEQ(name1, "AINT"))
2066 case '\025': /* ${^UNICODE} */
2067 if (strEQ(name1, "NICODE"))
2069 if (strEQ(name1, "TF8LOCALE"))
2072 case '\027': /* ${^WARNING_BITS} */
2073 if (strEQ(name1, "ARNING_BITS"))
2086 const char *end = name + len;
2087 while (--end > name) {
2095 /* Because we're already assuming that name is NUL terminated
2096 below, we can treat an empty name as "\0" */
2123 case '\001': /* $^A */
2124 case '\003': /* $^C */
2125 case '\004': /* $^D */
2126 case '\005': /* $^E */
2127 case '\006': /* $^F */
2128 case '\010': /* $^H */
2129 case '\011': /* $^I, NOT \t in EBCDIC */
2130 case '\014': /* $^L */
2131 case '\016': /* $^N */
2132 case '\017': /* $^O */
2133 case '\020': /* $^P */
2134 case '\023': /* $^S */
2135 case '\024': /* $^T */
2136 case '\026': /* $^V */
2137 case '\027': /* $^W */
2157 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2163 PERL_UNUSED_ARG(flags);
2166 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2168 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2169 unshare_hek(GvNAME_HEK(gv));
2172 PERL_HASH(hash, name, len);
2173 GvNAME_HEK(gv) = share_hek(name, len, hash);
2178 * c-indentation-style: bsd
2180 * indent-tabs-mode: t
2183 * ex: set ts=8 sts=4 sw=4 noet: