3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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)
107 return gv_fetchfile_flags(name, strlen(name), 0);
111 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
117 const STRLEN tmplen = namelen + 2;
120 PERL_UNUSED_ARG(flags);
125 if (tmplen <= sizeof smallbuf)
128 Newx(tmpbuf, tmplen, char);
129 /* This is where the debugger's %{"::_<$filename"} hash is created */
132 memcpy(tmpbuf + 2, name, namelen);
133 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
135 gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
136 #ifdef PERL_DONT_CREATE_GVSV
137 GvSV(gv) = newSVpvn(name, namelen);
139 sv_setpvn(GvSV(gv), name, namelen);
142 hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
144 if (tmpbuf != smallbuf)
150 =for apidoc gv_const_sv
152 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
153 inlining, or C<gv> is a placeholder reference that would be promoted to such
154 a typeglob, then returns the value returned by the sub. Otherwise, returns
161 Perl_gv_const_sv(pTHX_ GV *gv)
163 if (SvTYPE(gv) == SVt_PVGV)
164 return cv_const_sv(GvCVu(gv));
165 return SvROK(gv) ? SvRV(gv) : NULL;
169 Perl_newGP(pTHX_ GV *const gv)
172 const char *const file
173 = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
174 STRLEN len = strlen(file);
177 PERL_HASH(hash, file, len);
181 #ifndef PERL_DONT_CREATE_GVSV
182 gp->gp_sv = newSV(0);
185 gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
186 /* XXX Ideally this cast would be replaced with a change to const char*
188 gp->gp_file_hek = share_hek(file, len, hash);
196 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
199 const U32 old_type = SvTYPE(gv);
200 const bool doproto = old_type > SVt_NULL;
201 const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
202 SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
203 const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
205 assert (!(proto && has_constant));
208 /* The constant has to be a simple scalar type. */
209 switch (SvTYPE(has_constant)) {
215 Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
216 sv_reftype(has_constant, 0));
224 if (old_type < SVt_PVGV) {
225 if (old_type >= SVt_PV)
227 sv_upgrade((SV*)gv, SVt_PVGV);
235 Safefree(SvPVX_mutable(gv));
240 GvGP(gv) = Perl_newGP(aTHX_ gv);
243 Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv);
244 gv_name_set(gv, name, len, GV_ADD);
245 if (multi || doproto) /* doproto means it _was_ mentioned */
247 if (doproto) { /* Replicate part of newSUB here. */
250 /* newCONSTSUB takes ownership of the reference from us. */
251 GvCV(gv) = newCONSTSUB(stash, name, has_constant);
252 /* If this reference was a copy of another, then the subroutine
253 must have been "imported", by a Perl space assignment to a GV
254 from a reference to CV. */
255 if (exported_constant)
256 GvIMPORTED_CV_on(gv);
258 (void) start_subparse(0,0); /* Create empty CV in compcv. */
259 GvCV(gv) = PL_compcv;
263 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
265 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
266 CvSTASH(GvCV(gv)) = PL_curstash;
268 sv_setpv((SV*)GvCV(gv), proto);
275 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
287 #ifdef PERL_DONT_CREATE_GVSV
295 /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
296 If we just cast GvSVn(gv) to void, it ignores evaluating it for
304 =for apidoc gv_fetchmeth
306 Returns the glob with the given C<name> and a defined subroutine or
307 C<NULL>. The glob lives in the given C<stash>, or in the stashes
308 accessible via @ISA and UNIVERSAL::.
310 The argument C<level> should be either 0 or -1. If C<level==0>, as a
311 side-effect creates a glob with the given C<name> in the given C<stash>
312 which in the case of success contains an alias for the subroutine, and sets
313 up caching info for this glob.
315 This function grants C<"SUPER"> token as a postfix of the stash name. The
316 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
317 visible to Perl code. So when calling C<call_sv>, you should not use
318 the GV directly; instead, you should use the method's CV, which can be
319 obtained from the GV with the C<GvCV> macro.
324 /* NOTE: No support for tied ISA */
327 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
335 GV* candidate = NULL;
340 I32 create = (level >= 0) ? 1 : 0;
345 /* UNIVERSAL methods should be callable without a stash */
347 create = 0; /* probably appropriate */
348 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
354 hvname = HvNAME_get(stash);
356 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
361 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
363 topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
365 /* check locally for a real method or a cache entry */
366 gvp = (GV**)hv_fetch(stash, name, len, create);
370 if (SvTYPE(topgv) != SVt_PVGV)
371 gv_init(topgv, stash, name, len, TRUE);
372 if ((cand_cv = GvCV(topgv))) {
373 /* If genuine method or valid cache entry, use it */
374 if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
378 /* stale cache entry, junk it and move on */
379 SvREFCNT_dec(cand_cv);
380 GvCV(topgv) = cand_cv = NULL;
384 else if (GvCVGEN(topgv) == topgen_cmp) {
385 /* cache indicates no such method definitively */
390 packlen = HvNAMELEN_get(stash);
391 if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
394 basestash = gv_stashpvn(hvname, packlen, GV_ADD);
395 linear_av = mro_get_linear_isa(basestash);
398 linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
401 linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
402 items = AvFILLp(linear_av); /* no +1, to skip over self */
404 linear_sv = *linear_svp++;
406 cstash = gv_stashsv(linear_sv, 0);
409 if (ckWARN(WARN_SYNTAX))
410 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
411 SVfARG(linear_sv), hvname);
417 gvp = (GV**)hv_fetch(cstash, name, len, 0);
421 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
422 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
424 * Found real method, cache method in topgv if:
425 * 1. topgv has no synonyms (else inheritance crosses wires)
426 * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
428 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
429 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
430 SvREFCNT_inc_simple_void_NN(cand_cv);
431 GvCV(topgv) = cand_cv;
432 GvCVGEN(topgv) = topgen_cmp;
438 /* Check UNIVERSAL without caching */
439 if(level == 0 || level == -1) {
440 candidate = gv_fetchmeth(NULL, name, len, 1);
442 cand_cv = GvCV(candidate);
443 if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
444 if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
445 SvREFCNT_inc_simple_void_NN(cand_cv);
446 GvCV(topgv) = cand_cv;
447 GvCVGEN(topgv) = topgen_cmp;
453 if (topgv && GvREFCNT(topgv) == 1) {
454 /* cache the fact that the method is not defined */
455 GvCVGEN(topgv) = topgen_cmp;
462 =for apidoc gv_fetchmeth_autoload
464 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
465 Returns a glob for the subroutine.
467 For an autoloaded subroutine without a GV, will create a GV even
468 if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
469 of the result may be zero.
475 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
477 GV *gv = gv_fetchmeth(stash, name, len, level);
484 return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */
485 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
487 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
490 if (!(CvROOT(cv) || CvXSUB(cv)))
492 /* Have an autoload */
493 if (level < 0) /* Cannot do without a stub */
494 gv_fetchmeth(stash, name, len, 0);
495 gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
504 =for apidoc gv_fetchmethod_autoload
506 Returns the glob which contains the subroutine to call to invoke the method
507 on the C<stash>. In fact in the presence of autoloading this may be the
508 glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
511 The third parameter of C<gv_fetchmethod_autoload> determines whether
512 AUTOLOAD lookup is performed if the given method is not present: non-zero
513 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
514 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
515 with a non-zero C<autoload> parameter.
517 These functions grant C<"SUPER"> token as a prefix of the method name. Note
518 that if you want to keep the returned glob for a long time, you need to
519 check for it being "AUTOLOAD", since at the later time the call may load a
520 different subroutine due to $AUTOLOAD changing its value. Use the glob
521 created via a side effect to do this.
523 These functions have the same side-effects and as C<gv_fetchmeth> with
524 C<level==0>. C<name> should be writable if contains C<':'> or C<'
525 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
526 C<call_sv> apply equally to these functions.
532 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
535 register const char *nend;
536 const char *nsplit = NULL;
540 if (stash && SvTYPE(stash) < SVt_PVHV)
543 for (nend = name; *nend; nend++) {
546 else if (*nend == ':' && *(nend + 1) == ':')
550 const char * const origname = name;
554 if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
555 /* ->SUPER::method should really be looked up in original stash */
556 SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
557 CopSTASHPV(PL_curcop)));
558 /* __PACKAGE__::SUPER stash should be autovivified */
559 stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), GV_ADD);
560 DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
561 origname, HvNAME_get(stash), name) );
564 /* don't autovifify if ->NoSuchStash::method */
565 stash = gv_stashpvn(origname, nsplit - origname, 0);
567 /* however, explicit calls to Pkg::SUPER::method may
568 happen, and may require autovivification to work */
569 if (!stash && (nsplit - origname) >= 7 &&
570 strnEQ(nsplit - 7, "::SUPER", 7) &&
571 gv_stashpvn(origname, nsplit - origname - 7, 0))
572 stash = gv_stashpvn(origname, nsplit - origname, GV_ADD);
577 gv = gv_fetchmeth(stash, name, nend - name, 0);
579 if (strEQ(name,"import") || strEQ(name,"unimport"))
580 gv = (GV*)&PL_sv_yes;
582 gv = gv_autoload4(ostash, name, nend - name, TRUE);
585 CV* const cv = GvCV(gv);
586 if (!CvROOT(cv) && !CvXSUB(cv)) {
594 if (GvCV(stubgv) != cv) /* orphaned import */
597 autogv = gv_autoload4(GvSTASH(stubgv),
598 GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
608 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
616 const char *packname = "";
617 STRLEN packname_len = 0;
619 if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
622 if (SvTYPE(stash) < SVt_PVHV) {
623 packname = SvPV_const((SV*)stash, packname_len);
627 packname = HvNAME_get(stash);
628 packname_len = HvNAMELEN_get(stash);
631 if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
635 if (!(CvROOT(cv) || CvXSUB(cv)))
639 * Inheriting AUTOLOAD for non-methods works ... for now.
641 if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
642 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
644 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
645 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
646 packname, (int)len, name);
649 /* rather than lookup/init $AUTOLOAD here
650 * only to have the XSUB do another lookup for $AUTOLOAD
651 * and split that value on the last '::',
652 * pass along the same data via some unused fields in the CV
655 SvPV_set(cv, (char *)name); /* cast to lose constness warning */
661 * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
662 * The subroutine's original name may not be "AUTOLOAD", so we don't
663 * use that, but for lack of anything better we will use the sub's
664 * original package to look up $AUTOLOAD.
666 varstash = GvSTASH(CvGV(cv));
667 vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
671 gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
672 #ifdef PERL_DONT_CREATE_GVSV
673 GvSV(vargv) = newSV(0);
677 varsv = GvSVn(vargv);
678 sv_setpvn(varsv, packname, packname_len);
679 sv_catpvs(varsv, "::");
680 sv_catpvn(varsv, name, len);
685 /* require_tie_mod() internal routine for requiring a module
686 * that implements the logic of automatical ties like %! and %-
688 * The "gv" parameter should be the glob.
689 * "varpv" holds the name of the var, used for error messages.
690 * "namesv" holds the module name. Its refcount will be decremented.
691 * "methpv" holds the method name to test for to check that things
692 * are working reasonably close to as expected.
693 * "flags": if flag & 1 then save the scalar before loading.
694 * For the protection of $! to work (it is set by this routine)
695 * the sv slot must already be magicalized.
698 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
701 HV* stash = gv_stashsv(namesv, 0);
703 if (!stash || !(gv_fetchmethod(stash, methpv))) {
704 SV *module = newSVsv(namesv);
705 char varname = *varpv; /* varpv might be clobbered by load_module,
706 so save it. For the moment it's always
712 PUSHSTACKi(PERLSI_MAGIC);
713 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
717 stash = gv_stashsv(namesv, 0);
719 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
720 varname, SVfARG(namesv));
721 else if (!gv_fetchmethod(stash, methpv))
722 Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
723 varname, SVfARG(namesv), methpv);
725 SvREFCNT_dec(namesv);
730 =for apidoc gv_stashpv
732 Returns a pointer to the stash for a specified package. Uses C<strlen> to
733 determine the length of C<name>, then calls C<gv_stashpvn()>.
739 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
741 return gv_stashpvn(name, strlen(name), create);
745 =for apidoc gv_stashpvn
747 Returns a pointer to the stash for a specified package. The C<namelen>
748 parameter indicates the length of the C<name>, in bytes. C<flags> is passed
749 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
750 created if it does not already exist. If the package does not exist and
751 C<flags> is 0 (or any other setting that does not create packages) then NULL
759 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
766 if (namelen + 2 <= sizeof smallbuf)
769 Newx(tmpbuf, namelen + 2, char);
770 Copy(name,tmpbuf,namelen,char);
771 tmpbuf[namelen++] = ':';
772 tmpbuf[namelen++] = ':';
773 tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
774 if (tmpbuf != smallbuf)
779 GvHV(tmpgv) = newHV();
781 if (!HvNAME_get(stash))
782 hv_name_set(stash, name, namelen, 0);
787 =for apidoc gv_stashsv
789 Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
795 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
798 const char * const ptr = SvPV_const(sv,len);
799 return gv_stashpvn(ptr, len, flags);
804 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
805 return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
809 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
811 const char * const nambeg = SvPV_const(name, len);
812 return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
816 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
820 register const char *name = nambeg;
821 register GV *gv = NULL;
824 register const char *name_cursor;
826 const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
827 const I32 no_expand = flags & GV_NOEXPAND;
828 const I32 add = flags & ~GV_NOADD_MASK;
829 const char *const name_end = nambeg + full_len;
830 const char *const name_em1 = name_end - 1;
832 if (flags & GV_NOTQUAL) {
833 /* Caller promised that there is no stash, so we can skip the check. */
838 if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
839 /* accidental stringify on a GV? */
843 for (name_cursor = name; name_cursor < name_end; name_cursor++) {
844 if ((*name_cursor == ':' && name_cursor < name_em1
845 && name_cursor[1] == ':')
846 || (*name_cursor == '\'' && name_cursor[1]))
850 if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
853 len = name_cursor - name;
858 if (len + 2 <= (I32)sizeof (smallbuf))
861 Newx(tmpbuf, len+2, char);
862 Copy(name, tmpbuf, len, char);
865 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
866 gv = gvp ? *gvp : NULL;
867 if (gv && gv != (GV*)&PL_sv_undef) {
868 if (SvTYPE(gv) != SVt_PVGV)
869 gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
873 if (tmpbuf != smallbuf)
875 if (!gv || gv == (GV*)&PL_sv_undef)
878 if (!(stash = GvHV(gv)))
879 stash = GvHV(gv) = newHV();
881 if (!HvNAME_get(stash))
882 hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
885 if (*name_cursor == ':')
889 if (name == name_end)
890 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
893 len = name_cursor - name;
895 /* No stash in name, so see how we can default */
899 if (len && isIDFIRST_lazy(name)) {
908 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
909 || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
910 || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
914 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
919 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
920 && name[3] == 'I' && name[4] == 'N')
924 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
925 &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
926 ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
930 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
931 && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
939 else if (IN_PERL_COMPILETIME) {
941 if (add && (PL_hints & HINT_STRICT_VARS) &&
942 sv_type != SVt_PVCV &&
943 sv_type != SVt_PVGV &&
944 sv_type != SVt_PVFM &&
945 sv_type != SVt_PVIO &&
946 !(len == 1 && sv_type == SVt_PV &&
947 (*name == 'a' || *name == 'b')) )
949 gvp = (GV**)hv_fetch(stash,name,len,0);
951 *gvp == (GV*)&PL_sv_undef ||
952 SvTYPE(*gvp) != SVt_PVGV)
956 else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) ||
957 (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
958 (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
960 Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
961 sv_type == SVt_PVAV ? '@' :
962 sv_type == SVt_PVHV ? '%' : '$',
965 Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
971 stash = CopSTASH(PL_curcop);
977 /* By this point we should have a stash and a name */
981 SV * const err = Perl_mess(aTHX_
982 "Global symbol \"%s%s\" requires explicit package name",
983 (sv_type == SVt_PV ? "$"
984 : sv_type == SVt_PVAV ? "@"
985 : sv_type == SVt_PVHV ? "%"
988 if (USE_UTF8_IN_NAMES)
991 gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
993 /* symbol table under destruction */
1002 if (!SvREFCNT(stash)) /* symbol table under destruction */
1005 gvp = (GV**)hv_fetch(stash,name,len,add);
1006 if (!gvp || *gvp == (GV*)&PL_sv_undef)
1009 if (SvTYPE(gv) == SVt_PVGV) {
1012 gv_init_sv(gv, sv_type);
1013 if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1015 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1016 else if (*name == '-' || *name == '+')
1017 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
1021 } else if (no_init) {
1023 } else if (no_expand && SvROK(gv)) {
1027 /* Adding a new symbol */
1029 if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
1030 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1031 gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1032 gv_init_sv(gv, sv_type);
1034 if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1035 : (PL_dowarn & G_WARN_ON ) ) )
1038 /* set up magic where warranted */
1043 /* Nothing else to do.
1044 The compiler will probably turn the switch statement into a
1045 branch table. Make sure we avoid even that small overhead for
1046 the common case of lower case variable names. */
1050 const char * const name2 = name + 1;
1053 if (strEQ(name2, "RGV")) {
1054 IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1056 else if (strEQ(name2, "RGVOUT")) {
1061 if (strnEQ(name2, "XPORT", 5))
1065 if (strEQ(name2, "SA")) {
1066 AV* const av = GvAVn(gv);
1068 sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1069 /* NOTE: No support for tied ISA */
1070 if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1071 && AvFILLp(av) == -1)
1074 av_push(av, newSVpvn(pname = "NDBM_File",9));
1075 gv_stashpvn(pname, 9, GV_ADD);
1076 av_push(av, newSVpvn(pname = "DB_File",7));
1077 gv_stashpvn(pname, 7, GV_ADD);
1078 av_push(av, newSVpvn(pname = "GDBM_File",9));
1079 gv_stashpvn(pname, 9, GV_ADD);
1080 av_push(av, newSVpvn(pname = "SDBM_File",9));
1081 gv_stashpvn(pname, 9, GV_ADD);
1082 av_push(av, newSVpvn(pname = "ODBM_File",9));
1083 gv_stashpvn(pname, 9, GV_ADD);
1088 if (strEQ(name2, "VERLOAD")) {
1089 HV* const hv = GvHVn(gv);
1091 hv_magic(hv, NULL, PERL_MAGIC_overload);
1095 if (strEQ(name2, "IG")) {
1099 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
1100 Newxz(PL_psig_name, SIG_SIZE, SV*);
1101 Newxz(PL_psig_pend, SIG_SIZE, int);
1105 hv_magic(hv, NULL, PERL_MAGIC_sig);
1106 for (i = 1; i < SIG_SIZE; i++) {
1107 SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1109 sv_setsv(*init, &PL_sv_undef);
1111 PL_psig_name[i] = 0;
1112 PL_psig_pend[i] = 0;
1117 if (strEQ(name2, "ERSION"))
1120 case '\003': /* $^CHILD_ERROR_NATIVE */
1121 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1124 case '\005': /* $^ENCODING */
1125 if (strEQ(name2, "NCODING"))
1128 case '\015': /* $^MATCH */
1129 if (strEQ(name2, "ATCH"))
1131 case '\017': /* $^OPEN */
1132 if (strEQ(name2, "PEN"))
1135 case '\020': /* $^PREMATCH $^POSTMATCH */
1136 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1138 case '\024': /* ${^TAINT} */
1139 if (strEQ(name2, "AINT"))
1142 case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */
1143 if (strEQ(name2, "NICODE"))
1145 if (strEQ(name2, "TF8LOCALE"))
1147 if (strEQ(name2, "TF8CACHE"))
1150 case '\027': /* $^WARNING_BITS */
1151 if (strEQ(name2, "ARNING_BITS"))
1164 /* ensures variable is only digits */
1165 /* ${"1foo"} fails this test (and is thus writeable) */
1166 /* added by japhy, but borrowed from is_gv_magical */
1167 const char *end = name + len;
1168 while (--end > name) {
1169 if (!isDIGIT(*end)) return gv;
1176 /* Names of length 1. (Or 0. But name is NUL terminated, so that will
1177 be case '\0' in this switch statement (ie a default case) */
1183 sv_type == SVt_PVAV ||
1184 sv_type == SVt_PVHV ||
1185 sv_type == SVt_PVCV ||
1186 sv_type == SVt_PVFM ||
1189 PL_sawampersand = TRUE;
1193 sv_setpv(GvSVn(gv),PL_chopset);
1197 #ifdef COMPLEX_STATUS
1198 SvUPGRADE(GvSVn(gv), SVt_PVLV);
1204 /* If %! has been used, automatically load Errno.pm. */
1206 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1208 /* magicalization must be done before require_tie_mod is called */
1209 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1210 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1215 GvMULTI_on(gv); /* no used once warnings here */
1217 AV* const av = GvAVn(gv);
1218 SV* const avc = (*name == '+') ? (SV*)av : NULL;
1220 sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0);
1221 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1223 SvREADONLY_on(GvSVn(gv));
1226 if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1227 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
1233 if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1234 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1235 "$%c is no longer supported", *name);
1238 sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1241 case '\010': /* $^H */
1243 HV *const hv = GvHVn(gv);
1244 hv_magic(hv, NULL, PERL_MAGIC_hints);
1247 case '\023': /* $^S */
1258 SvREADONLY_on(GvSVn(gv));
1273 case '\001': /* $^A */
1274 case '\003': /* $^C */
1275 case '\004': /* $^D */
1276 case '\005': /* $^E */
1277 case '\006': /* $^F */
1278 case '\011': /* $^I, NOT \t in EBCDIC */
1279 case '\016': /* $^N */
1280 case '\017': /* $^O */
1281 case '\020': /* $^P */
1282 case '\024': /* $^T */
1283 case '\027': /* $^W */
1285 sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1288 case '\014': /* $^L */
1289 sv_setpvn(GvSVn(gv),"\f",1);
1290 PL_formfeed = GvSVn(gv);
1293 sv_setpvn(GvSVn(gv),"\034",1);
1297 SV * const sv = GvSVn(gv);
1298 if (!sv_derived_from(PL_patchlevel, "version"))
1299 upg_version(PL_patchlevel, TRUE);
1300 GvSV(gv) = vnumify(PL_patchlevel);
1301 SvREADONLY_on(GvSV(gv));
1305 case '\026': /* $^V */
1307 SV * const sv = GvSVn(gv);
1308 GvSV(gv) = new_version(PL_patchlevel);
1309 SvREADONLY_on(GvSV(gv));
1319 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1323 const HV * const hv = GvSTASH(gv);
1328 sv_setpv(sv, prefix ? prefix : "");
1330 name = HvNAME_get(hv);
1332 namelen = HvNAMELEN_get(hv);
1338 if (keepmain || strNE(name, "main")) {
1339 sv_catpvn(sv,name,namelen);
1342 sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1346 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1348 const GV * const egv = GvEGV(gv);
1349 gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1357 IO * const io = (IO*)newSV_type(SVt_PVIO);
1358 /* This used to read SvREFCNT(io) = 1;
1359 It's not clear why the reference count needed an explicit reset. NWC
1361 assert (SvREFCNT(io) == 1);
1363 /* Clear the stashcache because a new IO could overrule a package name */
1364 hv_clear(PL_stashcache);
1365 iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1366 /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1367 if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1368 iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1369 SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1374 Perl_gv_check(pTHX_ const HV *stash)
1379 if (!HvARRAY(stash))
1381 for (i = 0; i <= (I32) HvMAX(stash); i++) {
1383 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1386 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1387 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1389 if (hv != PL_defstash && hv != stash)
1390 gv_check(hv); /* nested package */
1392 else if (isALPHA(*HeKEY(entry))) {
1394 gv = (GV*)HeVAL(entry);
1395 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1398 CopLINE_set(PL_curcop, GvLINE(gv));
1400 CopFILE(PL_curcop) = (char *)file; /* set for warning */
1402 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1404 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1405 "Name \"%s::%s\" used only once: possible typo",
1406 HvNAME_get(stash), GvNAME(gv));
1413 Perl_newGVgen(pTHX_ const char *pack)
1416 return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1420 /* hopefully this is only called on local symbol table entries */
1423 Perl_gp_ref(pTHX_ GP *gp)
1431 /* If the GP they asked for a reference to contains
1432 a method cache entry, clear it first, so that we
1433 don't infect them with our cached entry */
1434 SvREFCNT_dec(gp->gp_cv);
1443 Perl_gp_free(pTHX_ GV *gv)
1448 if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1450 if (gp->gp_refcnt == 0) {
1451 if (ckWARN_d(WARN_INTERNAL))
1452 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1453 "Attempt to free unreferenced glob pointers"
1454 pTHX__FORMAT pTHX__VALUE);
1457 if (--gp->gp_refcnt > 0) {
1458 if (gp->gp_egv == gv)
1464 if (gp->gp_file_hek)
1465 unshare_hek(gp->gp_file_hek);
1466 SvREFCNT_dec(gp->gp_sv);
1467 SvREFCNT_dec(gp->gp_av);
1468 /* FIXME - another reference loop GV -> symtab -> GV ?
1469 Somehow gp->gp_hv can end up pointing at freed garbage. */
1470 if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1471 const char *hvname = HvNAME_get(gp->gp_hv);
1472 if (PL_stashcache && hvname)
1473 hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1475 SvREFCNT_dec(gp->gp_hv);
1477 SvREFCNT_dec(gp->gp_io);
1478 SvREFCNT_dec(gp->gp_cv);
1479 SvREFCNT_dec(gp->gp_form);
1486 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1488 AMT * const amtp = (AMT*)mg->mg_ptr;
1489 PERL_UNUSED_ARG(sv);
1491 if (amtp && AMT_AMAGIC(amtp)) {
1493 for (i = 1; i < NofAMmeth; i++) {
1494 CV * const cv = amtp->table[i];
1496 SvREFCNT_dec((SV *) cv);
1497 amtp->table[i] = NULL;
1504 /* Updates and caches the CV's */
1507 Perl_Gv_AMupdate(pTHX_ HV *stash)
1510 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1514 newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen;
1516 const AMT * const amtp = (AMT*)mg->mg_ptr;
1517 if (amtp->was_ok_am == PL_amagic_generation
1518 && amtp->was_ok_sub == newgen) {
1519 return (bool)AMT_OVERLOADED(amtp);
1521 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1524 DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1527 amt.was_ok_am = PL_amagic_generation;
1528 amt.was_ok_sub = newgen;
1529 amt.fallback = AMGfallNO;
1533 int filled = 0, have_ovl = 0;
1536 /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1538 /* Try to find via inheritance. */
1539 GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1540 SV * const sv = gv ? GvSV(gv) : NULL;
1544 lim = DESTROY_amg; /* Skip overloading entries. */
1545 #ifdef PERL_DONT_CREATE_GVSV
1547 NOOP; /* Equivalent to !SvTRUE and !SvOK */
1550 else if (SvTRUE(sv))
1551 amt.fallback=AMGfallYES;
1553 amt.fallback=AMGfallNEVER;
1555 for (i = 1; i < lim; i++)
1556 amt.table[i] = NULL;
1557 for (; i < NofAMmeth; i++) {
1558 const char * const cooky = PL_AMG_names[i];
1559 /* Human-readable form, for debugging: */
1560 const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1561 const STRLEN l = strlen(cooky);
1563 DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1564 cp, HvNAME_get(stash)) );
1565 /* don't fill the cache while looking up!
1566 Creation of inheritance stubs in intermediate packages may
1567 conflict with the logic of runtime method substitution.
1568 Indeed, for inheritance A -> B -> C, if C overloads "+0",
1569 then we could have created stubs for "(+0" in A and C too.
1570 But if B overloads "bool", we may want to use it for
1571 numifying instead of C's "+0". */
1572 if (i >= DESTROY_amg)
1573 gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1574 else /* Autoload taken care of below */
1575 gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1577 if (gv && (cv = GvCV(gv))) {
1579 if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1580 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1581 /* This is a hack to support autoloading..., while
1582 knowing *which* methods were declared as overloaded. */
1583 /* GvSV contains the name of the method. */
1585 SV *gvsv = GvSV(gv);
1587 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1588 "\" for overloaded \"%s\" in package \"%.256s\"\n",
1589 (void*)GvSV(gv), cp, hvname) );
1590 if (!gvsv || !SvPOK(gvsv)
1591 || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1594 /* Can be an import stub (created by "can"). */
1595 const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???";
1596 Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1597 "in package \"%.256s\"",
1598 (GvCVGEN(gv) ? "Stub found while resolving"
1602 cv = GvCV(gv = ngv);
1604 DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1605 cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1606 GvNAME(CvGV(cv))) );
1608 if (i < DESTROY_amg)
1610 } else if (gv) { /* Autoloaded... */
1614 amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1617 AMT_AMAGIC_on(&amt);
1619 AMT_OVERLOADED_on(&amt);
1620 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1621 (char*)&amt, sizeof(AMT));
1625 /* Here we have no table: */
1627 AMT_AMAGIC_off(&amt);
1628 sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1629 (char*)&amt, sizeof(AMTS));
1635 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1642 if (!stash || !HvNAME_get(stash))
1645 newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen;
1647 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1651 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1654 amtp = (AMT*)mg->mg_ptr;
1655 if ( amtp->was_ok_am != PL_amagic_generation
1656 || amtp->was_ok_sub != newgen )
1658 if (AMT_AMAGIC(amtp)) {
1659 CV * const ret = amtp->table[id];
1660 if (ret && isGV(ret)) { /* Autoloading stab */
1661 /* Passing it through may have resulted in a warning
1662 "Inherited AUTOLOAD for a non-method deprecated", since
1663 our caller is going through a function call, not a method call.
1664 So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1665 GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1678 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1683 CV **cvp=NULL, **ocvp=NULL;
1684 AMT *amtp=NULL, *oamtp=NULL;
1685 int off = 0, off1, lr = 0, notfound = 0;
1686 int postpr = 0, force_cpy = 0;
1687 int assign = AMGf_assign & flags;
1688 const int assignshift = assign ? 1 : 0;
1693 if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1694 && (stash = SvSTASH(SvRV(left)))
1695 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1696 && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1697 ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1699 && ((cv = cvp[off=method+assignshift])
1700 || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1706 cv = cvp[off=method])))) {
1707 lr = -1; /* Call method for left argument */
1709 if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1712 /* look for substituted methods */
1713 /* In all the covered cases we should be called with assign==0. */
1717 if ((cv = cvp[off=add_ass_amg])
1718 || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1719 right = &PL_sv_yes; lr = -1; assign = 1;
1724 if ((cv = cvp[off = subtr_ass_amg])
1725 || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1726 right = &PL_sv_yes; lr = -1; assign = 1;
1730 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1733 (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1736 (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1739 (void)((cv = cvp[off=bool__amg])
1740 || (cv = cvp[off=numer_amg])
1741 || (cv = cvp[off=string_amg]));
1747 * SV* ref causes confusion with the interpreter variable of
1750 SV* const tmpRef=SvRV(left);
1751 if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1753 * Just to be extra cautious. Maybe in some
1754 * additional cases sv_setsv is safe, too.
1756 SV* const newref = newSVsv(tmpRef);
1757 SvOBJECT_on(newref);
1758 /* As a bit of a source compatibility hack, SvAMAGIC() and
1759 friends dereference an RV, to behave the same was as when
1760 overloading was stored on the reference, not the referant.
1761 Hence we can't use SvAMAGIC_on()
1763 SvFLAGS(newref) |= SVf_AMAGIC;
1764 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1770 if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1771 && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1772 SV* const nullsv=sv_2mortal(newSViv(0));
1774 SV* const lessp = amagic_call(left,nullsv,
1775 lt_amg,AMGf_noright);
1776 logic = SvTRUE(lessp);
1778 SV* const lessp = amagic_call(left,nullsv,
1779 ncmp_amg,AMGf_noright);
1780 logic = (SvNV(lessp) < 0);
1783 if (off==subtr_amg) {
1794 if ((cv = cvp[off=subtr_amg])) {
1796 left = sv_2mortal(newSViv(0));
1801 case iter_amg: /* XXXX Eventually should do to_gv. */
1803 return NULL; /* Delegate operation to standard mechanisms. */
1811 return left; /* Delegate operation to standard mechanisms. */
1816 if (!cv) goto not_found;
1817 } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1818 && (stash = SvSTASH(SvRV(right)))
1819 && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1820 && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1821 ? (amtp = (AMT*)mg->mg_ptr)->table
1823 && (cv = cvp[off=method])) { /* Method for right
1826 } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1827 && (cvp=ocvp) && (lr = -1))
1828 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1829 && !(flags & AMGf_unary)) {
1830 /* We look for substitution for
1831 * comparison operations and
1833 if (method==concat_amg || method==concat_ass_amg
1834 || method==repeat_amg || method==repeat_ass_amg) {
1835 return NULL; /* Delegate operation to string conversion */
1845 postpr = 1; off=ncmp_amg; break;
1852 postpr = 1; off=scmp_amg; break;
1854 if (off != -1) cv = cvp[off];
1859 not_found: /* No method found, either report or croak */
1880 return left; /* Delegate operation to standard mechanisms. */
1883 if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1884 notfound = 1; lr = -1;
1885 } else if (cvp && (cv=cvp[nomethod_amg])) {
1886 notfound = 1; lr = 1;
1887 } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1888 /* Skip generating the "no method found" message. */
1892 if (off==-1) off=method;
1893 msg = sv_2mortal(Perl_newSVpvf(aTHX_
1894 "Operation \"%s\": no method found,%sargument %s%s%s%s",
1895 AMG_id2name(method + assignshift),
1896 (flags & AMGf_unary ? " " : "\n\tleft "),
1898 "in overloaded package ":
1899 "has no overloaded magic",
1901 HvNAME_get(SvSTASH(SvRV(left))):
1904 ",\n\tright argument in overloaded package ":
1907 : ",\n\tright argument has no overloaded magic"),
1909 HvNAME_get(SvSTASH(SvRV(right))):
1911 if (amtp && amtp->fallback >= AMGfallYES) {
1912 DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1914 Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1918 force_cpy = force_cpy || assign;
1923 DEBUG_o(Perl_deb(aTHX_
1924 "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1926 method+assignshift==off? "" :
1928 method+assignshift==off? "" :
1929 AMG_id2name(method+assignshift),
1930 method+assignshift==off? "" : "\")",
1931 flags & AMGf_unary? "" :
1932 lr==1 ? " for right argument": " for left argument",
1933 flags & AMGf_unary? " for argument" : "",
1934 stash ? HvNAME_get(stash) : "null",
1935 fl? ",\n\tassignment variant used": "") );
1938 /* Since we use shallow copy during assignment, we need
1939 * to dublicate the contents, probably calling user-supplied
1940 * version of copy operator
1942 /* We need to copy in following cases:
1943 * a) Assignment form was called.
1944 * assignshift==1, assign==T, method + 1 == off
1945 * b) Increment or decrement, called directly.
1946 * assignshift==0, assign==0, method + 0 == off
1947 * c) Increment or decrement, translated to assignment add/subtr.
1948 * assignshift==0, assign==T,
1950 * d) Increment or decrement, translated to nomethod.
1951 * assignshift==0, assign==0,
1953 * e) Assignment form translated to nomethod.
1954 * assignshift==1, assign==T, method + 1 != off
1957 /* off is method, method+assignshift, or a result of opcode substitution.
1958 * In the latter case assignshift==0, so only notfound case is important.
1960 if (( (method + assignshift == off)
1961 && (assign || (method == inc_amg) || (method == dec_amg)))
1968 const bool oldcatch = CATCH_GET;
1971 Zero(&myop, 1, BINOP);
1972 myop.op_last = (OP *) &myop;
1973 myop.op_next = NULL;
1974 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1976 PUSHSTACKi(PERLSI_OVERLOAD);
1979 PL_op = (OP *) &myop;
1980 if (PERLDB_SUB && PL_curstash != PL_debstash)
1981 PL_op->op_private |= OPpENTERSUB_DB;
1985 EXTEND(SP, notfound + 5);
1986 PUSHs(lr>0? right: left);
1987 PUSHs(lr>0? left: right);
1988 PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1990 PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1995 if ((PL_op = Perl_pp_entersub(aTHX)))
2003 CATCH_SET(oldcatch);
2010 ans=SvIV(res)<=0; break;
2013 ans=SvIV(res)<0; break;
2016 ans=SvIV(res)>=0; break;
2019 ans=SvIV(res)>0; break;
2022 ans=SvIV(res)==0; break;
2025 ans=SvIV(res)!=0; break;
2028 SvSetSV(left,res); return left;
2030 ans=!SvTRUE(res); break;
2035 } else if (method==copy_amg) {
2037 Perl_croak(aTHX_ "Copy method did not return a reference");
2039 return SvREFCNT_inc(SvRV(res));
2047 =for apidoc is_gv_magical_sv
2049 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2055 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2058 const char * const temp = SvPV_const(name, len);
2059 return is_gv_magical(temp, len, flags);
2063 =for apidoc is_gv_magical
2065 Returns C<TRUE> if given the name of a magical GV.
2067 Currently only useful internally when determining if a GV should be
2068 created even in rvalue contexts.
2070 C<flags> is not used at present but available for future extension to
2071 allow selecting particular classes of magical variable.
2073 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2074 This assumption is met by all callers within the perl core, which all pass
2075 pointers returned by SvPV.
2080 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2082 PERL_UNUSED_CONTEXT;
2083 PERL_UNUSED_ARG(flags);
2086 const char * const name1 = name + 1;
2089 if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2093 if (len == 8 && strEQ(name1, "VERLOAD"))
2097 if (len == 3 && name[1] == 'I' && name[2] == 'G')
2100 /* Using ${^...} variables is likely to be sufficiently rare that
2101 it seems sensible to avoid the space hit of also checking the
2103 case '\017': /* ${^OPEN} */
2104 if (strEQ(name1, "PEN"))
2107 case '\024': /* ${^TAINT} */
2108 if (strEQ(name1, "AINT"))
2111 case '\025': /* ${^UNICODE} */
2112 if (strEQ(name1, "NICODE"))
2114 if (strEQ(name1, "TF8LOCALE"))
2117 case '\027': /* ${^WARNING_BITS} */
2118 if (strEQ(name1, "ARNING_BITS"))
2131 const char *end = name + len;
2132 while (--end > name) {
2140 /* Because we're already assuming that name is NUL terminated
2141 below, we can treat an empty name as "\0" */
2168 case '\001': /* $^A */
2169 case '\003': /* $^C */
2170 case '\004': /* $^D */
2171 case '\005': /* $^E */
2172 case '\006': /* $^F */
2173 case '\010': /* $^H */
2174 case '\011': /* $^I, NOT \t in EBCDIC */
2175 case '\014': /* $^L */
2176 case '\016': /* $^N */
2177 case '\017': /* $^O */
2178 case '\020': /* $^P */
2179 case '\023': /* $^S */
2180 case '\024': /* $^T */
2181 case '\026': /* $^V */
2182 case '\027': /* $^W */
2202 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2208 PERL_UNUSED_ARG(flags);
2211 Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2213 if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2214 unshare_hek(GvNAME_HEK(gv));
2217 PERL_HASH(hash, name, len);
2218 GvNAME_HEK(gv) = share_hek(name, len, hash);
2223 * c-indentation-style: bsd
2225 * indent-tabs-mode: t
2228 * ex: set ts=8 sts=4 sw=4 noet: