* 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"]
*/
/*
* 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) {
}
}
+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) (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
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);
/* 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,0))
+ 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)) {
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);
}
hv_magic(hv, NULL, PERL_MAGIC_overload);
}
-static void core_xsub(pTHX_ CV* cv);
-
GV *
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
const svtype 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;
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);
}
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 ) ) )
default:
goto try_core;
}
- return gv;
+ 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)) {
- 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;
-
- if (code >= 0) return gv; /* 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 gv;
- 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_setpgrp: case KEY_shift:
- case KEY_splice:
- case KEY_stat: case KEY_substr:
- case KEY_sysopen:
- case KEY_system:
- case KEY_tell: case KEY_tie: case KEY_tied:
- case KEY_truncate: case KEY_umask: case KEY_unlink:
- case KEY_unpack: case KEY_unshift: case KEY_untie:
- case KEY_values: case KEY_write:
- ampable = FALSE;
- }
- 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 (ampable) {
- if (opnum == OP_VEC || opnum == OP_LOCK) CvLVALUE_on(cv);
- newATTRSUB(oldsavestack_ix,
- newSVOP(
- OP_CONST, 0,
- newSVpvn_share(nambeg,full_len,0)
- ),
- NULL,NULL,
- coresub_op(
- opnum
- ? newSVuv((UV)opnum)
- : newSVpvn(name,len),
- code, opnum
- )
- );
- assert(GvCV(gv) == cv);
- if (opnum == OP_LOCK)
- 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);
- }
+ 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) {
/* 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;
}
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_sv(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
}
}
}
-/*
-=for apidoc is_gv_magical_sv
-
-Returns C<TRUE> if given the name of a magical GV. Any get-magic that
-C<name_sv> has is ignored.
-
-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.
-
-=cut
-*/
-
-bool
-Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
-{
- STRLEN len;
- const char *const name = SvPV_nomg_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 ']':
- 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)
{