PERL_ARGS_ASSERT_ALLOCMY;
- if (flags)
+ if (flags & ~SVf_UTF8)
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
(UV)flags);
if (len &&
!(is_our ||
isALPHA(name[1]) ||
- (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
+ ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
/* allocate a spare slot and store the name in that slot */
- off = pad_add_name(name, len,
- is_our ? padadd_OUR :
- PL_parser->in_my == KEY_state ? padadd_STATE : 0,
+ off = pad_add_name_pvn(name, len,
+ (is_our ? padadd_OUR :
+ PL_parser->in_my == KEY_state ? padadd_STATE : 0)
+ | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
PERL_ARGS_ASSERT_OP_CLEAR;
#ifdef PERL_MAD
- /* if (o->op_madprop && o->op_madprop->mad_next)
- abort(); */
- /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
- "modification of a read only value" for a reason I can't fathom why.
- It's the "" stringification of $_, where $_ was set to '' in a foreach
- loop, but it defies simplification into a small test case.
- However, commenting them out has caused ext/List/Util/t/weak.t to fail
- the last test. */
- /*
- mad_free(o->op_madprop);
- o->op_madprop = 0;
- */
+ mad_free(o->op_madprop);
+ o->op_madprop = 0;
#endif
retry:
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
- if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
- /* not an OP_PADAV replacement */
+ {
GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
#ifdef USE_ITHREADS
&& PL_curpad
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN) {
- if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
- scalar(kid);
- scalarvoid(sib);
- break;
- } else
- scalarvoid(kid);
- } else
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ scalarvoid(kid);
+ else
scalar(kid);
kid = sib;
}
case OP_SPRINTF:
case OP_AELEM:
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
case OP_ASLICE:
case OP_HELEM:
case OP_HSLICE:
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN) {
- if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
- list(kid);
- scalarvoid(sib);
- break;
- } else
- scalarvoid(kid);
- } else
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ scalarvoid(kid);
+ else
list(kid);
kid = sib;
}
*/
OP *
-Perl_op_lvalue(pTHX_ OP *o, I32 type)
+Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
dVAR;
OP *kid;
if ((type == OP_UNDEF || type == OP_REFGEN) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* The default is to set op_private to the number of children,
- which for a UNOP such as RV2CV is always 1. And w're using
- the bit for a flag in RV2CV, so we need it clear. */
+ /* Both ENTERSUB and RV2CV use this bit, but for different pur-
+ poses, so we need it clear. */
o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
else if (o->op_private & OPpENTERSUB_NOMOD)
return o;
else { /* lvalue subroutine call */
- o->op_private |= OPpLVAL_INTRO;
+ o->op_private |= OPpLVAL_INTRO
+ |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
/* Backward compatibility mode: */
/* FALL THROUGH */
default:
nomod:
+ if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ if (type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
break;
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
localize = -1;
PL_modcount++;
break;
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
- Perl_croak(aTHX_ "Can't localize lexical variable %s",
- PAD_COMPNAME_PV(o->op_targ));
+ Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
+ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
break;
case OP_KEYS:
- if (type != OP_SASSIGN)
+ case OP_RKEYS:
+ if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
/* FALL THROUGH */
case OP_POS:
case OP_VEC:
+ lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- lvalue_func:
pad_free(o->op_targ);
o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
switch (o->op_type) {
case OP_ENTERSUB:
- if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
+ if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
o->op_flags |= OPf_SPECIAL;
o->op_private &= ~1;
}
+ else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+ o->op_private |= OPpENTERSUB_DEREF;
+ o->op_flags |= OPf_MOD;
+ }
+
break;
case OP_COND_EXPR:
o = scalar(op_append_list(OP_LIST, rops, o));
o->op_private |= OPpLVAL_INTRO;
}
- else
+ else {
+ /* The listop in rops might have a pushmark at the beginning,
+ which will mess up list assignment. */
+ LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
+ if (rops->op_type == OP_LIST &&
+ lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
+ {
+ OP * const pushmark = lrops->op_first;
+ lrops->op_first = pushmark->op_sibling;
+ op_free(pushmark);
+ }
o = op_append_list(OP_LIST, o, rops);
+ }
}
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
S_newDEFSVOP(pTHX)
{
dVAR;
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
case 0:
CALLRUNOPS(aTHX);
sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
+#ifdef PERL_MAD
+ /* Can't simply swipe the SV from the pad, because that relies on
+ the op being freed "real soon now". Under MAD, this doesn't
+ happen (see the #ifdef below). */
+ sv = newSVsv(sv);
+#else
pad_swipe(o->op_targ, FALSE);
+#endif
+ }
else if (SvTEMP(sv)) { /* grab mortal temp? */
SvREFCNT_inc_simple_void(sv);
SvTEMP_off(sv);
MADPROP *
Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
{
- MADPROP *mp;
- Newxz(mp, 1, MADPROP);
+ MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
mp->mad_next = 0;
mp->mad_key = key;
mp->mad_vlen = vlen;
PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
break;
}
- Safefree(mp);
+ PerlMemShared_free(mp);
}
#endif
PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
);
if (reflags && SvOK(reflags)) {
- set_regex_charset(&(pmop->op_pmflags), SvIV(reflags));
+ set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
}
}
PL_parser->copline = NOLINE;
PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
+ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+ PL_cop_seqmax++;
#ifdef PERL_MAD
if (!PL_madskills) {
ENTER;
SAVEVPTR(PL_curcop);
- lex_start(NULL, NULL, 0);
+ lex_start(NULL, NULL, LEX_START_SAME_FILTER);
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
LEAVE;
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
- Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
+ Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
PL_hints |= HINT_BLOCK_SCOPE;
/* It seems that we need to defer freeing this pointer, as other parts
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH)
{
warnop = ((k1->op_type == OP_NULL)
? (OPCODE)k1->op_targ : k1->op_type);
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
}
}
else {
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
scalar(ref_array_or_hash(cond)));
}
- return newGIVWHENOP(
- cond_op,
- op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
- OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+ return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
void
#ifdef PERL_MAD
|| block->op_type == OP_NULL
#endif
- )&& !attrs) {
+ )) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
- if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
+ CvFLAGS(cv) |=
+ (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
}
+ if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
CvISXSUB_on(cv);
}
else {
- GvCV(gv) = NULL;
+ GvCV_set(gv, NULL);
cv = newCONSTSUB(NULL, name, const_sv);
}
mro_method_changed_in( /* sub Foo::Bar () { 123 } */
else {
cv = PL_compcv;
if (name) {
- GvCV(gv) = cv;
+ GvCV_set(gv, cv);
if (PL_madskills) {
if (strEQ(name, "import")) {
PL_formfeed = MUTABLE_SV(cv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
+ attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
exit. */
PL_breakable_sub_gen++;
- if (CvLVALUE(cv)) {
- CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV));
- block->op_attached = 1;
- }
- else {
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
#ifdef PERL_MAD
op_getmad(block,newblock,'B');
op_free(block);
#endif
block = newblock;
- }
- else
- block->op_attached = 1;
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
+ else block->op_attached = 1;
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
CvSTART(cv) = LINKLIST(CvROOT(cv));
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
- GvCV(gv) = 0; /* cv has been hijacked */
+ GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
} else
return;
DEBUG_x( dump_sub(gv) );
- GvCV(gv) = 0; /* cv has been hijacked */
+ GvCV_set(gv,0); /* cv has been hijacked */
}
}
else {
cv = MUTABLE_CV(newSV_type(SVt_PVCV));
if (name) {
- GvCV(gv) = cv;
+ GvCV_set(gv,cv);
GvCVGEN(gv) = 0;
mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
{
PERL_ARGS_ASSERT_CK_ANONCODE;
- cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
+ cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
cSVOPo->op_sv = NULL;
return o;
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT)
+ && kidtype != OP_STAT && kidtype != OP_LSTAT) {
o->op_private |= OPpFT_STACKED;
+ kid->op_private |= OPpFT_STACKING;
+ }
}
else {
#ifdef PERL_MAD
kid->op_sibling = sibl;
*tokid = kid;
}
- else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
+ else if (kid->op_type == OP_CONST
+ && ( !SvROK(cSVOPx_sv(kid))
+ || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
+ )
bad_type(numargs, "array", PL_op_desc[type], kid);
- op_lvalue(kid, type);
+ /* Defer checks to run-time if we have a scalar arg */
+ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
+ op_lvalue(kid, type);
+ else scalar(kid);
break;
case OA_HVREF:
if (kid->op_type == OP_CONST &&
newSVpvs("File::Glob"), NULL, NULL, NULL);
if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- GvCV(gv) = GvCV(glob_gv);
+ GvCV_set(gv, GvCV(glob_gv));
SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
GvIMPORTED_CV_on(gv);
}
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
- offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid)
kid = kid->op_sibling; /* get past "big" */
- if (kid && kid->op_type == OP_CONST)
+ if (kid && kid->op_type == OP_CONST) {
+ const bool save_taint = PL_tainted;
fbm_compile(((SVOP*)kid)->op_sv, 0);
+ PL_tainted = save_taint;
+ }
}
return ck_fun(o);
}
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
if (CvLVALUE(PL_compcv)) {
for (; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_LEAVESUBLV);
- } else {
- for (; kid; kid = kid->op_sibling)
- if ((kid->op_type == OP_NULL)
- && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
- /* This is a do block */
- OP *op = kUNOP->op_first;
- if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
- op = cUNOPx(op)->op_first;
- assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
- /* Force the use of the caller's context */
- op->op_flags |= OPf_SPECIAL;
- }
- }
}
return o;
return newUNOP(type, 0, scalar(argop));
#endif
}
- return scalar(modkids(ck_push(o), type));
+ return scalar(ck_fun(o));
}
OP *
Perl_croak(aTHX_ "panic: ck_split");
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
- cLISTOPo->op_first = kid;
- if (!kid) {
+ if (kid)
+ cLISTOPo->op_first = kid;
+ else {
cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
cLISTOPo->op_last = kid; /* There was only one element previously */
}
const char *p = proto;
const char *const end = proto;
contextclass = 0;
- while (*--p != '[') {}
+ while (*--p != '[')
+ /* \[$] accepts any scalar lvalue */
+ if (*p == '$'
+ && Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
bad_type(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
gv_ename(namegv), o3);
o3->op_type == OP_HELEM ||
o3->op_type == OP_AELEM)
goto wrapref;
- if (!contextclass)
+ if (!contextclass) {
+ /* \$ accepts any scalar lvalue */
+ if (Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
bad_type(arg, "scalar", gv_ename(namegv), o3);
+ }
break;
case '@':
if (o3->op_type == OP_RV2AV ||
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
}
OP *
-Perl_ck_push(pTHX_ OP *o)
-{
- dVAR;
- OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
- OP *cursor = NULL;
- OP *proxy = NULL;
-
- PERL_ARGS_ASSERT_CK_PUSH;
-
- /* If 1st kid is pushmark (e.g. push, unshift, splice), we need 2nd kid */
- if (kid) {
- cursor = kid->op_type == OP_PUSHMARK ? kid->op_sibling : kid;
- }
-
- /* If not array or array deref, wrap it with an array deref.
- * For OP_CONST, we only wrap arrayrefs */
- if (cursor) {
- if ( ( cursor->op_type != OP_PADAV
- && cursor->op_type != OP_RV2AV
- && cursor->op_type != OP_CONST
- )
- ||
- ( cursor->op_type == OP_CONST
- && SvROK(cSVOPx_sv(cursor))
- && SvTYPE(SvRV(cSVOPx_sv(cursor))) == SVt_PVAV
- )
- ) {
- proxy = newAVREF(cursor);
- if ( cursor == kid ) {
- cLISTOPx(o)->op_first = proxy;
- }
- else {
- cLISTOPx(kid)->op_sibling = proxy;
- }
- cLISTOPx(proxy)->op_sibling = cLISTOPx(cursor)->op_sibling;
- cLISTOPx(cursor)->op_sibling = NULL;
- }
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_each(pTHX_ OP *o)
{
dVAR;
CHANGE_TYPE(o, array_type);
break;
case OP_CONST:
- if (kid->op_private == OPpCONST_BARE)
- /* we let ck_fun treat as hash */
+ if (kid->op_private == OPpCONST_BARE
+ || !SvROK(cSVOPx_sv(kid))
+ || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
+ && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
+ )
+ /* we let ck_fun handle it */
break;
default:
CHANGE_TYPE(o, ref_type);
+ scalar(kid);
}
}
/* if treating as a reference, defer additional checks to runtime */
return oleft;
}
+#define MAX_DEFERRED 4
+
+#define DEFER(o) \
+ if (defer_ix == (MAX_DEFERRED-1)) { \
+ CALL_RPEEP(defer_queue[defer_base]); \
+ defer_base = (defer_base + 1) % MAX_DEFERRED; \
+ defer_ix--; \
+ } \
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
+
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
{
dVAR;
register OP* oldop = NULL;
+ OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
+ int defer_base = 0;
+ int defer_ix = -1;
if (!o || o->op_opt)
return;
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
- for (; o; o = o->op_next) {
- if (o->op_opt)
+ for (;; o = o->op_next) {
+ if (o && o->op_opt)
+ o = NULL;
+ if (!o) {
+ while (defer_ix >= 0)
+ CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
break;
+ }
+
+#if defined(PERL_MAD) && defined(USE_ITHREADS)
+ MADPROP *mp = o->op_madprop;
+ while (mp) {
+ if (mp->mad_type == MAD_OP && mp->mad_vlen) {
+ OP *prop_op = (OP *) mp->mad_val;
+ /* I *think* that this is roughly the right thing to do. It
+ seems that sometimes the optree hooked into the madprops
+ doesn't have its next pointers set, so it's not possible to
+ use them to locate all the OPs needing a fixup. Possibly
+ it's a bit overkill calling LINKLIST to do this, when we
+ could instead iterate over the OPs (without changing them)
+ the way op_linklist does internally. However, I'm not sure
+ if there are corner cases where we have a chain of partially
+ linked OPs. Or even if we do, does that matter? Or should
+ we always iterate on op_first,op_next? */
+ LINKLIST(prop_op);
+ do {
+ if (prop_op->op_opt)
+ break;
+ prop_op->op_opt = 1;
+ switch (prop_op->op_type) {
+ case OP_CONST:
+ case OP_HINTSEVAL:
+ case OP_METHOD_NAMED:
+ /* Duplicate the "relocate sv to the pad for thread
+ safety" code, as otherwise an opfree of this madprop
+ in the wrong thread will free the SV to the wrong
+ interpreter. */
+ if (((SVOP *)prop_op)->op_sv) {
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
+ sv_setsv(PAD_SVl(ix),((SVOP *)prop_op)->op_sv);
+ SvREFCNT_dec(((SVOP *)prop_op)->op_sv);
+ ((SVOP *)prop_op)->op_sv = NULL;
+ }
+ break;
+ }
+ } while ((prop_op = prop_op->op_next));
+ }
+ mp = mp->mad_next;
+ }
+#endif
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
- /* If op_sv is already a PADTMP then it is being used by
+ if (o->op_type != OP_METHOD_NAMED &&
+ (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
+ {
+ /* If op_sv is already a PADTMP/MY then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
SvREADONLY_on(PAD_SVl(ix));
if (o->op_type == OP_GV) {
gv = cGVOPo_gv;
GvAVn(gv);
+ o->op_type = OP_AELEMFAST;
}
else
- o->op_flags |= OPf_SPECIAL;
- o->op_type = OP_AELEMFAST;
+ o->op_type = OP_AELEMFAST_LEX;
}
break;
}
sop = fop->op_sibling;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- CALL_RPEEP(cLOGOP->op_other);
+ while (o->op_next && ( o->op_type == o->op_next->op_type
+ || o->op_next->op_type == OP_NULL))
+ o->op_next = o->op_next->op_next;
+ DEFER(cLOGOP->op_other);
stitch_keys:
o->op_opt = 1;
case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- CALL_RPEEP(cLOGOP->op_other);
+ DEFER(cLOGOP->op_other);
break;
case OP_ENTERLOOP:
case OP_ENTERITER:
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
- CALL_RPEEP(cLOOP->op_redoop);
while (cLOOP->op_nextop->op_type == OP_NULL)
cLOOP->op_nextop = cLOOP->op_nextop->op_next;
- CALL_RPEEP(cLOOP->op_nextop);
while (cLOOP->op_lastop->op_type == OP_NULL)
cLOOP->op_lastop = cLOOP->op_lastop->op_next;
- CALL_RPEEP(cLOOP->op_lastop);
+ /* a while(1) loop doesn't have an op_next that escapes the
+ * loop, so we have to explicitly follow the op_lastop to
+ * process the rest of the code */
+ DEFER(cLOOP->op_lastop);
break;
case OP_SUBST:
cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
cPMOP->op_pmstashstartu.op_pmreplstart
= cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
- CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
+ DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
case OP_EXEC:
case OP_RV2SV:
case OP_RV2AV:
case OP_RV2HV:
- if (oldop
- && ( oldop->op_type == OP_AELEM
+ if (oldop &&
+ (
+ (
+ ( oldop->op_type == OP_AELEM
|| oldop->op_type == OP_PADSV
|| oldop->op_type == OP_RV2SV
|| oldop->op_type == OP_RV2GV
|| oldop->op_type == OP_HELEM
)
&& (oldop->op_private & OPpDEREF)
+ )
+ || ( oldop->op_type == OP_ENTERSUB
+ && oldop->op_private & OPpENTERSUB_DEREF )
+ )
) {
o->op_private |= OPpDEREFed;
}
Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
}
+/*
+=head1 Functions in file op.c
+
+=for apidoc core_prototype
+This function assigns the prototype of the named core function to C<sv>, or
+to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
+NULL if the core function has no prototype.
+
+If the C<name> is not a Perl keyword, it croaks if C<croak> is true, or
+returns NULL if C<croak> is false.
+
+=cut
+*/
+
+SV *
+Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
+ const bool croak)
+{
+ const int code = keyword(name, len, 1);
+ int i = 0, n = 0, seen_question = 0, defgv = 0;
+ I32 oa;
+#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
+ char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+
+ PERL_ARGS_ASSERT_CORE_PROTOTYPE;
+
+ if (!code) {
+ if (croak)
+ return (SV *)Perl_die(aTHX_
+ "Can't find an opnumber for \"%s\"", name
+ );
+ return NULL;
+ }
+
+ if (code > 0) return NULL; /* Not overridable */
+
+ if (!sv) sv = sv_newmortal();
+
+#define retsetpvs(x) sv_setpvs(sv, x); return sv
+
+ switch (-code) {
+ case KEY_and : case KEY_chop: case KEY_chomp:
+ case KEY_cmp : case KEY_exec: case KEY_eq :
+ case KEY_ge : case KEY_gt : case KEY_le :
+ case KEY_lt : case KEY_ne : case KEY_or :
+ case KEY_system: case KEY_x : case KEY_xor :
+ return NULL;
+ case KEY_mkdir:
+ retsetpvs("_;$");
+ case KEY_keys: case KEY_values: case KEY_each:
+ retsetpvs("+");
+ case KEY_push: case KEY_unshift:
+ retsetpvs("+@");
+ case KEY_pop: case KEY_shift:
+ retsetpvs(";+");
+ case KEY_splice:
+ retsetpvs("+;$$@");
+ case KEY_lock: case KEY_tied: case KEY_untie:
+ retsetpvs("\\[$@%*]");
+ case KEY_tie:
+ retsetpvs("\\[$@%*]$@");
+ case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
+ retsetpvs("");
+ case KEY_readpipe:
+ name = "backtick";
+ }
+
+#undef retsetpvs
+
+ while (i < MAXO) { /* The slow way. */
+ if (strEQ(name, PL_op_name[i])
+ || strEQ(name, PL_op_desc[i]))
+ {
+ goto found;
+ }
+ i++;
+ }
+ return NULL; /* Should not happen... */
+ found:
+ defgv = PL_opargs[i] & OA_DEFGV;
+ oa = PL_opargs[i] >> OASHIFT;
+ while (oa) {
+ if (oa & OA_OPTIONAL && !seen_question && !defgv) {
+ seen_question = 1;
+ str[n++] = ';';
+ }
+ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
+ && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
+ /* But globs are already references (kinda) */
+ && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
+ ) {
+ str[n++] = '\\';
+ }
+ str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+ oa = oa >> 4;
+ }
+ if (defgv && str[n - 1] == '$')
+ str[n - 1] = '_';
+ str[n++] = '\0';
+ sv_setpvn(sv, str, n - 1);
+ return sv;
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
https://perl5.git.perl.org / perl5.git / blobdiff