/* gv.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* laughed Pippin.
*/
+/*
+=head1 GV Functions
+*/
+
#include "EXTERN.h"
#define PERL_IN_GV_C
#include "perl.h"
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
Perl_croak(aTHX_ "Bad symbol for filehandle");
if (!GvIOp(gv)) {
-#ifdef GV_SHARED_CHECK
- if (GvSHARED(gv)) {
- Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE(gv)) {
+ Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
}
#endif
GvIOp(gv) = newIO();
tmpbuf = smallbuf;
else
New(603, tmpbuf, tmplen + 1, char);
+ /* This is where the debugger's %{"::_<$filename"} hash is created */
tmpbuf[0] = '_';
tmpbuf[1] = '<';
strcpy(tmpbuf + 2, name);
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
if (PERLDB_LINE)
- hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
+ hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile);
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
- sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
+ sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
- CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
+ CvFILE_set_from_cop(GvCV(gv), PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
-#ifdef USE_THREADS
- CvOWNER(GvCV(gv)) = 0;
- if (!CvMUTEXP(GvCV(gv))) {
- New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(GvCV(gv)));
- }
-#endif /* USE_THREADS */
if (proto) {
sv_setpv((SV*)GvCV(gv), proto);
Safefree(proto);
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
-accessible via @ISA and @UNIVERSAL.
+accessible via @ISA and UNIVERSAL::.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
GV** gvp;
CV* cv;
- if (!stash)
- return 0;
+ /* UNIVERSAL methods should be callable without a stash */
+ if (!stash) {
+ level = -1; /* probably appropriate */
+ if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
+ return 0;
+ }
+
if (!HvNAME(stash))
- Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+ Perl_croak(aTHX_
+ "Can't use anonymous symbol table for method lookup");
+
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
- SvPVX(sv), HvNAME(stash));
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
+ sv, HvNAME(stash));
continue;
}
gv = gv_fetchmeth(basestash, name, len,
}
/*
+=for apidoc gv_fetchmeth_autoload
+
+Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
+Returns a glob for the subroutine.
+
+For an autoloaded subroutine without a GV, will create a GV even
+if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
+of the result may be zero.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+{
+ GV *gv = gv_fetchmeth(stash, name, len, level);
+
+ if (!gv) {
+ char autoload[] = "AUTOLOAD";
+ STRLEN autolen = sizeof(autoload)-1;
+ CV *cv;
+ GV **gvp;
+
+ if (!stash)
+ return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */
+ if (len == autolen && strnEQ(name, autoload, autolen))
+ return Nullgv;
+ if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
+ return Nullgv;
+ cv = GvCV(gv);
+ if (!(CvROOT(cv) || CvXSUB(cv)))
+ return Nullgv;
+ /* Have an autoload */
+ if (level < 0) /* Cannot do without a stub */
+ gv_fetchmeth(stash, name, len, 0);
+ gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+ if (!gvp)
+ return Nullgv;
+ return *gvp;
+ }
+ return gv;
+}
+
+/*
=for apidoc gv_fetchmethod
See L<gv_fetchmethod_autoload>.
register const char *nend;
const char *nsplit = 0;
GV* gv;
+ HV* ostash = stash;
+
+ if (stash && SvTYPE(stash) < SVt_PVHV)
+ stash = Nullhv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
+ /* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
- else
- stash = gv_stashpvn(origname, nsplit - origname, TRUE);
+ else {
+ /* don't autovifify if ->NoSuchStash::method */
+ stash = gv_stashpvn(origname, nsplit - origname, FALSE);
+
+ /* however, explicit calls to Pkg::SUPER::method may
+ happen, and may require autovivification to work */
+ if (!stash && (nsplit - origname) >= 7 &&
+ strnEQ(nsplit - 7, "::SUPER", 7) &&
+ gv_stashpvn(origname, nsplit - origname - 7, FALSE))
+ stash = gv_stashpvn(origname, nsplit - origname, TRUE);
+ }
+ ostash = stash;
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
- gv = gv_autoload4(stash, name, nend - name, TRUE);
+ gv = gv_autoload4(ostash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
- static char autoload[] = "AUTOLOAD";
- static STRLEN autolen = 8;
+ char autoload[] = "AUTOLOAD";
+ STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
+ char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
+ if (stash) {
+ if (SvTYPE(stash) < SVt_PVHV) {
+ packname = SvPV_nolen((SV*)stash);
+ stash = Nullhv;
+ }
+ else {
+ packname = HvNAME(stash);
+ }
+ }
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
- if (ckWARN(WARN_DEPRECATED) && !method &&
+ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
- HvNAME(stash), (int)len, name);
+ packname, (int)len, name);
-#ifndef USE_THREADS
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
- SvPVX(cv) = (char *)name; /* cast to loose constness warning */
+ SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
-#endif
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
-#ifdef USE_THREADS
- sv_lock((SV *)varstash);
-#endif
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
-#ifdef USE_THREADS
- sv_lock(varsv);
-#endif
- sv_setpv(varsv, HvNAME(stash));
+ sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
PUTBACK;
ENTER;
save_scalar(gv); /* keep the value of $! */
- require_pv("Errno.pm");
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvn("Errno",5), Nullsv);
LEAVE;
SPAGAIN;
stash = gv_stashpvn("Errno",5,FALSE);
char smallbuf[256];
char *tmpbuf;
- if (len + 3 < sizeof smallbuf)
+ if (len + 3 < sizeof (smallbuf))
tmpbuf = smallbuf;
else
New(601, tmpbuf, len+3, char);
}
}
len = namend - name;
- if (!len)
- len = 1;
+
+ /* $_ should always be in main:: even when our'ed */
+ if (*name == '_' && !name[1])
+ stash = PL_defstash;
/* No stash in name, so see how we can default */
if (global)
stash = PL_defstash;
- else if ((COP*)PL_curcop == &PL_compiling) {
+ else if (IN_PERL_COMPILETIME) {
stash = PL_curstash;
if (add && (PL_hints & HINT_STRICT_VARS) &&
sv_type != SVt_PVCV &&
if (!stash) {
if (add) {
- qerror(Perl_mess(aTHX_
+ register SV *err = Perl_mess(aTHX_
"Global symbol \"%s%s\" requires explicit package name",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), name));
- stash = PL_nullstash;
+ : ""), name);
+ if (USE_UTF8_IN_NAMES)
+ SvUTF8_on(err);
+ qerror(err);
+ stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
}
else
return Nullgv;
/* Adding a new symbol */
if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
gv_init(gv, stash, name, len, add & GV_ADDMULTI);
gv_init_sv(gv, sv_type);
if (strEQ(name, "ISA")) {
AV* av = GvAVn(gv);
GvMULTI_on(gv);
- sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
+ sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
/* NOTE: No support for tied ISA */
if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
&& AvFILLp(av) == -1)
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
GvMULTI_on(gv);
- hv_magic(hv, Nullgv, 'A');
+ hv_magic(hv, Nullgv, PERL_MAGIC_overload);
}
break;
case 'S':
}
GvMULTI_on(gv);
hv = GvHVn(gv);
- hv_magic(hv, Nullgv, 'S');
+ hv_magic(hv, Nullgv, PERL_MAGIC_sig);
for (i = 1; i < SIG_SIZE; i++) {
SV ** init;
init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
break;
case '&':
- if (len > 1)
- break;
- PL_sawampersand = TRUE;
- goto ro_magicalize;
-
case '`':
- if (len > 1)
- break;
- PL_sawampersand = TRUE;
- goto ro_magicalize;
-
case '\'':
- if (len > 1)
- break;
+ if (
+ len > 1 ||
+ sv_type == SVt_PVAV ||
+ sv_type == SVt_PVHV ||
+ sv_type == SVt_PVCV ||
+ sv_type == SVt_PVFM ||
+ sv_type == SVt_PVIO
+ ) { break; }
PL_sawampersand = TRUE;
goto ro_magicalize;
now (rather than going to magicalize)
*/
- sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
if (sv_type == SVt_PVHV)
require_errno(gv);
break;
else {
AV* av = GvAVn(gv);
- sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
+ sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
}
goto magicalize;
- case '#':
case '*':
- if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
- Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
+ if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ "$* is no longer supported");
+ break;
+ case '#':
+ if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ "Use of $# is deprecated");
/* FALL THROUGH */
case '[':
case '^':
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
- case '\005': /* $^E */
case '\006': /* $^F */
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
+ case '\016': /* $^N */
case '\020': /* $^P */
- case '\024': /* $^T */
if (len > 1)
break;
goto magicalize;
break;
sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
goto magicalize;
+ case '\005': /* $^E && $^ENCODING */
+ if (len > 1 && strNE(name, "\005NCODING"))
+ break;
+ goto magicalize;
+
case '\017': /* $^O & $^OPEN */
if (len > 1 && strNE(name, "\017PEN"))
break;
if (len > 1)
break;
goto ro_magicalize;
+ case '\024': /* $^T, ${^TAINT} */
+ if (len == 1)
+ goto magicalize;
+ else if (strEQ(name, "\024AINT"))
+ goto ro_magicalize;
+ else
+ break;
+ case '\025':
+ if (len > 1 && strNE(name, "\025NICODE"))
+ break;
+ goto ro_magicalize;
+
case '\027': /* $^W & $^WARNING_BITS */
- if (len > 1 && strNE(name, "\027ARNING_BITS")
- && strNE(name, "\027IDE_SYSTEM_CALLS"))
+ if (len > 1
+ && strNE(name, "\027ARNING_BITS")
+ )
break;
goto magicalize;
break;
else {
AV* av = GvAVn(gv);
- sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
+ sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
SvREADONLY_on(av);
}
/* FALL THROUGH */
case '7':
case '8':
case '9':
+ /* ensures variable is only digits */
+ /* ${"1foo"} fails this test (and is thus writeable) */
+ /* added by japhy, but borrowed from is_gv_magical */
+
+ if (len > 1) {
+ const char *end = name + len;
+ while (--end > name) {
+ if (!isDIGIT(*end)) return gv;
+ }
+ }
+
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
- sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
break;
case '\014': /* $^L */
void
Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
{
+ char *name;
HV *hv = GvSTASH(gv);
if (!hv) {
(void)SvOK_off(sv);
return;
}
sv_setpv(sv, prefix ? prefix : "");
- if (keepmain || strNE(HvNAME(hv), "main")) {
- sv_catpv(sv,HvNAME(hv));
+
+ if (!HvNAME(hv))
+ name = "__ANON__";
+ else
+ name = HvNAME(hv);
+ if (keepmain || strNE(name, "main")) {
+ sv_catpv(sv,name);
sv_catpvn(sv,"::", 2);
}
- sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+ if (((unsigned int)*GvNAME(gv)) <= 26) { /* handle $^FOO */
+ Perl_sv_catpvf(aTHX_ sv,"^%c", *GvNAME(gv) + 'A' - 1);
+ sv_catpvn(sv,GvNAME(gv)+1,GvNAMELEN(gv)-1);
+ }
+ else
+ sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+
}
void
Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
{
- HV *hv = GvSTASH(gv);
- if (!hv) {
- (void)SvOK_off(sv);
- return;
- }
- sv_setpv(sv, prefix ? prefix : "");
- sv_catpv(sv,HvNAME(hv));
- sv_catpvn(sv,"::", 2);
- sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+ gv_fullname4(sv, gv, prefix, TRUE);
}
void
void
Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
{
- GV *egv = GvEGV(gv);
- if (!egv)
- egv = gv;
- gv_fullname3(sv, egv, prefix);
+ gv_efullname4(sv, gv, prefix, TRUE);
}
/* XXX compatibility with versions <= 5.003. */
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
+ /* Clear the stashcache because a new IO could overrule a
+ package name */
+ hv_clear(PL_stashcache);
iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
/* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
- (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
+ (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
{
if (hv != PL_defstash && hv != stash)
gv_check(hv); /* nested package */
#else
CopFILEGV(PL_curcop) = gv_fetchfile(file);
#endif
- Perl_warner(aTHX_ WARN_ONCE,
+ Perl_warner(aTHX_ packWARN(WARN_ONCE),
"Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
return;
if (gp->gp_refcnt == 0) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free unreferenced glob pointers");
return;
}
return;
}
- SvREFCNT_dec(gp->gp_sv);
- SvREFCNT_dec(gp->gp_av);
- SvREFCNT_dec(gp->gp_hv);
- SvREFCNT_dec(gp->gp_io);
- SvREFCNT_dec(gp->gp_cv);
- SvREFCNT_dec(gp->gp_form);
+ if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
+ if (gp->gp_sv) SvREFCNT_dec(gp->gp_av);
+ if (gp->gp_hv) {
+ if (PL_stashcache && HvNAME(gp->gp_hv))
+ hv_delete(PL_stashcache,
+ HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
+ G_DISCARD);
+ SvREFCNT_dec(gp->gp_hv);
+ }
+ if (gp->gp_io) SvREFCNT_dec(gp->gp_io);
+ if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv);
+ if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
Safefree(gp);
GvGP(gv) = 0;
}
-#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
-#define MICROPORT
-#endif
-
-#ifdef MICROPORT /* Microport 2.4 hack */
-AV *GvAVn(gv)
-register GV *gv;
-{
- if (GvGP(gv)->gp_av)
- return GvGP(gv)->gp_av;
- else
- return GvGP(gv_AVadd(gv))->gp_av;
-}
-
-HV *GvHVn(gv)
-register GV *gv;
-{
- if (GvGP(gv)->gp_hv)
- return GvGP(gv)->gp_hv;
- else
- return GvGP(gv_HVadd(gv))->gp_hv;
-}
-#endif /* Microport 2.4 hack */
-
int
Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
{
{
GV* gv;
CV* cv;
- MAGIC* mg=mg_find((SV*)stash,'c');
+ MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
- STRLEN n_a;
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
- return AMT_OVERLOADED(amtp);
- sv_unmagic((SV*)stash, 'c');
+ return (bool)AMT_OVERLOADED(amtp);
+ sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
cp, HvNAME(stash)) );
- /* don't fill the cache while looking up! */
- gv = gv_fetchmeth(stash, cooky, l, -1);
+ /* don't fill the cache while looking up!
+ Creation of inheritance stubs in intermediate packages may
+ conflict with the logic of runtime method substitution.
+ Indeed, for inheritance A -> B -> C, if C overloads "+0",
+ then we could have created stubs for "(+0" in A and C too.
+ But if B overloads "bool", we may want to use it for
+ numifying instead of C's "+0". */
+ if (i >= DESTROY_amg)
+ gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
+ else /* Autoload taken care of below */
+ gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
cv = 0;
if (gv && (cv = GvCV(gv))) {
if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+ /* This is a hack to support autoloading..., while
+ knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
- GV *ngv;
+ GV *ngv = Nullgv;
- DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
- SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
+ DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
+ "' for overloaded `%s' in package `%.256s'\n",
+ GvSV(gv), cp, HvNAME(stash)) );
if (!SvPOK(GvSV(gv))
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
FALSE)))
{
/* Can be an import stub (created by `can'). */
- if (GvCVGEN(gv)) {
- Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
- (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
- cp, HvNAME(stash));
- } else
- Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
- (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
- cp, HvNAME(stash));
+ SV *gvsv = GvSV(gv);
+ const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???";
+ Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
+ "in package `%.256s'",
+ (GvCVGEN(gv) ? "Stub found while resolving"
+ : "Can't resolve"),
+ name, cp, HvNAME(stash));
}
cv = GvCV(gv = ngv);
}
filled = 1;
if (i < DESTROY_amg)
have_ovl = 1;
+ } else if (gv) { /* Autoloaded... */
+ cv = (CV*)gv;
+ filled = 1;
}
amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
AMT_AMAGIC_on(&amt);
if (have_ovl)
AMT_OVERLOADED_on(&amt);
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
+ sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
+ (char*)&amt, sizeof(AMT));
return have_ovl;
}
}
/* Here we have no table: */
/* no_table: */
AMT_AMAGIC_off(&amt);
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
+ sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
+ (char*)&amt, sizeof(AMTS));
return FALSE;
}
{
MAGIC *mg;
AMT *amtp;
+ CV *ret;
- if (!stash)
+ if (!stash || !HvNAME(stash))
return Nullcv;
- mg = mg_find((SV*)stash,'c');
+ mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
if (!mg) {
do_update:
Gv_AMupdate(stash);
- mg = mg_find((SV*)stash,'c');
+ mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
}
amtp = (AMT*)mg->mg_ptr;
if ( amtp->was_ok_am != PL_amagic_generation
|| amtp->was_ok_sub != PL_sub_generation )
goto do_update;
- if (AMT_AMAGIC(amtp))
- return amtp->table[id];
+ if (AMT_AMAGIC(amtp)) {
+ ret = amtp->table[id];
+ if (ret && isGV(ret)) { /* Autoloading stab */
+ /* Passing it through may have resulted in a warning
+ "Inherited AUTOLOAD for a non-method deprecated", since
+ our caller is going through a function call, not a method call.
+ So return the CV for AUTOLOAD, setting $AUTOLOAD. */
+ GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
+
+ if (gv && GvCV(gv))
+ return GvCV(gv);
+ }
+ return ret;
+ }
+
return Nullcv;
}
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
MAGIC *mg;
- CV *cv;
+ CV *cv=NULL;
CV **cvp=NULL, **ocvp=NULL;
- AMT *amtp, *oamtp;
- int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
+ AMT *amtp=NULL, *oamtp=NULL;
+ int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
- HV* stash;
+#ifdef DEBUGGING
+ int fl=0;
+#endif
+ HV* stash=NULL;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
- && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
+ && (stash = SvSTASH(SvRV(left)))
+ && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
- (fl = 1, cv = cvp[off=method])))) {
+ (
+#ifdef DEBUGGING
+ fl = 1,
+#endif
+ cv = cvp[off=method])))) {
lr = -1; /* Call method for left argument */
} else {
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
}
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
- && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
+ && (stash = SvSTASH(SvRV(right)))
+ && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
: (CV **) NULL))
force_cpy = force_cpy || assign;
}
}
+#ifdef DEBUGGING
if (!notfound) {
- DEBUG_o( Perl_deb(aTHX_
- "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
- AMG_id2name(off),
- method+assignshift==off? "" :
- " (initially `",
- method+assignshift==off? "" :
- AMG_id2name(method+assignshift),
- method+assignshift==off? "" : "')",
- flags & AMGf_unary? "" :
- lr==1 ? " for right argument": " for left argument",
- flags & AMGf_unary? " for argument" : "",
- HvNAME(stash),
- fl? ",\n\tassignment variant used": "") );
+ DEBUG_o(Perl_deb(aTHX_
+ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
+ AMG_id2name(off),
+ method+assignshift==off? "" :
+ " (initially `",
+ method+assignshift==off? "" :
+ AMG_id2name(method+assignshift),
+ method+assignshift==off? "" : "')",
+ flags & AMGf_unary? "" :
+ lr==1 ? " for right argument": " for left argument",
+ flags & AMGf_unary? " for argument" : "",
+ stash ? HvNAME(stash) : "null",
+ fl? ",\n\tassignment variant used": "") );
}
+#endif
/* Since we use shallow copy during assignment, we need
* to dublicate the contents, probably calling user-supplied
* version of copy operator
CATCH_SET(oldcatch);
if (postpr) {
- int ans;
+ int ans=0;
switch (method) {
case le_amg:
case sle_amg:
break;
case '\017': /* $^O & $^OPEN */
if (len == 1
- || (len == 4 && strEQ(name, "\027PEN")))
+ || (len == 4 && strEQ(name, "\017PEN")))
{
goto yes;
}
break;
+ case '\025':
+ if (len > 1 && strEQ(name, "\025NICODE"))
+ goto yes;
case '\027': /* $^W & $^WARNING_BITS */
if (len == 1
|| (len == 12 && strEQ(name, "\027ARNING_BITS"))
- || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
+ )
{
goto yes;
}
case '!':
case '-':
case '#':
- case '*':
case '[':
case '^':
case '~':
case '\010': /* $^H */
case '\011': /* $^I, NOT \t in EBCDIC */
case '\014': /* $^L */
+ case '\016': /* $^N */
case '\020': /* $^P */
case '\023': /* $^S */
- case '\024': /* $^T */
case '\026': /* $^V */
if (len == 1)
goto yes;
break;
+ case '\024': /* $^T, ${^TAINT} */
+ if (len == 1 || strEQ(name, "\024AINT"))
+ goto yes;
+ break;
case '1':
case '2':
case '3':
https://perl5.git.perl.org / perl5.git / blobdiff