X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5e24af7dc1ab912b3a8f822d37f232e8ef19779d..2d46797c8ef21e574c543d2368ec39a1ddb31fde:/op.c diff --git a/op.c b/op.c index 4e8f5a4..9d3d0fa 100644 --- a/op.c +++ b/op.c @@ -1325,10 +1325,19 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) if (!parent) goto no_parent; + /* ought to use OP_CLASS(parent) here, but that can't handle + * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't + * either */ type = parent->op_type; - if (type == OP_NULL) - type = parent->op_targ; - type = PL_opargs[type] & OA_CLASS_MASK; + if (type == OP_CUSTOM) { + dTHX; + type = XopENTRYCUSTOM(parent, xop_class); + } + else { + if (type == OP_NULL) + type = parent->op_targ; + type = PL_opargs[type] & OA_CLASS_MASK; + } lastop = last_ins ? last_ins : start ? start : NULL; if ( type == OA_BINOP @@ -1611,9 +1620,6 @@ S_scalar_slice_warning(pTHX_ const OP *o) case OP_LOCALTIME: case OP_GMTIME: case OP_ENTEREVAL: - case OP_REACH: - case OP_RKEYS: - case OP_RVALUES: return; } @@ -2989,7 +2995,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; case OP_KEYS: - case OP_RKEYS: if (type != OP_SASSIGN && type != OP_LEAVESUBLV) goto nomod; goto lvalue_func; @@ -3359,24 +3364,26 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; - PERL_ARGS_ASSERT_APPLY_ATTRS; + { + SV * const stashsv = newSVhek(HvNAME_HEK(stash)); - /* fake up C */ + /* fake up C */ #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" - Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvs(ATTRSMODULE), - NULL, - op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - op_prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, - newRV(target)), - dup_attrlist(attrs)))); + Perl_load_module( + aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvs(ATTRSMODULE), + NULL, + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); + } } STATIC void @@ -3407,7 +3414,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); /* Build up the real arg-list. */ - stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + stashsv = newSVhek(HvNAME_HEK(stash)); arg = newOP(OP_PADSV, 0); arg->op_targ = target->op_targ; @@ -7595,7 +7602,7 @@ S_ref_array_or_hash(pTHX_ OP *cond) /* anonlist now needs a list from this op, was previously used in * scalar context */ - cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF); + cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF); cond->op_flags |= OPf_WANT_LIST; return newANONLIST(op_lvalue(cond, OP_ANONLIST)); @@ -8133,14 +8140,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); start = LINKLIST(block); block->op_next = 0; + if (ps && !*ps && !attrs && !CvLVALUE(compcv)) + const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE); + else + const_sv = NULL; } - - if (!block || !ps || *ps || attrs - || CvLVALUE(compcv) - ) - const_sv = NULL; else - const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE); + const_sv = NULL; if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -8441,9 +8447,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); has_name = FALSE; } - if (!ec) - move_proto_attr(&proto, &attrs, - isGV(gv) ? gv : (GV *)cSVOPo->op_sv); + if (!ec) { + if (isGV(gv)) { + move_proto_attr(&proto, &attrs, gv); + } else { + assert(cSVOPo); + move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv); + } + } if (proto) { assert(proto->op_type == OP_CONST); @@ -8538,15 +8549,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); start = LINKLIST(block); block->op_next = 0; + if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) + const_sv = + S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv)); + else + const_sv = NULL; } - - if (!block || !ps || *ps || attrs - || CvLVALUE(PL_compcv) - ) - const_sv = NULL; else - const_sv = - S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv))); + const_sv = NULL; if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { assert (block); @@ -9047,7 +9057,7 @@ Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr) { PERL_ARGS_ASSERT_NEWXS_DEFFILE; return newXS_len_flags( - name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0 + name, strlen(name), subaddr, NULL, NULL, NULL, 0 ); } @@ -9960,17 +9970,13 @@ Perl_ck_fun(pTHX_ OP *o) || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) ) bad_type_pv(numargs, "array", o, kid); - /* 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); - /* diag_listed_as: push on reference is experimental */ - Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__AUTODEREF), - "%s on reference is experimental", - PL_op_desc[type]); + else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) { + yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden", + PL_op_desc[type]), 0); } + else { + op_lvalue(kid, type); + } break; case OA_HVREF: if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) @@ -11118,11 +11124,11 @@ Perl_ck_stringify(pTHX_ OP *o) { OP * const kid = OpSIBLING(cUNOPo->op_first); PERL_ARGS_ASSERT_CK_STRINGIFY; - if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA - || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST - || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) + if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA + || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST + || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) + && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ { - assert(!OpHAS_SIBLING(kid)); op_sibling_splice(o, cUNOPo->op_first, -1, NULL); op_free(o); return kid; @@ -11408,11 +11414,12 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) case '&': proto++; arg++; - if (o3->op_type != OP_SREFGEN - || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type - != OP_ANONCODE - && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type - != OP_RV2CV)) + if ( o3->op_type != OP_UNDEF + && (o3->op_type != OP_SREFGEN + || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type + != OP_ANONCODE + && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type + != OP_RV2CV))) bad_type_gv(arg, namegv, o3, arg == 1 ? "block or sub {}" : "sub {}"); break; @@ -11711,7 +11718,7 @@ The C-level function pointer is returned in I<*ckfun_p>, and an SV argument for it is returned in I<*ckobj_p>. The function is intended to be called in this manner: - entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p)); + entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p)); In this call, I is a pointer to the C op, which may be replaced by the check function, and I is a GV @@ -11936,9 +11943,7 @@ Perl_ck_svconst(pTHX_ OP *o) SV * const sv = cSVOPo->op_sv; PERL_ARGS_ASSERT_CK_SVCONST; PERL_UNUSED_CONTEXT; -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(sv)) sv_force_normal(sv); -#elif defined(PERL_NEW_COPY_ON_WRITE) +#ifdef PERL_COPY_ON_WRITE /* Since the read-only flag may be used to protect a string buffer, we cannot do copy-on-write with existing read-only scalars that are not already copy-on-write scalars. To allow $_ = "hello" to do COW with @@ -12014,10 +12019,6 @@ Perl_ck_each(pTHX_ OP *o) dVAR; OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL; const unsigned orig_type = o->op_type; - const unsigned array_type = orig_type == OP_EACH ? OP_AEACH - : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; - const unsigned ref_type = orig_type == OP_EACH ? OP_REACH - : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES; PERL_ARGS_ASSERT_CK_EACH; @@ -12028,7 +12029,9 @@ Perl_ck_each(pTHX_ OP *o) break; case OP_PADAV: case OP_RV2AV: - OpTYPE_set(o, array_type); + OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH + : orig_type == OP_KEYS ? OP_AKEYS + : OP_AVALUES); break; case OP_CONST: if (kid->op_private == OPpCONST_BARE @@ -12039,17 +12042,12 @@ Perl_ck_each(pTHX_ OP *o) /* we let ck_fun handle it */ break; default: - OpTYPE_set(o, ref_type); - scalar(kid); + Perl_croak_nocontext( + "Experimental %s on scalar is now forbidden", + PL_op_desc[orig_type]); + break; } } - /* if treating as a reference, defer additional checks to runtime */ - if (o->op_type == ref_type) { - /* diag_listed_as: keys on reference is experimental */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF), - "%s is experimental", PL_op_desc[ref_type]); - return o; - } return ck_fun(o); } @@ -14172,16 +14170,16 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, case KEY_x : case KEY_xor : if (!opnum) return NULL; nullret = TRUE; goto findopnum; case KEY_glob: retsetpvs("_;", OP_GLOB); - case KEY_keys: retsetpvs("+", OP_KEYS); - case KEY_values: retsetpvs("+", OP_VALUES); - case KEY_each: retsetpvs("+", OP_EACH); - case KEY_push: retsetpvs("+@", OP_PUSH); - case KEY_unshift: retsetpvs("+@", OP_UNSHIFT); - case KEY_pop: retsetpvs(";+", OP_POP); - case KEY_shift: retsetpvs(";+", OP_SHIFT); + case KEY_keys: retsetpvs("\\[%@]", OP_KEYS); + case KEY_values: retsetpvs("\\[%@]", OP_VALUES); + case KEY_each: retsetpvs("\\[%@]", OP_EACH); + case KEY_push: retsetpvs("\\@@", OP_PUSH); + case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT); + case KEY_pop: retsetpvs(";\\@", OP_POP); + case KEY_shift: retsetpvs(";\\@", OP_SHIFT); case KEY_pos: retsetpvs(";\\[$*]", OP_POS); case KEY_splice: - retsetpvs("+;$$@", OP_SPLICE); + retsetpvs("\\@;$$@", OP_SPLICE); case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: retsetpvs("", 0); case KEY_evalbytes: