X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/169504d53dbeb12d5171b2b44e7db3c2b81af314..2c8bbb43f3e77a214243c1121d83606429f63584:/op.c diff --git a/op.c b/op.c index 7519f73..c4db56f 100644 --- a/op.c +++ b/op.c @@ -175,19 +175,6 @@ Perl_Slab_Alloc(pTHX_ size_t sz) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) return PerlMemShared_calloc(1, sz); -#if defined(USE_ITHREADS) && IVSIZE > U32SIZE - /* Work around a goof with alignment on our part. For sparc32 (and - possibly other architectures), if built with -Duse64bitint, the IV - op_pmoffset in struct pmop should be 8 byte aligned, but the slab - allocator is only providing 4 byte alignment. The real fix is to change - the IV to a type the same size as a pointer, such as size_t, but we - can't do that without breaking the ABI, which is a no-no in a maint - release. So instead, simply allocate struct pmop directly, which will be - suitably aligned: */ - if (sz == sizeof(struct pmop)) - return PerlMemShared_calloc(1, sz); -#endif - /* While the subroutine is under construction, the slabs are accessed via CvSTART(), to avoid needing to expand PVCV by one pointer for something unneeded at runtime. Once a subroutine is constructed, the slabs are @@ -311,7 +298,7 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) } #else -# define Slab_to_rw(op) +# define Slab_to_rw(op) NOOP #endif /* This cannot possibly be right, but it was copied from the old slab @@ -548,9 +535,10 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP } STATIC void -S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid) +S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - PERL_ARGS_ASSERT_BAD_TYPE_SV; + SV * const namesv = gv_ename(gv); + PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); @@ -740,9 +728,8 @@ Perl_op_free(pTHX_ OP *o) if (type == OP_NULL) type = (OPCODE)o->op_targ; - if (o->op_slabbed) { - Slab_to_rw(OpSLAB(o)); - } + if (o->op_slabbed) + Slab_to_rw(OpSLAB(o)); /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ @@ -938,6 +925,8 @@ S_cop_free(pTHX_ COP* cop) if (! specialWARN(cop->cop_warnings)) PerlMemShared_free(cop->cop_warnings); cophh_free(CopHINTHASH_get(cop)); + if (PL_curcop == cop) + PL_curcop = NULL; } STATIC void @@ -1134,6 +1123,112 @@ S_scalarboolean(pTHX_ OP *o) return scalar(o); } +static SV * +S_op_varname(pTHX_ const OP *o) +{ + assert(o); + assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || + o->op_type == OP_PADHV || o->op_type == OP_RV2HV); + { + const char funny = o->op_type == OP_PADAV + || o->op_type == OP_RV2AV ? '@' : '%'; + if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { + GV *gv; + if (cUNOPo->op_first->op_type != OP_GV + || !(gv = cGVOPx_gv(cUNOPo->op_first))) + return NULL; + return varname(gv, funny, 0, NULL, 0, 1); + } + return + varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1); + } +} + +static void +S_scalar_slice_warning(pTHX_ const OP *o) +{ + OP *kid; + const char lbrack = + o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '{' : '['; + const char rbrack = + o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '}' : ']'; + const char funny = + o->op_type == OP_ASLICE || o->op_type == OP_HSLICE ? '@' : '%'; + SV *name; + SV *keysv; + const char *key = NULL; + + if (!(o->op_private & OPpSLICEWARNING)) + return; + if (PL_parser && PL_parser->error_count) + /* This warning can be nonsensical when there is a syntax error. */ + return; + + kid = cLISTOPo->op_first; + kid = kid->op_sibling; /* get past pushmark */ + /* weed out false positives: any ops that can return lists */ + switch (kid->op_type) { + case OP_BACKTICK: + case OP_GLOB: + case OP_READLINE: + case OP_MATCH: + case OP_RV2AV: + case OP_EACH: + case OP_VALUES: + case OP_KEYS: + case OP_SPLIT: + case OP_LIST: + case OP_SORT: + case OP_REVERSE: + case OP_ENTERSUB: + case OP_CALLER: + case OP_LSTAT: + case OP_STAT: + case OP_READDIR: + case OP_SYSTEM: + case OP_TMS: + case OP_LOCALTIME: + case OP_GMTIME: + case OP_ENTEREVAL: + case OP_REACH: + case OP_RKEYS: + case OP_RVALUES: + return; + } + assert(kid->op_sibling); + name = S_op_varname(aTHX_ kid->op_sibling); + if (!name) /* XS module fiddling with the op tree */ + return; + if (kid->op_type == OP_CONST) { + keysv = kSVOP_sv; + if (SvPOK(kSVOP_sv)) { + SV *sv = keysv; + keysv = sv_newmortal(); + pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); + } + else if (!SvOK(keysv)) + key = "undef"; + } + else key = "..."; + assert(SvPOK(name)); + sv_chop(name,SvPVX(name)+1); + if (key) + /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Scalar value %c%"SVf"%c%s%c better written as $%"SVf + "%c%s%c", + funny, SVfARG(name), lbrack, key, rbrack, SVfARG(name), + lbrack, key, rbrack); + else + /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Scalar value %c%"SVf"%c%"SVf"%c better written as $%" + SVf"%c%"SVf"%c", + funny, SVfARG(name), lbrack, keysv, rbrack, + SVfARG(name), lbrack, keysv, rbrack); +} + OP * Perl_scalar(pTHX_ OP *o) { @@ -1196,6 +1291,9 @@ Perl_scalar(pTHX_ OP *o) case OP_SORT: Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; + case OP_KVHSLICE: + case OP_KVASLICE: + S_scalar_slice_warning(aTHX_ o); } return o; } @@ -1287,8 +1385,10 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_AELEMFAST: case OP_AELEMFAST_LEX: case OP_ASLICE: + case OP_KVASLICE: case OP_HELEM: case OP_HSLICE: + case OP_KVHSLICE: case OP_UNPACK: case OP_PACK: case OP_JOIN: @@ -1394,29 +1494,16 @@ Perl_scalarvoid(pTHX_ OP *o) else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = NULL; else if (SvPOK(sv)) { - /* perl4's way of mixing documentation and code - (before the invention of POD) was based on a - trick to mix nroff and perl code. The trick was - built upon these three nroff macros being used in - void context. The pink camel has the details in - the script wrapman near page 319. */ - const char * const maybe_macro = SvPVX_const(sv); - if (strnEQ(maybe_macro, "di", 2) || - strnEQ(maybe_macro, "ds", 2) || - strnEQ(maybe_macro, "ig", 2)) - useless = NULL; - else { - SV * const dsv = newSVpvs(""); - useless_sv - = Perl_newSVpvf(aTHX_ - "a constant (%s)", - pv_pretty(dsv, maybe_macro, - SvCUR(sv), 32, NULL, NULL, - PERL_PV_PRETTY_DUMP - | PERL_PV_ESCAPE_NOCLEAR - | PERL_PV_ESCAPE_UNI_DETECT)); - SvREFCNT_dec_NN(dsv); - } + SV * const dsv = newSVpvs(""); + useless_sv + = Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, SvPVX_const(sv), + SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP + | PERL_PV_ESCAPE_NOCLEAR + | PERL_PV_ESCAPE_UNI_DETECT)); + SvREFCNT_dec_NN(dsv); } else if (SvOK(sv)) { useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv); @@ -1777,35 +1864,11 @@ S_finalize_op(pTHX_ OP* o) * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOPo->op_sv) { - const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - 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); - if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); - SvREFCNT_dec(cSVOPo->op_sv); - } - else if (o->op_type != OP_METHOD_NAMED - && cSVOPo->op_sv == &PL_sv_undef) { - /* PL_sv_undef is hack - it's unsafe to store it in the - AV that is the pad, because av_fetch treats values of - PL_sv_undef as a "free" AV entry and will merrily - replace them with a new SV, causing pad_alloc to think - that this pad slot is free. (When, clearly, it is not) - */ - SvOK_off(PAD_SVl(ix)); - SvPADTMP_on(PAD_SVl(ix)); - SvREADONLY_on(PAD_SVl(ix)); - } - else { - SvREFCNT_dec(PAD_SVl(ix)); - SvPADTMP_on(cSVOPo->op_sv); - PAD_SETSV(ix, cSVOPo->op_sv); - /* XXX I don't know how this isn't readonly already. */ - if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); - } + const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(ix)); + PAD_SETSV(ix, cSVOPo->op_sv); + /* XXX I don't know how this isn't readonly already. */ + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); cSVOPo->op_sv = NULL; o->op_targ = ix; } @@ -1825,8 +1888,8 @@ S_finalize_op(pTHX_ OP* o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvIsCOW(sv = *svp)) - && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) { + if ((!SvIsCOW_shared_hash(sv = *svp)) + && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, @@ -1847,9 +1910,7 @@ S_finalize_op(pTHX_ OP* o) fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); if (!fields || !GvHV(*fields)) break; - key = SvPV_const(*svp, keylen); - if (!hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { + if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) { Perl_croak(aTHX_ "No such class field \"%"SVf"\" " "in variable %"SVf" of type %"HEKf, SVfARG(*svp), SVfARG(lexname), @@ -1863,10 +1924,10 @@ S_finalize_op(pTHX_ OP* o) SV *lexname; GV **fields; SV **svp; - const char *key; - STRLEN keylen; SVOP *first_key_op, *key_op; + S_scalar_slice_warning(aTHX_ o); + if ((o->op_private & (OPpLVAL_INTRO)) /* I bet there's always a pushmark... */ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) @@ -1903,9 +1964,7 @@ S_finalize_op(pTHX_ OP* o) if (key_op->op_type != OP_CONST) continue; svp = cSVOPx_svp(key_op); - key = SvPV_const(*svp, keylen); - if (!hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { + if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) { Perl_croak(aTHX_ "No such class field \"%"SVf"\" " "in variable %"SVf" of type %"HEKf, SVfARG(*svp), SVfARG(lexname), @@ -1914,6 +1973,9 @@ S_finalize_op(pTHX_ OP* o) } break; } + case OP_ASLICE: + S_scalar_slice_warning(aTHX_ o); + break; case OP_SUBST: { if (cPMOPo->op_pmreplrootu.op_pmreplroot) @@ -2109,6 +2171,11 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; break; + case OP_KVHSLICE: + case OP_KVASLICE: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + goto nomod; case OP_AV2ARYLEN: PL_hints |= HINT_BLOCK_SCOPE; if (type == OP_LEAVESUBLV) @@ -2601,6 +2668,98 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, attrs))); } +STATIC void +S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) +{ + OP *new_proto = NULL; + STRLEN pvlen; + char *pv; + OP *o; + + PERL_ARGS_ASSERT_MOVE_PROTO_ATTR; + + if (!*attrs) + return; + + o = *attrs; + if (o->op_type == OP_CONST) { + pv = SvPV(cSVOPo_sv, pvlen); + if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { + SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); + SV ** const tmpo = cSVOPx_svp(o); + SvREFCNT_dec(cSVOPo_sv); + *tmpo = tmpsv; + new_proto = o; + *attrs = NULL; + } + } else if (o->op_type == OP_LIST) { + OP * lasto = NULL; + assert(o->op_flags & OPf_KIDS); + assert(cLISTOPo->op_first->op_type == OP_PUSHMARK); + /* Counting on the first op to hit the lasto = o line */ + for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + if (o->op_type == OP_CONST) { + pv = SvPV(cSVOPo_sv, pvlen); + if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { + SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); + SV ** const tmpo = cSVOPx_svp(o); + SvREFCNT_dec(cSVOPo_sv); + *tmpo = tmpsv; + if (new_proto && ckWARN(WARN_MISC)) { + STRLEN new_len; + const char * newp = SvPV(cSVOPo_sv, new_len); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub", + UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); + op_free(new_proto); + } + else if (new_proto) + op_free(new_proto); + new_proto = o; + lasto->op_sibling = o->op_sibling; + continue; + } + } + lasto = o; + } + /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs + would get pulled in with no real need */ + if (!cLISTOPx(*attrs)->op_first->op_sibling) { + op_free(*attrs); + *attrs = NULL; + } + } + + if (new_proto) { + SV *svname; + if (isGV(name)) { + svname = sv_newmortal(); + gv_efullname3(svname, name, NULL); + } + else if (SvPOK(name) && *SvPVX((SV *)name) == '&') + svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP); + else + svname = (SV *)name; + if (ckWARN(WARN_ILLEGALPROTO)) + (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE); + if (*proto && ckWARN(WARN_PROTOTYPE)) { + STRLEN old_len, new_len; + const char * oldp = SvPV(cSVOPx_sv(*proto), old_len); + const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); + + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), + "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'" + " in %"SVf, + UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), + UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), + SVfARG(svname)); + } + if (*proto) + op_free(*proto); + *proto = new_proto; + } +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { @@ -2755,16 +2914,8 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) ) ? (int)rtype : OP_MATCH]; const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; - GV *gv; SV * const name = - (ltype == OP_RV2AV || ltype == OP_RV2HV) - ? cUNOPx(left)->op_first->op_type == OP_GV - && (gv = cGVOPx_gv(cUNOPx(left)->op_first)) - ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1) - : NULL - : varname( - (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1 - ); + S_op_varname(aTHX_ left); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %"SVf" will act on scalar(%"SVf")", @@ -2918,7 +3069,6 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) CALL_BLOCK_HOOKS(bhk_pre_end, &retval); LEAVE_SCOPE(floor); - CopHINTS_set(&PL_compiling, PL_hints); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ o = pad_leavemy(); @@ -3283,6 +3433,11 @@ S_fold_constants(pTHX_ OP *o) break; case OP_REPEAT: if (o->op_private & OPpREPEAT_DOLIST) goto nope; + break; + case OP_SREFGEN: + if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST + || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first))) + goto nope; } if (PL_parser && PL_parser->error_count) @@ -3337,6 +3492,7 @@ S_fold_constants(pTHX_ OP *o) SvREFCNT_inc_simple_void(sv); SvTEMP_off(sv); } + else { assert(SvIMMORTAL(sv)); } break; case 3: /* Something tried to die. Abandon constant folding. */ @@ -3368,10 +3524,15 @@ S_fold_constants(pTHX_ OP *o) op_free(o); #endif assert(sv); + if (type == OP_STRINGIFY) SvPADTMP_off(sv); + else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv); if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else - newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv)); + { + newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); + if (type != OP_STRINGIFY) newop->op_folded = 1; + } op_getmad(o,newop,'f'); return newop; @@ -3384,7 +3545,9 @@ S_gen_constant_list(pTHX_ OP *o) { dVAR; OP *curop; - const I32 oldtmps_floor = PL_tmps_floor; + const SSize_t oldtmps_floor = PL_tmps_floor; + SV **svp; + AV *av; list(o); if (PL_parser && PL_parser->error_count) @@ -3407,7 +3570,11 @@ S_gen_constant_list(pTHX_ OP *o) o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in rpeep() */ curop = ((UNOP*)o)->op_first; - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--)); + av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); + ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av); + if (AvFILLp(av) != -1) + for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) + SvPADTMP_on(*svp); #ifdef PERL_MAD op_getmad(curop,o,'O'); #else @@ -4140,11 +4307,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) rend = r + len; } -/* There are several snags with this code on EBCDIC: - 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). - 2. scan_const() in toke.c has encoded chars in native encoding which makes - ranges at least in EBCDIC 0..255 range the bottom odd. -*/ +/* There is a snag with this code on EBCDIC: scan_const() in toke.c has + * encoded chars in native encoding which makes ranges in the EBCDIC 0..255 + * odd. */ if (complement) { U8 tmpbuf[UTF8_MAXBYTES+1]; @@ -4154,11 +4319,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) i = 0; transv = newSVpvs(""); while (t < tend) { - cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags); + cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags); t += ulen; - if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { + if (t < tend && *t == ILLEGAL_UTF8_BYTE) { t++; - cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags); + cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags); t += ulen; } else { @@ -4171,11 +4336,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) UV val = cp[2*j]; diff = val - nextmin; if (diff > 0) { - t = uvuni_to_utf8(tmpbuf,nextmin); + t = uvchr_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); if (diff > 1) { - U8 range_mark = UTF_TO_NATIVE(0xff); - t = uvuni_to_utf8(tmpbuf, val - 1); + U8 range_mark = ILLEGAL_UTF8_BYTE; + t = uvchr_to_utf8(tmpbuf, val - 1); sv_catpvn(transv, (char *)&range_mark, 1); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } @@ -4184,13 +4349,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (val >= nextmin) nextmin = val + 1; } - t = uvuni_to_utf8(tmpbuf,nextmin); + t = uvchr_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { - U8 range_mark = UTF_TO_NATIVE(0xff); + U8 range_mark = ILLEGAL_UTF8_BYTE; sv_catpvn(transv, (char *)&range_mark, 1); } - t = uvuni_to_utf8(tmpbuf, 0x7fffffff); + t = uvchr_to_utf8(tmpbuf, 0x7fffffff); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); t = (const U8*)SvPVX_const(transv); tlen = SvCUR(transv); @@ -4211,11 +4376,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); + tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); t += ulen; - if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ + if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ t++; - tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); + tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); t += ulen; } else @@ -4225,11 +4390,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { - rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); + rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); r += ulen; - if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ + if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ r++; - rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); + rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); r += ulen; } else @@ -4291,7 +4456,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); #ifdef USE_ITHREADS - cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); + cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY); SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); PAD_SETSV(cPADOPo->op_padix, swash); SvPADTMP_on(swash); @@ -4397,7 +4562,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if(del && rlen == tlen) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); - } else if(rlen > tlen) { + } else if(rlen > tlen && !complement) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); } @@ -4800,10 +4965,6 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) if (repl) { OP *curop = repl; bool konst; - if (pm->op_pmflags & PMf_EVAL) { - if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end) - CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end); - } /* If we are looking at s//.../e with a single statement, get past the implicit do{}. */ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS @@ -4944,7 +5105,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) return CHECKOP(type, padop); } -#endif /* !USE_ITHREADS */ +#endif /* USE_ITHREADS */ /* =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv @@ -5392,7 +5553,8 @@ S_is_list_assignment(pTHX_ const OP *o) if (type == OP_LIST || flags & OPf_PARENS || type == OP_RV2AV || type == OP_RV2HV || - type == OP_ASLICE || type == OP_HSLICE) + type == OP_ASLICE || type == OP_HSLICE || + type == OP_KVASLICE || type == OP_KVHSLICE) return TRUE; if (type == OP_PADAV || type == OP_PADHV) @@ -5443,24 +5605,20 @@ S_aassign_common_vars(pTHX_ OP* o) return TRUE; } else if (curop->op_type == OP_PUSHRE) { + GV *const gv = #ifdef USE_ITHREADS - if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { - GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)); - if (gv == PL_defgv - || (int)GvASSIGN_GENERATION(gv) == PL_generation) - return TRUE; - GvASSIGN_GENERATION_set(gv, PL_generation); - } + ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff + ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)) + : NULL; #else - GV *const gv - = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; + ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; +#endif if (gv) { if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) return TRUE; GvASSIGN_GENERATION_set(gv, PL_generation); } -#endif } else return TRUE; @@ -5521,6 +5679,9 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP *curop; bool maybe_common_vars = TRUE; + if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) + left->op_private &= ~ OPpSLICEWARNING; + PL_modcount = 0; left = op_lvalue(left, OP_AASSIGN); curop = list(force_list(left)); @@ -5646,9 +5807,22 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { - SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV ** const svp = + &((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV * const sv = *svp; if (SvIOK(sv) && SvIVX(sv) == 0) + { + if (right->op_private & OPpSPLIT_IMPLIM) { + /* our own SV, created in ck_split */ + SvREADONLY_off(sv); sv_setiv(sv, PL_modcount+1); + } + else { + /* SV may belong to someone else */ + SvREFCNT_dec(sv); + *svp = newSViv(PL_modcount+1); + } + } } } } @@ -5711,7 +5885,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif - CopHINTS_set(&PL_compiling, CopHINTS_get(cop)); cop->op_next = (OP*)cop; cop->cop_seq = seq; @@ -5727,7 +5900,11 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) SAVEFREEPV(label); } - if (PL_parser && PL_parser->copline == NOLINE) + if (PL_parser->preambling != NOLINE) { + CopLINE_set(cop, PL_parser->preambling); + PL_parser->copline = NOLINE; + } + else if (PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); else { CopLINE_set(cop, PL_parser->copline); @@ -5744,7 +5921,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) /* this line can have a breakpoint - store the cop in IV */ AV *av = CopFILEAVx(PL_curcop); if (av) { - SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); + SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); if (svp && *svp != &PL_sv_undef ) { (void)SvIOK_on(*svp); SvIV_set(*svp, PTR2IV(cop)); @@ -5840,6 +6017,44 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first = *firstp; other = *otherp; + /* [perl #59802]: Warn about things like "return $a or $b", which + is parsed as "(return $a) or $b" rather than "return ($a or + $b)". NB: This also applies to xor, which is why we do it + here. + */ + switch (first->op_type) { + case OP_NEXT: + case OP_LAST: + case OP_REDO: + /* XXX: Perhaps we should emit a stronger warning for these. + Even with the high-precedence operator they don't seem to do + anything sensible. + + But until we do, fall through here. + */ + case OP_RETURN: + case OP_EXIT: + case OP_DIE: + case OP_GOTO: + /* XXX: Currently we allow people to "shoot themselves in the + foot" by explicitly writing "(return $a) or $b". + + Warn unless we are looking at the result from folding or if + the programmer explicitly grouped the operators like this. + The former can occur with e.g. + + use constant FEATURE => ( $] >= ... ); + sub { not FEATURE and return or do_stuff(); } + */ + if (!first->op_folded && !(first->op_flags & OPf_PARENS)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Possible precedence issue with control flow operator"); + /* XXX: Should we optimze this to "return $a;" (i.e. remove + the "or $b" part)? + */ + break; + } + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); @@ -5891,8 +6106,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) || other->op_type == OP_TRANS) /* Mark the op as being unbindable with =~ */ other->op_flags |= OPf_SPECIAL; - else if (other->op_type == OP_CONST) - other->op_private |= OPpCONST_FOLDED; + + other->op_folded = 1; return other; } else { @@ -5914,8 +6129,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } *otherp = NULL; - if (first->op_type == OP_CONST) - first->op_private |= OPpCONST_SHORTCIRCUIT; + if (cstop->op_type == OP_CONST) + cstop->op_private |= OPpCONST_SHORTCIRCUIT; if (PL_madskills) { first = newUNOP(OP_NULL, 0, first); op_getmad(other, first, '2'); @@ -6052,8 +6267,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) || live->op_type == OP_TRANS || live->op_type == OP_TRANSR) /* Mark the op as being unbindable with =~ */ live->op_flags |= OPf_SPECIAL; - else if (live->op_type == OP_CONST) - live->op_private |= OPpCONST_FOLDED; + live->op_folded = 1; return live; } NewOp(1101, logop, 1, LOGOP); @@ -6585,7 +6799,9 @@ S_ref_array_or_hash(pTHX_ OP *cond) else if(cond && (cond->op_type == OP_ASLICE - || cond->op_type == OP_HSLICE)) { + || cond->op_type == OP_KVASLICE + || cond->op_type == OP_HSLICE + || cond->op_type == OP_KVHSLICE)) { /* anonlist now needs a list from this op, was previously used in * scalar context */ @@ -6796,55 +7012,65 @@ void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { - const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv); - const STRLEN clen = CvPROTOLEN(cv); + SV *name = NULL, *msg; + const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); + STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; - if (((!p != !cvp) /* One has prototype, one has not. */ - || (p && ( - (flags & SVf_UTF8) == SvUTF8(cv) - ? len != clen || memNE(cvp, p, len) - : flags & SVf_UTF8 - ? bytes_cmp_utf8((const U8 *)cvp, clen, - (const U8 *)p, len) - : bytes_cmp_utf8((const U8 *)p, len, - (const U8 *)cvp, clen) - ) - ) - ) - && ckWARN_d(WARN_PROTOTYPE)) { - SV* const msg = sv_newmortal(); - SV* name = NULL; + if (p == NULL && cvp == NULL) + return; - if (gv) - { - if (isGV(gv)) - gv_efullname3(name = sv_newmortal(), gv, NULL); - else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') - name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, - SvUTF8(gv)|SVs_TEMP); - else name = (SV *)gv; - } - sv_setpvs(msg, "Prototype mismatch:"); - if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); - if (cvp) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", - SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP)) - ); - else - sv_catpvs(msg, ": none"); - sv_catpvs(msg, " vs "); - if (p) - Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP))); - else - sv_catpvs(msg, "none"); - Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); + if (!ckWARN_d(WARN_PROTOTYPE)) + return; + + if (p && cvp) { + p = S_strip_spaces(aTHX_ p, &plen); + cvp = S_strip_spaces(aTHX_ cvp, &clen); + if ((flags & SVf_UTF8) == SvUTF8(cv)) { + if (plen == clen && memEQ(cvp, p, plen)) + return; + } else { + if (flags & SVf_UTF8) { + if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) + return; + } + else { + if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) + return; + } + } } + + msg = sv_newmortal(); + + if (gv) + { + if (isGV(gv)) + gv_efullname3(name = sv_newmortal(), gv, NULL); + else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') + name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else name = (SV *)gv; + } + sv_setpvs(msg, "Prototype mismatch:"); + if (name) + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); + if (cvp) + Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")", + UTF8fARG(SvUTF8(cv),clen,cvp) + ); + else + sv_catpvs(msg, ": none"); + sv_catpvs(msg, " vs "); + if (p) + Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p)); + else + sv_catpvs(msg, "none"); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); } static void const_sv_xsub(pTHX_ CV* cv); +static void const_av_xsub(pTHX_ CV* cv); /* @@ -6863,37 +7089,32 @@ L. SV * Perl_cv_const_sv(pTHX_ const CV *const cv) { + SV *sv; PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) return NULL; + sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; + if (sv && SvTYPE(sv) == SVt_PVAV) return NULL; + return sv; +} + +SV * +Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) +{ + PERL_UNUSED_CONTEXT; + if (!cv) + return NULL; + assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } /* op_const_sv: examine an optree to determine whether it's in-lineable. - * Can be called in 3 ways: - * - * !cv - * look for a single OP_CONST with attached value: return the value - * - * cv && CvCLONE(cv) && !CvCONST(cv) - * - * examine the clone prototype, and if contains only a single - * OP_CONST referencing a pad const, or a single PADSV referencing - * an outer lexical, return a non-zero value to indicate the CV is - * a candidate for "constizing" at clone time - * - * cv && CvCONST(cv) - * - * We have just cloned an anon prototype that was marked as a const - * candidate. Try to grab the current value, and in the case of - * PADSV, ignore it if it has multiple references. In this case we - * return a newly created *copy* of the value. */ SV * -Perl_op_const_sv(pTHX_ const OP *o, CV *cv) +Perl_op_const_sv(pTHX_ const OP *o) { dVAR; SV *sv = NULL; @@ -6926,27 +7147,6 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; - else if (cv && type == OP_CONST) { - sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - if (!sv) - return NULL; - } - else if (cv && type == OP_PADSV) { - if (CvCONST(cv)) { /* newly cloned anon */ - sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - /* the candidate should have 1 ref from this pad and 1 ref - * from the parent */ - if (!sv || SvREFCNT(sv) != 2) - return NULL; - sv = newSVsv(sv); - SvREADONLY_on(sv); - return sv; - } - else { - if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) - sv = &PL_sv_undef; /* an arbitrary non-null value */ - } - } else { return NULL; } @@ -7053,6 +7253,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; spot = (CV **)svspot; + if (!(PL_parser && PL_parser->error_count)) + move_proto_attr(&proto, &attrs, (GV *)name); + if (proto) { assert(proto->op_type == OP_CONST); ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); @@ -7115,7 +7318,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ) const_sv = NULL; else - const_sv = op_const_sv(block, NULL); + const_sv = op_const_sv(block); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7144,6 +7347,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7286,12 +7490,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); - if (CvCLONE(cv)) { - assert(!CvCONST(cv)); - if (ps && !*ps && op_const_sv(block, cv)) - CvCONST_on(cv); - } - attrs: if (attrs) { /* Need to do a C. */ @@ -7399,14 +7597,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OPSLAB *slab = NULL; #endif - if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); - ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); - } - else - ps = NULL; - if (o_is_gv) { gv = (GV*)o; o = NULL; @@ -7429,6 +7619,17 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, has_name = FALSE; } + if (!ec) + move_proto_attr(&proto, &attrs, gv); + + if (proto) { + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); + } + else + ps = NULL; + if (!PL_madskills) { if (o) SAVEFREEOP(o); @@ -7489,7 +7690,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, ) const_sv = NULL; else - const_sv = op_const_sv(block, NULL); + const_sv = op_const_sv(block); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7514,6 +7715,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7649,12 +7851,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); - if (CvCLONE(cv)) { - assert(!CvCONST(cv)); - if (ps && !*ps && op_const_sv(block, cv)) - CvCONST_on(cv); - } - attrs: if (attrs) { /* Need to do a C. */ @@ -7729,7 +7925,6 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GvCV_set(gv,0); /* cv has been hijacked */ call_list(oldscope, PL_beginav); - CopHINTS_set(&PL_compiling, PL_hints); LEAVE; } else @@ -7814,12 +8009,7 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, { dVAR; CV* cv; -#ifdef USE_ITHREADS const char *const file = CopFILE(PL_curcop); -#else - SV *const temp_sv = CopFILESV(PL_curcop); - const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL; -#endif ENTER; @@ -7850,7 +8040,11 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ - cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "", + cv = newXS_len_flags(name, len, + sv && SvTYPE(sv) == SVt_PVAV + ? const_av_xsub + : const_sv_xsub, + file ? file : "", "", &sv, XS_DYNAMIC_FILENAME | flags); CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); CvCONST_on(cv); @@ -7949,13 +8143,19 @@ CV * Perl_newSTUB(pTHX_ GV *gv, bool fake) { CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GV *cvgv; PERL_ARGS_ASSERT_NEWSTUB; assert(!GvCVu(gv)); GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (!fake && HvENAME_HEK(GvSTASH(gv))) gv_method_changed(gv); - CvGV_set(cv, gv); + if (SvFAKE(gv)) { + cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); + SvFAKE_off(cvgv); + } + else cvgv = gv; + CvGV_set(cv, cvgv); CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); GvMULTI_on(gv); @@ -8088,11 +8288,13 @@ Perl_oopsAV(pTHX_ OP *o) switch (o->op_type) { case OP_PADSV: + case OP_PADHV: o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; return ref(o, OP_RV2AV); case OP_RV2SV: + case OP_RV2HV: o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; ref(o, OP_RV2AV); @@ -8346,9 +8548,15 @@ Perl_ck_delete(pTHX_ OP *o) /* FALL THROUGH */ case OP_HELEM: break; + case OP_KVASLICE: + Perl_croak(aTHX_ "delete argument is index/value array slice," + " use array slice"); + case OP_KVHSLICE: + Perl_croak(aTHX_ "delete argument is key/value hash slice, use" + " hash slice"); default: - Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", - OP_DESC(o)); + Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " + "element or slice"); } if (kid->op_private & OPpLVAL_INTRO) o->op_private |= OPpLVAL_INTRO; @@ -8405,12 +8613,9 @@ Perl_ck_eval(pTHX_ OP *o) PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { SVOP * const kid = (SVOP*)cUNOPo->op_first; + assert(kid); - if (!kid) { - o->op_flags &= ~OPf_KIDS; - op_null(o); - } - else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { + if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; #ifdef PERL_MAD OP* const oldo = o; @@ -8515,15 +8720,15 @@ Perl_ck_exists(pTHX_ OP *o) (void) ref(kid, o->op_type); if (kid->op_type != OP_RV2CV && !(PL_parser && PL_parser->error_count)) - Perl_croak(aTHX_ "%s argument is not a subroutine name", - OP_DESC(o)); + Perl_croak(aTHX_ + "exists argument is not a subroutine name"); o->op_private |= OPpEXISTS_SUB; } else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", - OP_DESC(o)); + Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " + "element or a subroutine"); op_null(kid); } return o; @@ -8574,6 +8779,7 @@ Perl_ck_rvconst(pTHX_ OP *o) Perl_croak(aTHX_ "Constant is not %s reference", badtype); return o; } + if (SvTYPE(kidsv) == SVt_PVAV) return o; if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { const char *badthing; switch (o->op_type) { @@ -8655,7 +8861,7 @@ Perl_ck_ftst(pTHX_ OP *o) const OPCODE kidtype = kid->op_type; if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) - && !(kid->op_private & OPpCONST_FOLDED)) { + && !kid->op_folded) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); #ifdef PERL_MAD @@ -8937,11 +9143,12 @@ Perl_ck_fun(pTHX_ OP *o) } if (name) { SV *namesv; - targ = pad_alloc(OP_RV2GV, SVs_PADTMP); + targ = pad_alloc(OP_RV2GV, SVf_READONLY); namesv = PAD_SVl(targ); - SvUPGRADE(namesv, SVt_PV); if (want_dollar && *name != '$') sv_setpvs(namesv, "$"); + else + sv_setpvs(namesv, ""); sv_catpvn(namesv, name, len); if ( name_utf8 ) SvUTF8_on(namesv); } @@ -9133,7 +9340,14 @@ Perl_ck_index(pTHX_ OP *o) kid = kid->op_sibling; /* get past "big" */ if (kid && kid->op_type == OP_CONST) { const bool save_taint = TAINT_get; - fbm_compile(((SVOP*)kid)->op_sv, 0); + SV *sv = kSVOP->op_sv; + if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) { + sv = newSV(0); + sv_copypv(sv, kSVOP->op_sv); + SvREFCNT_dec_NN(kSVOP->op_sv); + kSVOP->op_sv = sv; + } + if (SvOK(sv)) fbm_compile(sv, 0); TAINT_set(save_taint); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(save_taint); @@ -9233,7 +9447,7 @@ Perl_ck_listiob(pTHX_ OP *o) kid = kid->op_sibling; else if (kid && !kid->op_sibling) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE - && !(kid->op_private & OPpCONST_FOLDED)) { + && !kid->op_folded) { o->op_flags |= OPf_STACKED; /* make it a filehandle */ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); cLISTOPo->op_first->op_sibling = kid; @@ -9380,7 +9594,7 @@ Perl_ck_method(pTHX_ OP *o) const char * const method = SvPVX_const(sv); if (!(strchr(method, ':') || strchr(method, '\''))) { OP *cmop; - if (!SvIsCOW(sv)) { + if (!SvIsCOW_shared_hash(sv)) { sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0); } else { @@ -9636,7 +9850,10 @@ Perl_ck_sort(pTHX_ OP *o) { dVAR; OP *firstkid; - HV * const hinthv = GvHV(PL_hintgv); + OP *kid; + HV * const hinthv = + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; + U8 stacked; PERL_ARGS_ASSERT_CK_SORT; @@ -9654,7 +9871,7 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ + if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { @@ -9673,8 +9890,12 @@ Perl_ck_sort(pTHX_ OP *o) firstkid = firstkid->op_sibling; } - /* provide list context for arguments */ - list(firstkid); + for (kid = firstkid; kid; kid = kid->op_sibling) { + /* provide list context for arguments */ + list(kid); + if (stacked) + op_lvalue(kid, OP_GREPSTART); + } return o; } @@ -9692,8 +9913,6 @@ S_simplify_sort(pTHX_ OP *o) PERL_ARGS_ASSERT_SIMPLIFY_SORT; - if (!(o->op_flags & OPf_STACKED)) - return; GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)); GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)); kid = kUNOP->op_first; /* get past null */ @@ -9834,7 +10053,10 @@ Perl_ck_split(pTHX_ OP *o) scalar(kid); if (!kid->op_sibling) + { op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); + o->op_private |= OPpSPLIT_IMPLIM; + } assert(kid->op_sibling); kid = kid->op_sibling; @@ -10056,6 +10278,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (SvTYPE(protosv) == SVt_PVCV) proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); else proto = SvPV(protosv, proto_len); + proto = S_strip_spaces(aTHX_ proto, &proto_len); proto_end = proto + proto_len; aop = cUNOPx(entersubop)->op_first; if (!aop->op_sibling) @@ -10100,9 +10323,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) proto++; arg++; if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) - bad_type_sv(arg, + bad_type_gv(arg, arg == 1 ? "block or sub {}" : "sub {}", - gv_ename(namegv), 0, o3); + namegv, 0, o3); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -10187,9 +10410,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s", + bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), - gv_ename(namegv), 0, o3); + namegv, 0, o3); } else goto oops; break; @@ -10197,13 +10420,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) - bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3); + bad_type_gv(arg, "symbol", namegv, 0, o3); break; case '&': if (o3->op_type == OP_ENTERSUB) goto wrapref; if (!contextclass) - bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0, + bad_type_gv(arg, "subroutine entry", namegv, 0, o3); break; case '$': @@ -10219,7 +10442,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3); + bad_type_gv(arg, "scalar", namegv, 0, o3); } break; case '@': @@ -10227,14 +10450,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) o3->op_type == OP_PADAV) goto wrapref; if (!contextclass) - bad_type_sv(arg, "array", gv_ename(namegv), 0, o3); + bad_type_gv(arg, "array", namegv, 0, o3); break; case '%': if (o3->op_type == OP_RV2HV || o3->op_type == OP_PADHV) goto wrapref; if (!contextclass) - bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3); + bad_type_gv(arg, "hash", namegv, 0, o3); break; wrapref: { @@ -10574,9 +10797,23 @@ Perl_ck_subr(pTHX_ OP *o) OP * Perl_ck_svconst(pTHX_ OP *o) { + SV * const sv = cSVOPo->op_sv; PERL_ARGS_ASSERT_CK_SVCONST; PERL_UNUSED_CONTEXT; - if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv); +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(sv)) sv_force_normal(sv); +#elif defined(PERL_NEW_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 + that constant, mark the constant as COWable here, if it is not + already read-only. */ + if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { + SvIsCOW_on(sv); + CowREFCNT(sv) = 0; + } +#endif + SvREADONLY_on(sv); return o; } @@ -10591,8 +10828,8 @@ Perl_ck_trunc(pTHX_ OP *o) if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; if (kid && kid->op_type == OP_CONST && - (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED)) - == OPpCONST_BARE) + (kid->op_private & OPpCONST_BARE) && + !kid->op_folded) { o->op_flags |= OPf_SPECIAL; kid->op_private &= ~OPpCONST_STRICT; @@ -10688,19 +10925,9 @@ Perl_ck_length(pTHX_ OP *o) switch (kid->op_type) { case OP_PADHV: case OP_PADAV: - name = varname( - (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ, - NULL, 0, 1 - ); - break; case OP_RV2HV: case OP_RV2AV: - if (cUNOPx(kid)->op_first->op_type != OP_GV) break; - { - GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first); - if (!gv) break; - name = varname(gv, hash?'%':'@', 0, NULL, 0, 1); - } + name = S_op_varname(aTHX_ kid); break; default: return o; @@ -10712,9 +10939,11 @@ Perl_ck_length(pTHX_ OP *o) name, hash ? "keys " : "", name ); else if (hash) + /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); else + /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "length() used on @array (did you mean \"scalar(@array)\"?)"); } @@ -11131,9 +11360,14 @@ Perl_rpeep(pTHX_ OP *o) old_count = (oldoldop->op_private & OPpPADRANGE_COUNTMASK); - assert(oldoldop->op_targ + old_count == base); - if (old_count < OPpPADRANGE_COUNTMASK - count) { + /* Do not assume pad offsets for $c and $d are con- + tiguous in + my ($a,$b,$c); + my ($d,$e,$f); + */ + if ( oldoldop->op_targ + old_count == base + && old_count < OPpPADRANGE_COUNTMASK - count) { base = oldoldop->op_targ; count += old_count; reuse = 1; @@ -11158,8 +11392,8 @@ Perl_rpeep(pTHX_ OP *o) && ( p->op_next->op_type == OP_NEXTSTATE || p->op_next->op_type == OP_DBSTATE) && count < OPpPADRANGE_COUNTMASK + && base + count == p->op_targ ) { - assert(base + count == p->op_targ); count++; followop = p->op_next; } @@ -11939,14 +12173,7 @@ const_sv_xsub(pTHX_ CV* cv) dVAR; dXSARGS; SV *const sv = MUTABLE_SV(XSANY.any_ptr); - if (items != 0) { - NOOP; -#if 0 - /* diag_listed_as: SKIPME */ - Perl_croak(aTHX_ "usage: %s::%s()", - HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); -#endif - } + PERL_UNUSED_ARG(items); if (!sv) { XSRETURN(0); } @@ -11955,6 +12182,31 @@ const_sv_xsub(pTHX_ CV* cv) XSRETURN(1); } +static void +const_av_xsub(pTHX_ CV* cv) +{ + dVAR; + dXSARGS; + AV * const av = MUTABLE_AV(XSANY.any_ptr); + SP -= items; + assert(av); +#ifndef DEBUGGING + if (!av) { + XSRETURN(0); + } +#endif + if (SvRMAGICAL(av)) + Perl_croak(aTHX_ "Magical list constants are not supported"); + if (GIMME_V != G_ARRAY) { + EXTEND(SP, 1); + ST(0) = newSViv((IV)AvFILLp(av)+1); + XSRETURN(1); + } + EXTEND(SP, AvFILLp(av)+1); + Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *); + XSRETURN(AvFILLp(av)+1); +} + /* * Local variables: * c-indentation-style: bsd