* history of Middle-earth and Over-heaven and of the Sundering Seas,'
* laughed Pippin.
*
- * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
+ * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
*/
/*
#define PERL_IN_GV_C
#include "perl.h"
#include "overload.c"
+#include "keywords.h"
static const char S_autoload[] = "AUTOLOAD";
static const STRLEN S_autolen = sizeof(S_autoload)-1;
* if it walks like a dirhandle, then let's assume that
* this is a dirhandle.
*/
- what = PL_op->op_type == OP_READDIR ||
- PL_op->op_type == OP_TELLDIR ||
- PL_op->op_type == OP_SEEKDIR ||
- PL_op->op_type == OP_REWINDDIR ||
- PL_op->op_type == OP_CLOSEDIR ?
+ what = OP_IS_DIRHOP(PL_op->op_type) ?
"dirhandle" : "filehandle";
/* diag_listed_as: Bad symbol for filehandle */
} else if (type == SVt_PVHV) {
}
void
-Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
+Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, int multi, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_GV_INIT_SV;
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv))
+ flags |= SVf_UTF8;
+ gv_init_pvn(gv, stash, namepv, namelen, multi, flags);
+}
+
+void
+Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, int multi, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_INIT_PV;
+ gv_init_pvn(gv, stash, name, strlen(name), multi, flags);
+}
+
+void
+Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi, U32 flags)
{
dVAR;
const U32 old_type = SvTYPE(gv);
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
- PERL_ARGS_ASSERT_GV_INIT;
+ PERL_ARGS_ASSERT_GV_INIT_PVN;
assert (!(proto && has_constant));
if (has_constant) {
SvIOK_off(gv);
isGV_with_GP_on(gv);
- GvGP(gv) = Perl_newGP(aTHX_ gv);
+ GvGP_set(gv, Perl_newGP(aTHX_ gv));
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
/* newCONSTSUB takes ownership of the reference from us. */
cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
+ /* In case op.c:S_process_special_blocks stole it: */
+ if (!GvCV(gv))
+ GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
if (name0)
Safefree(name0);
} else {
(void) start_subparse(0,0); /* Create empty CV in compcv. */
cv = PL_compcv;
- GvCV(gv) = cv;
+ GvCV_set(gv,cv);
}
LEAVE;
}
STATIC void
-S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
+S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
{
- PERL_ARGS_ASSERT_GV_INIT_SV;
+ PERL_ARGS_ASSERT_GV_INIT_SVTYPE;
switch (sv_type) {
case SVt_PVIO:
}
}
+static void core_xsub(pTHX_ CV* cv);
+
+static GV *
+S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
+ const char * const name, const STRLEN len,
+ const char * const fullname, STRLEN const fullen)
+{
+ const int code = keyword(name, len, 1);
+ static const char file[] = __FILE__;
+ CV *cv, *oldcompcv;
+ int opnum = 0;
+ SV *opnumsv;
+ bool ampable = TRUE; /* &{}-able */
+ COP *oldcurcop;
+ yy_parser *oldparser;
+ I32 oldsavestack_ix;
+
+ assert(gv || stash);
+ assert(name);
+ assert(stash || fullname);
+
+ if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
+ that would require
+ inlining newATTRSUB */
+ if (code >= 0) return NULL; /* not overridable */
+ switch (-code) {
+ /* no support for \&CORE::infix;
+ no support for funcs that take labels, as their parsing is
+ weird */
+ case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
+ case KEY_eq: case KEY_ge:
+ case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
+ case KEY_or: case KEY_x: case KEY_xor:
+ return NULL;
+ case KEY_chdir:
+ case KEY_chomp: case KEY_chop:
+ case KEY_each: case KEY_eof: case KEY_exec:
+ case KEY_keys:
+ case KEY_lstat:
+ case KEY_pop:
+ case KEY_push:
+ case KEY_shift:
+ case KEY_splice:
+ case KEY_stat:
+ case KEY_system:
+ case KEY_truncate: case KEY_unlink:
+ case KEY_unshift:
+ case KEY_values:
+ ampable = FALSE;
+ }
+ if (!gv) {
+ gv = (GV *)newSV(0);
+ gv_init(gv, stash, name, len, TRUE);
+ }
+ if (ampable) {
+ ENTER;
+ oldcurcop = PL_curcop;
+ oldparser = PL_parser;
+ lex_start(NULL, NULL, 0);
+ oldcompcv = PL_compcv;
+ PL_compcv = NULL; /* Prevent start_subparse from setting
+ CvOUTSIDE. */
+ oldsavestack_ix = start_subparse(FALSE,0);
+ cv = PL_compcv;
+ }
+ else {
+ /* Avoid calling newXS, as it calls us, and things start to
+ get hairy. */
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ GvCV_set(gv,cv);
+ GvCVGEN(gv) = 0;
+ mro_method_changed_in(GvSTASH(gv));
+ CvISXSUB_on(cv);
+ CvXSUB(cv) = core_xsub;
+ }
+ CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
+ from PL_curcop. */
+ (void)gv_fetchfile(file);
+ CvFILE(cv) = (char *)file;
+ /* XXX This is inefficient, as doing things this order causes
+ a prototype check in newATTRSUB. But we have to do
+ it this order as we need an op number before calling
+ new ATTRSUB. */
+ (void)core_prototype((SV *)cv, name, code, &opnum);
+ if (stash && (fullname || !fullen))
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ if (ampable) {
+ SV *tmpstr;
+ CvLVALUE_on(cv);
+ if (!fullname) {
+ tmpstr = newSVhek(HvENAME_HEK(stash));
+ sv_catpvs(tmpstr, "::");
+ sv_catpvn(tmpstr,name,len);
+ }
+ else tmpstr = newSVpvn_share(fullname,fullen,0);
+ newATTRSUB(oldsavestack_ix,
+ newSVOP(OP_CONST, 0, tmpstr),
+ NULL,NULL,
+ coresub_op(
+ opnum
+ ? newSVuv((UV)opnum)
+ : newSVpvn(name,len),
+ code, opnum
+ )
+ );
+ assert(GvCV(gv) == cv);
+ if (opnum != OP_VEC && opnum != OP_SUBSTR)
+ CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+ LEAVE;
+ PL_parser = oldparser;
+ PL_curcop = oldcurcop;
+ PL_compcv = oldcompcv;
+ }
+ opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+ cv_set_call_checker(
+ cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+ );
+ SvREFCNT_dec(opnumsv);
+ return gv;
+}
+
/*
=for apidoc gv_fetchmeth
HV* cstash;
GV* candidate = NULL;
CV* cand_cv = NULL;
- CV* old_cv;
GV* topgv = NULL;
const char *hvname;
I32 create = (level >= 0) ? 1 : 0;
gvp = (GV**)hv_fetch(stash, name, len, create);
if(gvp) {
topgv = *gvp;
+ have_gv:
assert(topgv);
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
else {
/* stale cache entry, junk it and move on */
SvREFCNT_dec(cand_cv);
- GvCV(topgv) = cand_cv = NULL;
+ GvCV_set(topgv, NULL);
+ cand_cv = NULL;
GvCVGEN(topgv) = 0;
}
}
/* cache indicates no such method definitively */
return 0;
}
+ else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
+ && strnEQ(hvname, "CORE", 4)
+ && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
+ goto have_gv;
}
packlen = HvNAMELEN_get(stash);
assert(cstash);
gvp = (GV**)hv_fetch(cstash, name, len, 0);
- if (!gvp) continue;
- candidate = *gvp;
+ if (!gvp) {
+ if (len > 1 && HvNAMELEN_get(cstash) == 4) {
+ const char *hvname = HvNAME(cstash); assert(hvname);
+ if (strnEQ(hvname, "CORE", 4)
+ && (candidate =
+ S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
+ ))
+ goto have_candidate;
+ }
+ continue;
+ }
+ else candidate = *gvp;
+ have_candidate:
assert(candidate);
if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
- if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+ CV *old_cv = GvCV(topgv);
+ SvREFCNT_dec(old_cv);
SvREFCNT_inc_simple_void_NN(cand_cv);
- GvCV(topgv) = cand_cv;
+ GvCV_set(topgv, cand_cv);
GvCVGEN(topgv) = topgen_cmp;
}
return candidate;
if(candidate) {
cand_cv = GvCV(candidate);
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
- if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
+ CV *old_cv = GvCV(topgv);
+ SvREFCNT_dec(old_cv);
SvREFCNT_inc_simple_void_NN(cand_cv);
- GvCV(topgv) = cand_cv;
+ GvCV_set(topgv, cand_cv);
GvCVGEN(topgv) = topgen_cmp;
}
return candidate;
/* Right now this is exclusively for the benefit of S_method_common
in pp_hot.c */
if (stash) {
+ /* If we can't find an IO::File method, it might be a call on
+ * a filehandle. If IO:File has not been loaded, try to
+ * require it first instead of croaking */
+ const char *stash_name = HvNAME_get(stash);
+ if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File")
+ && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL,
+ STR_WITH_LEN("IO/File.pm"), 0,
+ HV_FETCH_ISEXISTS, NULL, 0)
+ ) {
+ require_pv("IO/File.pm");
+ gv = gv_fetchmeth(stash, name, nend - name, 0);
+ if (gv)
+ return gv;
+ }
Perl_croak(aTHX_
"Can't locate object method \"%s\" via package \"%.*s\"",
name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
varsv = GvSVn(vargv);
sv_setpvn(varsv, packname, packname_len);
sv_catpvs(varsv, "::");
- sv_catpvn(varsv, name, len);
+ /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
+ tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
+ sv_catpvn_mg(varsv, name, len);
return gv;
}
/* require_tie_mod() internal routine for requiring a module
- * that implements the logic of automatical ties like %! and %-
+ * that implements the logic of automatic ties like %! and %-
*
* The "gv" parameter should be the glob.
* "varpv" holds the name of the var, used for error messages.
if (!tmpgv)
return NULL;
stash = GvHV(tmpgv);
+ if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
assert(stash);
- assert(HvNAME_get(stash));
+ if (!HvNAME_get(stash)) {
+ hv_name_set(stash, name, namelen, 0);
+
+ /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */
+ /* If the containing stash has multiple effective
+ names, see that this one gets them, too. */
+ if (HvAUX(GvSTASH(tmpgv))->xhv_name_count)
+ mro_package_moved(stash, NULL, tmpgv, 1);
+ }
return stash;
}
GV *
Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
STRLEN len;
- const char * const nambeg = SvPV_const(name, len);
+ const char * const nambeg =
+ SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC);
PERL_ARGS_ASSERT_GV_FETCHSV;
return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
}
const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
const I32 no_expand = flags & GV_NOEXPAND;
const I32 add = flags & ~GV_NOADD_MASK;
+ bool addmg = !!(flags & GV_ADDMG);
const char *const name_end = nambeg + full_len;
const char *const name_em1 = name_end - 1;
U32 faking_it;
}
for (name_cursor = name; name_cursor < name_end; name_cursor++) {
- if ((*name_cursor == ':' && name_cursor < name_em1
+ if (name_cursor < name_em1 &&
+ ((*name_cursor == ':'
&& name_cursor[1] == ':')
- || (*name_cursor == '\'' && name_cursor[1]))
+ || *name_cursor == '\''))
{
if (!stash)
stash = PL_defstash;
return NULL;
len = name_cursor - name;
- if (len > 0) {
+ if (name_cursor > nambeg) { /* Skip for initial :: or ' */
const char *key;
if (*name_cursor == ':') {
key = name;
GvMULTI_on(gv);
}
if (key != name)
- Safefree((char *)key);
+ Safefree(key);
if (!gv || gv == (const GV *)&PL_sv_undef)
return NULL;
if (!(stash = GvHV(gv)))
+ {
stash = GvHV(gv) = newHV();
-
- if (!HvNAME_get(stash))
+ if (!HvNAME_get(stash)) {
+ if (GvSTASH(gv) == PL_defstash && len == 6
+ && strnEQ(name, "CORE", 4))
+ hv_name_set(stash, "CORE", 4, 0);
+ else
+ hv_name_set(
+ stash, nambeg, name_cursor-nambeg, 0
+ );
+ /* If the containing stash has multiple effective
+ names, see that this one gets them, too. */
+ if (HvAUX(GvSTASH(gv))->xhv_name_count)
+ mro_package_moved(stash, NULL, gv, 1);
+ }
+ }
+ else if (!HvNAME_get(stash))
hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
}
if (*name_cursor == ':')
name_cursor++;
- name_cursor++;
- name = name_cursor;
+ name = name_cursor+1;
if (name == name_end)
return gv
? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
return NULL;
gvp = (GV**)hv_fetch(stash,name,len,add);
- if (!gvp || *gvp == (const GV *)&PL_sv_undef)
- return NULL;
- gv = *gvp;
+ if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
+ if (addmg) gv = (GV *)newSV(0);
+ else return NULL;
+ }
+ else gv = *gvp, addmg = 0;
+ /* From this point on, addmg means gv has not been inserted in the
+ symtab yet. */
+
if (SvTYPE(gv) == SVt_PVGV) {
if (add) {
GvMULTI_on(gv);
- gv_init_sv(gv, sv_type);
- if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
+ gv_init_svtype(gv, sv_type);
+ if (len == 1 && stash == PL_defstash
+ && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
if (*name == '!')
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
}
+ else if (len == 3 && sv_type == SVt_PVAV
+ && strnEQ(name, "ISA", 3)
+ && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
+ gv_magicalize_isa(gv);
}
return gv;
} else if (no_init) {
+ assert(!addmg);
return gv;
} else if (no_expand && SvROK(gv)) {
+ assert(!addmg);
return gv;
}
if (add & GV_ADDWARN)
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
gv_init(gv, stash, name, len, add & GV_ADDMULTI);
- gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
: (PL_dowarn & G_WARN_ON ) ) )
/* set up magic where warranted */
if (stash != PL_defstash) { /* not the main stash */
/* We only have to check for four names here: EXPORT, ISA, OVERLOAD
- and VERSION. All the others apply only to the main stash. */
- if (len > 1) {
+ and VERSION. All the others apply only to the main stash or to
+ CORE (which is checked right after this). */
+ if (len > 2) {
const char * const name2 = name + 1;
switch (*name) {
case 'E':
if (strEQ(name2, "ERSION"))
GvMULTI_on(gv);
break;
+ default:
+ goto try_core;
}
+ goto add_magical_gv;
+ }
+ try_core:
+ if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
+ /* Avoid null warning: */
+ const char * const stashname = HvNAME(stash); assert(stashname);
+ if (strnEQ(stashname, "CORE", 4)
+ && S_maybe_add_coresub(aTHX_
+ addmg ? stash : 0, gv, name, len, nambeg, full_len
+ ))
+ addmg = 0;
}
}
else if (len > 1) {
if (strEQ(name2, "NCODING"))
goto magicalize;
break;
+ case '\007': /* $^GLOBAL_PHASE */
+ if (strEQ(name2, "LOBAL_PHASE"))
+ goto ro_magicalize;
+ break;
case '\015': /* $^MATCH */
if (strEQ(name2, "ATCH"))
goto magicalize;
break;
case '\020': /* $^PREMATCH $^POSTMATCH */
if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
- goto magicalize;
+ goto magicalize;
+ break;
case '\024': /* ${^TAINT} */
if (strEQ(name2, "AINT"))
goto ro_magicalize;
/* This snippet is taken from is_gv_magical */
const char *end = name + len;
while (--end > name) {
- if (!isDIGIT(*end)) return gv;
+ if (!isDIGIT(*end)) goto add_magical_gv;
}
goto magicalize;
}
case '>': /* $> */
case '\\': /* $\ */
case '/': /* $/ */
+ case '$': /* $$ */
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
break;
case ']': /* $] */
{
- SV * const sv = GvSVn(gv);
+ SV * const sv = GvSV(gv);
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
GvSV(gv) = vnumify(PL_patchlevel);
break;
case '\026': /* $^V */
{
- SV * const sv = GvSVn(gv);
+ SV * const sv = GvSV(gv);
GvSV(gv) = new_version(PL_patchlevel);
SvREADONLY_on(GvSV(gv));
SvREFCNT_dec(sv);
break;
}
}
+ add_magical_gv:
+ if (addmg) {
+ if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || (
+ GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv)))
+ ))
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ else SvREFCNT_dec(gv), gv = NULL;
+ }
+ if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
}
{
dVAR;
GP* gp;
+ int attempts = 100;
if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
return;
if (--gp->gp_refcnt > 0) {
if (gp->gp_egv == gv)
gp->gp_egv = 0;
- GvGP(gv) = 0;
+ GvGP_set(gv, NULL);
return;
}
- if (gp->gp_file_hek)
- unshare_hek(gp->gp_file_hek);
- SvREFCNT_dec(gp->gp_sv);
- SvREFCNT_dec(gp->gp_av);
- /* FIXME - another reference loop GV -> symtab -> GV ?
- Somehow gp->gp_hv can end up pointing at freed garbage. */
- if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
- const char *hvname = HvNAME_get(gp->gp_hv);
+ while (1) {
+ /* Copy and null out all the glob slots, so destructors do not see
+ freed SVs. */
+ HEK * const file_hek = gp->gp_file_hek;
+ SV * const sv = gp->gp_sv;
+ AV * const av = gp->gp_av;
+ HV * const hv = gp->gp_hv;
+ IO * const io = gp->gp_io;
+ CV * const cv = gp->gp_cv;
+ CV * const form = gp->gp_form;
+
+ gp->gp_file_hek = NULL;
+ gp->gp_sv = NULL;
+ gp->gp_av = NULL;
+ gp->gp_hv = NULL;
+ gp->gp_io = NULL;
+ gp->gp_cv = NULL;
+ gp->gp_form = NULL;
+
+ if (file_hek)
+ unshare_hek(file_hek);
+
+ SvREFCNT_dec(sv);
+ SvREFCNT_dec(av);
+ /* FIXME - another reference loop GV -> symtab -> GV ?
+ Somehow gp->gp_hv can end up pointing at freed garbage. */
+ if (hv && SvTYPE(hv) == SVt_PVHV) {
+ const char *hvname = HvNAME_get(hv);
if (PL_stashcache && hvname)
- (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
+ (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
G_DISCARD);
- SvREFCNT_dec(gp->gp_hv);
+ SvREFCNT_dec(hv);
+ }
+ SvREFCNT_dec(io);
+ SvREFCNT_dec(cv);
+ SvREFCNT_dec(form);
+
+ if (!gp->gp_file_hek
+ && !gp->gp_sv
+ && !gp->gp_av
+ && !gp->gp_hv
+ && !gp->gp_io
+ && !gp->gp_cv
+ && !gp->gp_form) break;
+
+ if (--attempts == 0) {
+ Perl_die(aTHX_
+ "panic: gp_free failed to free glob pointer - "
+ "something is repeatedly re-creating entries"
+ );
+ }
}
- SvREFCNT_dec(gp->gp_io);
- SvREFCNT_dec(gp->gp_cv);
- SvREFCNT_dec(gp->gp_form);
Safefree(gp);
- GvGP(gv) = 0;
+ GvGP_set(gv, NULL);
}
int
gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
cv = 0;
if (gv && (cv = GvCV(gv))) {
- const char *hvname;
- if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
- && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
+ if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
+ const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
+ if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
+ && strEQ(hvname, "overload")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
"\" for overloaded \"%s\" in package \"%.256s\"\n",
- (void*)GvSV(gv), cp, hvname) );
+ (void*)GvSV(gv), cp, HvNAME(stash)) );
if (!gvsv || !SvPOK(gvsv)
|| !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
FALSE)))
"in package \"%.256s\"",
(GvCVGEN(gv) ? "Stub found while resolving"
: "Can't resolve"),
- name, cp, hvname);
+ name, cp, HvNAME(stash));
}
}
cv = GvCV(gv = ngv);
+ }
}
DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
do_update:
/* If we're looking up a destructor to invoke, we must avoid
* that Gv_AMupdate croaks, because we might be dying already */
- if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
+ if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) {
/* and if it didn't found a destructor, we fall back
* to a simpler method that will only look for the
* destructor instead of the whole magic */
return TRUE;
}
}
+ if(left==right && SvGMAGICAL(left)) {
+ SV * const left = sv_newmortal();
+ *(sp-1) = left;
+ /* Print the uninitialized warning now, so it includes the vari-
+ able name. */
+ if (!SvOK(right)) {
+ if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right);
+ sv_setsv_flags(left, &PL_sv_no, 0);
+ }
+ else sv_setsv_flags(left, right, 0);
+ SvGETMAGIC(right);
+ }
if (flags & AMGf_numeric) {
- if (SvROK(left))
- *(sp-1) = sv_2num(left);
+ if (SvROK(TOPm1s))
+ *(sp-1) = sv_2num(TOPm1s);
if (SvROK(right))
*sp = sv_2num(right);
}
int postpr = 0, force_cpy = 0;
int assign = AMGf_assign & flags;
const int assignshift = assign ? 1 : 0;
+ int use_default_op = 0;
#ifdef DEBUGGING
int fl=0;
#endif
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
- } else if (((ocvp && oamtp->fallback > AMGfallNEVER
- && (cvp=ocvp) && (lr = -1))
- || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
+ } else if (((cvp && amtp->fallback > AMGfallNEVER)
+ || (ocvp && oamtp->fallback > AMGfallNEVER))
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
off = scmp_amg;
break;
}
- if ((off != -1) && (cv = cvp[off]))
+ if (off != -1) {
+ if (ocvp && (oamtp->fallback > AMGfallNEVER)) {
+ cv = ocvp[off];
+ lr = -1;
+ }
+ if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) {
+ cv = cvp[off];
+ lr = 1;
+ }
+ }
+ if (cv)
postpr = 1;
else
goto not_found;
notfound = 1; lr = -1;
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
- } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
+ } else if ((use_default_op =
+ (!ocvp || oamtp->fallback >= AMGfallYES)
+ && (!cvp || amtp->fallback >= AMGfallYES))
+ && !DEBUG_o_TEST) {
/* Skip generating the "no method found" message. */
return NULL;
} else {
SvAMAGIC(right)?
HvNAME_get(SvSTASH(SvRV(right))):
""));
- if (amtp && amtp->fallback >= AMGfallYES) {
+ if (use_default_op) {
DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
} else {
Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
* information by hand */
SV *tmpRef = SvRV(left);
SV *rv_copy;
- if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLun(left,copy))) {
+ if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) {
SvRV_set(left, rv_copy);
SvSETMAGIC(left);
SvREFCNT_dec(tmpRef);
if (PERLDB_SUB && PL_curstash != PL_debstash)
PL_op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ Perl_pp_pushmark(aTHX);
EXTEND(SP, notfound + 5);
PUSHs(lr>0? right: left);
}
}
-/*
-=for apidoc is_gv_magical_sv
-
-Returns C<TRUE> if given the name of a magical GV.
-
-Currently only useful internally when determining if a GV should be
-created even in rvalue contexts.
-
-C<flags> is not used at present but available for future extension to
-allow selecting particular classes of magical variable.
-
-Currently assumes that C<name> is NUL terminated (as well as len being valid).
-This assumption is met by all callers within the perl core, which all pass
-pointers returned by SvPV.
-
-=cut
-*/
-
-bool
-Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
-{
- STRLEN len;
- const char *const name = SvPV_const(name_sv, len);
-
- PERL_UNUSED_ARG(flags);
- PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
-
- if (len > 1) {
- const char * const name1 = name + 1;
- switch (*name) {
- case 'I':
- if (len == 3 && name[1] == 'S' && name[2] == 'A')
- goto yes;
- break;
- case 'O':
- if (len == 8 && strEQ(name1, "VERLOAD"))
- goto yes;
- break;
- case 'S':
- if (len == 3 && name[1] == 'I' && name[2] == 'G')
- goto yes;
- break;
- /* Using ${^...} variables is likely to be sufficiently rare that
- it seems sensible to avoid the space hit of also checking the
- length. */
- case '\017': /* ${^OPEN} */
- if (strEQ(name1, "PEN"))
- goto yes;
- break;
- case '\024': /* ${^TAINT} */
- if (strEQ(name1, "AINT"))
- goto yes;
- break;
- case '\025': /* ${^UNICODE} */
- if (strEQ(name1, "NICODE"))
- goto yes;
- if (strEQ(name1, "TF8LOCALE"))
- goto yes;
- break;
- case '\027': /* ${^WARNING_BITS} */
- if (strEQ(name1, "ARNING_BITS"))
- goto yes;
- break;
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- {
- const char *end = name + len;
- while (--end > name) {
- if (!isDIGIT(*end))
- return FALSE;
- }
- goto yes;
- }
- }
- } else {
- /* Because we're already assuming that name is NUL terminated
- below, we can treat an empty name as "\0" */
- switch (*name) {
- case '&':
- case '`':
- case '\'':
- case ':':
- case '?':
- case '!':
- case '-':
- case '#':
- case '[':
- case '^':
- case '~':
- case '=':
- case '%':
- case '.':
- case '(':
- case ')':
- case '<':
- case '>':
- case '\\':
- case '/':
- case '|':
- case '+':
- 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 '\014': /* $^L */
- case '\016': /* $^N */
- case '\017': /* $^O */
- case '\020': /* $^P */
- case '\023': /* $^S */
- case '\024': /* $^T */
- case '\026': /* $^V */
- case '\027': /* $^W */
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- yes:
- return TRUE;
- default:
- break;
- }
- }
- return FALSE;
-}
-
void
Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
{
/* XXX Why and where does this leave dangling pointers during global
destruction? */
- if (PL_dirty) return;
+ if (PL_phase == PERL_PHASE_DESTRUCT) return;
if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
!SvOBJECT(gv) && !SvREADONLY(gv) &&
}
}
+#include "XSUB.h"
+
+static void
+core_xsub(pTHX_ CV* cv)
+{
+ Perl_croak(aTHX_
+ "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
+ );
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff