X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/459b64da6c5743fa9093a9ef5214a82b46f2f7d0..b8c38f0a2a65800ef71a3715d0a31299fcfb4986:/op.c diff --git a/op.c b/op.c index e1bf353..2c829de 100644 --- a/op.c +++ b/op.c @@ -387,7 +387,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PERL_ARGS_ASSERT_ALLOCMY; - if (flags) + if (flags & ~SVf_UTF8) Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, (UV)flags); @@ -399,7 +399,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 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 */ @@ -415,9 +415,10 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) /* 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 */ @@ -571,8 +572,7 @@ Perl_op_clear(pTHX_ OP *o) 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 @@ -960,14 +960,9 @@ Perl_scalar(pTHX_ OP *o) 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; } @@ -1069,6 +1064,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_SPRINTF: case OP_AELEM: case OP_AELEMFAST: + case OP_AELEMFAST_LEX: case OP_ASLICE: case OP_HELEM: case OP_HSLICE: @@ -1345,14 +1341,9 @@ Perl_list(pTHX_ OP *o) 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; } @@ -1424,7 +1415,7 @@ such as C<$$x = 5> which might have to vivify a reference in C<$x>. */ OP * -Perl_op_lvalue(pTHX_ OP *o, I32 type) +Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) { dVAR; OP *kid; @@ -1471,9 +1462,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) 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); @@ -1483,7 +1473,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) 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: */ @@ -1568,8 +1559,10 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) /* 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) @@ -1654,6 +1647,7 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) break; case OP_AELEMFAST: + case OP_AELEMFAST_LEX: localize = -1; PL_modcount++; break; @@ -1671,8 +1665,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) 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: @@ -1681,7 +1675,7 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) case OP_KEYS: case OP_RKEYS: - if (type != OP_SASSIGN) + if (type != OP_SASSIGN && type != OP_LEAVESUBLV) goto nomod; goto lvalue_func; case OP_SUBSTR: @@ -1690,9 +1684,9 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) /* 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); @@ -1884,7 +1878,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) 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]; @@ -1893,6 +1887,11 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) 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: @@ -2238,8 +2237,19 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) 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; @@ -2441,7 +2451,7 @@ STATIC OP * 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)); } @@ -4875,7 +4885,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 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 @@ -5580,7 +5590,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } } 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); } @@ -5919,10 +5929,7 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) 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 @@ -6197,13 +6204,18 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) #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; @@ -6329,6 +6341,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } + attrs: if (attrs) { /* Need to do a C. */ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; @@ -6367,14 +6380,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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'); @@ -6382,11 +6389,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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)); @@ -6916,7 +6924,7 @@ Perl_ck_anoncode(pTHX_ OP *o) { 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; @@ -7335,8 +7343,10 @@ Perl_ck_ftst(pTHX_ OP *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 @@ -7752,7 +7762,7 @@ Perl_ck_grep(pTHX_ OP *o) 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); @@ -7780,8 +7790,11 @@ Perl_ck_index(pTHX_ OP *o) 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); } @@ -7999,7 +8012,7 @@ Perl_ck_match(pTHX_ OP *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; @@ -8213,19 +8226,6 @@ Perl_ck_return(pTHX_ OP *o) 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; @@ -8806,7 +8806,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) 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); @@ -8832,8 +8839,15 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) 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 || @@ -9044,6 +9058,7 @@ Perl_ck_subr(pTHX_ OP *o) 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) @@ -9289,6 +9304,16 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) { 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 */ @@ -9298,13 +9323,24 @@ Perl_rpeep(pTHX_ register OP *o) { 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) { + 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) { @@ -9346,8 +9382,6 @@ Perl_rpeep(pTHX_ register OP *o) mp = mp->mad_next; } #endif - if (o->op_opt) - break; /* By default, this op has now been optimised. A couple of cases below clear this again. */ o->op_opt = 1; @@ -9421,8 +9455,10 @@ Perl_rpeep(pTHX_ register OP *o) * 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)); @@ -9526,10 +9562,10 @@ Perl_rpeep(pTHX_ register OP *o) 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; } @@ -9586,7 +9622,10 @@ Perl_rpeep(pTHX_ register OP *o) 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; @@ -9637,20 +9676,21 @@ Perl_rpeep(pTHX_ register OP *o) 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: @@ -9659,7 +9699,7 @@ Perl_rpeep(pTHX_ register OP *o) 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: @@ -9787,14 +9827,20 @@ Perl_rpeep(pTHX_ register OP *o) 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; } @@ -10135,6 +10181,109 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) 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, or +to a new mortal SV if C is NULL. It returns the modified C, or +NULL if the core function has no prototype. + +If the C is not a Perl keyword, it croaks if C is true, or +returns NULL if C 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. */