X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0845736aa911ed8d7568022034b29a5eeec529a7..7ff1117359e03ce00638e9ee1daad537321e75d6:/op.c diff --git a/op.c b/op.c index 40df34a..46e8e7d 100644 --- a/op.c +++ b/op.c @@ -1145,17 +1145,32 @@ S_op_varname(pTHX_ const OP *o) } static void +S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) +{ /* or not so pretty :-) */ + if (o->op_type == OP_CONST) { + *retsv = cSVOPo_sv; + if (SvPOK(*retsv)) { + SV *sv = *retsv; + *retsv = sv_newmortal(); + pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); + } + else if (!SvOK(*retsv)) + *retpv = "undef"; + } + else *retpv = "..."; +} + +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 ? '{' : '['; + 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 ? '@' : '%'; + o->op_type == OP_HSLICE ? '}' : ']'; SV *name; - SV *keysv; + SV *keysv = NULL; /* just to silence compiler warnings */ const char *key = NULL; if (!(o->op_private & OPpSLICEWARNING)) @@ -1199,33 +1214,22 @@ S_scalar_slice_warning(pTHX_ const OP *o) 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 = "..."; + S_op_pretty(aTHX_ kid, &keysv, &key); assert(SvPOK(name)); sv_chop(name,SvPVX(name)+1); if (key) - /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */ + /* 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 + "Scalar value @%"SVf"%c%s%c better written as $%"SVf "%c%s%c", - funny, SVfARG(name), lbrack, key, rbrack, SVfARG(name), + SVfARG(name), lbrack, key, rbrack, SVfARG(name), lbrack, key, rbrack); else - /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */ + /* 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 $%" + "Scalar value @%"SVf"%c%"SVf"%c better written as $%" SVf"%c%"SVf"%c", - funny, SVfARG(name), lbrack, keysv, rbrack, + SVfARG(name), lbrack, keysv, rbrack, SVfARG(name), lbrack, keysv, rbrack); } @@ -1293,7 +1297,44 @@ Perl_scalar(pTHX_ OP *o) break; case OP_KVHSLICE: case OP_KVASLICE: - S_scalar_slice_warning(aTHX_ o); + { + /* Warn about scalar context */ + const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '['; + const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']'; + SV *name; + SV *keysv; + const char *key = NULL; + + /* This warning can be nonsensical when there is a syntax error. */ + if (PL_parser && PL_parser->error_count) + break; + + if (!ckWARN(WARN_SYNTAX)) break; + + kid = cLISTOPo->op_first; + kid = kid->op_sibling; /* get past pushmark */ + assert(kid->op_sibling); + name = S_op_varname(aTHX_ kid->op_sibling); + if (!name) /* XS module fiddling with the op tree */ + break; + S_op_pretty(aTHX_ kid, &keysv, &key); + assert(SvPOK(name)); + sv_chop(name,SvPVX(name)+1); + if (key) + /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "%%%"SVf"%c%s%c in scalar context better written " + "as $%"SVf"%c%s%c", + SVfARG(name), lbrack, key, rbrack, SVfARG(name), + lbrack, key, rbrack); + else + /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "%%%"SVf"%c%"SVf"%c in scalar context better " + "written as $%"SVf"%c%"SVf"%c", + SVfARG(name), lbrack, keysv, rbrack, + SVfARG(name), lbrack, keysv, rbrack); + } } return o; } @@ -1879,7 +1920,6 @@ S_finalize_op(pTHX_ OP* o) UNOP *rop; SV *lexname; GV **fields; - SV **svp, *sv; SVOP *key_op; OP *kid; bool check_fields; @@ -1894,6 +1934,7 @@ S_finalize_op(pTHX_ OP* o) case OP_HSLICE: S_scalar_slice_warning(aTHX_ o); + case OP_KVHSLICE: if (/* I bet there's always a pushmark... */ (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST && kid->op_type != OP_CONST) @@ -1922,6 +1963,9 @@ S_finalize_op(pTHX_ OP* o) rop = NULL; } + lexname = NULL; /* just to silence compiler warnings */ + fields = NULL; /* just to silence compiler warnings */ + check_fields = rop && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE), @@ -2544,7 +2588,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) PERL_ARGS_ASSERT_APPLY_ATTRS; /* fake up C */ - ENTER; /* need to protect against side-effects of 'use' */ #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" @@ -2558,7 +2601,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); - LEAVE; } STATIC void @@ -2578,7 +2620,6 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ - ENTER; /* need to protect against side-effects of 'use' */ /* Don't force the C if we don't need it. */ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) @@ -2586,7 +2627,6 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) else Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs(ATTRSMODULE), NULL); - LEAVE; /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); @@ -2756,6 +2796,22 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) } } +static void +S_cant_declare(pTHX_ OP *o) +{ + if (o->op_type == OP_NULL + && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS) + o = cUNOPo->op_first; + yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", + o->op_type == OP_NULL + && o->op_flags & OPf_SPECIAL + ? "do block" + : OP_DESC(o), + PL_parser->in_my == KEY_our ? "our" : + PL_parser->in_my == KEY_state ? "state" : + "my")); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { @@ -2785,11 +2841,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ - yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - OP_DESC(o), - PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); + S_cant_declare(aTHX_ o); } else if (attrs) { GV * const gv = cGVOPx_gv(cUNOPo->op_first); PL_parser->in_my = FALSE; @@ -2808,11 +2860,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type != OP_PADHV && type != OP_PUSHMARK) { - yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - OP_DESC(o), - PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); + S_cant_declare(aTHX_ o); return o; } else if (attrs && type != OP_PUSHMARK) { @@ -2935,8 +2983,10 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) /* !~ doesn't make sense with /r, so error on it for now */ if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ yyerror("Using !~ with s///r doesn't make sense"); if (rtype == OP_TRANSR && type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ yyerror("Using !~ with tr///r doesn't make sense"); ismatchop = (rtype == OP_MATCH || @@ -3521,7 +3571,10 @@ S_fold_constants(pTHX_ OP *o) #endif assert(sv); if (type == OP_STRINGIFY) SvPADTMP_off(sv); - else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv); + else if (!SvIMMORTAL(sv)) { + SvPADTMP_on(sv); + SvREADONLY_on(sv); + } if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else @@ -3570,7 +3623,10 @@ S_gen_constant_list(pTHX_ OP *o) ((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); + SvREADONLY_on(*svp); + } #ifdef PERL_MAD op_getmad(curop,o,'O'); #else @@ -5454,7 +5510,8 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) * that it has a PL_parser to play with while doing that, and also * that it doesn't mess with any existing parser, by creating a tmp * new parser with lex_start(). This won't actually be used for much, - * since pp_require() will create another parser for the real work. */ + * since pp_require() will create another parser for the real work. + * The ENTER/LEAVE pair protect callers from any side effects of use. */ ENTER; SAVEVPTR(PL_curcop); @@ -5464,28 +5521,26 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) LEAVE; } +PERL_STATIC_INLINE OP * +S_new_entersubop(pTHX_ GV *gv, OP *arg) +{ + return newUNOP(OP_ENTERSUB, OPf_STACKED, + newLISTOP(OP_LIST, 0, arg, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv)))); +} + OP * Perl_dofile(pTHX_ OP *term, I32 force_builtin) { dVAR; OP *doop; - GV *gv = NULL; + GV *gv; PERL_ARGS_ASSERT_DOFILE; - if (!force_builtin) { - gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV); - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { - GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE); - gv = gvp ? *gvp : NULL; - } - } - - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { - doop = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, term, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv))))); + if (!force_builtin && (gv = gv_override("do", 2))) { + doop = S_new_entersubop(aTHX_ gv, term); } else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); @@ -5881,6 +5936,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif +#ifdef VMS + if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH; +#endif cop->op_next = (OP*)cop; cop->cop_seq = seq; @@ -6384,12 +6442,20 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && - (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); + block->op_type == OP_NULL; PERL_UNUSED_ARG(debuggable); if (expr) { - if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + if (once && ( + (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + || ( expr->op_type == OP_NOT + && cUNOPx(expr)->op_first->op_type == OP_CONST + && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) + ) + )) + /* Return the block now, so that S_new_logop does not try to + fold it away. */ return block; /* do {} while 0 does once */ if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR @@ -6428,11 +6494,19 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); o = new_logop(OP_AND, 0, &expr, &listop); + if (once) { + ASSUME(listop); + } + if (listop) ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) + { + assert(cUNOPo->op_first->op_type == OP_AND + || cUNOPo->op_first->op_type == OP_OR); o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; + } if (o == listop) o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ @@ -7203,7 +7277,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, #endif { /* (PL_madskills unset in used file.) */ - SvREFCNT_dec(cv); + SAVEFREESV(cv); } return TRUE; } @@ -7327,7 +7401,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8); /* already defined? */ if (exists) { - if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv)) + if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv)) cv = NULL; else { if (attrs) goto attrs; @@ -7555,15 +7629,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) return cv; } +/* _x = extended */ CV * -Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) -{ - return newATTRSUB_flags(floor, o, proto, attrs, block, 0); -} - -CV * -Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, - OP *block, U32 flags) +Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, bool o_is_gv) { dVAR; GV *gv; @@ -7584,7 +7653,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; - const bool o_is_gv = flags & 1; const char * const name = o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; @@ -7910,8 +7978,10 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (*name == 'B') { if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; + dSP; if (floor) LEAVE_SCOPE(floor); ENTER; + PUSHSTACKi(PERLSI_REQUIRE); SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); SAVEVPTR(PL_curcop); @@ -7921,6 +7991,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GvCV_set(gv,0); /* cv has been hijacked */ call_list(oldscope, PL_beginav); + POPSTACK; LEAVE; } else @@ -8068,6 +8139,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, U32 flags) { CV *cv; + bool interleave = FALSE; PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; @@ -8097,7 +8169,9 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, ), cv, const_svp); } - SvREFCNT_dec_NN(cv); + interleave = TRUE; + ENTER; + SAVEFREESV(cv); cv = NULL; } } @@ -8132,6 +8206,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, CvDYNFILE_on(cv); } sv_setpv(MUTABLE_SV(cv), proto); + if (interleave) LEAVE; return cv; } @@ -8417,6 +8492,62 @@ Perl_ck_anoncode(pTHX_ OP *o) return o; } +static void +S_io_hints(pTHX_ OP *o) +{ + HV * const table = + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; + if (table) { + SV **svp = hv_fetchs(table, "open_IN", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; + } + + svp = hv_fetchs(table, "open_OUT", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; + } + } +} + +OP * +Perl_ck_backtick(pTHX_ OP *o) +{ + GV *gv; + OP *newop = NULL; + PERL_ARGS_ASSERT_CK_BACKTICK; + /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */ + if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling + && (gv = gv_override("readpipe",8))) { + newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling); + cUNOPo->op_first->op_sibling = NULL; + } + else if (!(o->op_flags & OPf_KIDS)) + newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); + if (newop) { +#ifdef PERL_MAD + op_getmad(o,newop,'O'); +#else + op_free(o); +#endif + return newop; + } + S_io_hints(aTHX_ o); + return o; +} + OP * Perl_ck_bitop(pTHX_ OP *o) { @@ -8562,17 +8693,6 @@ Perl_ck_delete(pTHX_ OP *o) } OP * -Perl_ck_die(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_CK_DIE; - -#ifdef VMS - if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; -#endif - return ck_fun(o); -} - -OP * Perl_ck_eof(pTHX_ OP *o) { dVAR; @@ -8669,23 +8789,6 @@ Perl_ck_eval(pTHX_ OP *o) } OP * -Perl_ck_exit(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_CK_EXIT; - -#ifdef VMS - HV * const table = GvHV(PL_hintgv); - if (table) { - SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE); - if (svp && *svp && SvTRUE(*svp)) - o->op_private |= OPpEXIT_VMSISH; - } - if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; -#endif - return ck_fun(o); -} - -OP * Perl_ck_exec(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_EXEC; @@ -8959,7 +9062,7 @@ Perl_ck_fun(pTHX_ OP *o) { return too_many_arguments_pv(o,PL_op_desc[type], 0); } - scalar(kid); + if (type != OP_DELETE) scalar(kid); break; case OA_LIST: if (oa < 16) { @@ -9209,7 +9312,6 @@ Perl_ck_glob(pTHX_ OP *o) { dVAR; GV *gv; - const bool core = o->op_flags & OPf_SPECIAL; PERL_ARGS_ASSERT_CK_GLOB; @@ -9217,16 +9319,8 @@ Perl_ck_glob(pTHX_ OP *o) if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ - if (core) gv = NULL; - else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) - && GvCVu(gv) && GvIMPORTED_CV(gv))) + if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) { - GV * const * const gvp = - (GV **)hv_fetchs(PL_globalstash, "glob", FALSE); - gv = gvp ? *gvp : NULL; - } - - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { /* convert * glob * \ null - const(wildcard) @@ -9241,11 +9335,7 @@ Perl_ck_glob(pTHX_ OP *o) */ o->op_flags |= OPf_SPECIAL; o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); - o = newLISTOP(OP_LIST, 0, o, NULL); - o = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, o, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv))))); + o = S_new_entersubop(aTHX_ gv, o); o = newUNOP(OP_NULL, 0, o); o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ return o; @@ -9620,46 +9710,10 @@ OP * Perl_ck_open(pTHX_ OP *o) { dVAR; - HV * const table = - PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; PERL_ARGS_ASSERT_CK_OPEN; - if (table) { - SV **svp = hv_fetchs(table, "open_IN", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); - if (mode & O_BINARY) - o->op_private |= OPpOPEN_IN_RAW; - else if (mode & O_TEXT) - o->op_private |= OPpOPEN_IN_CRLF; - } - - svp = hv_fetchs(table, "open_OUT", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); - if (mode & O_BINARY) - o->op_private |= OPpOPEN_OUT_RAW; - else if (mode & O_TEXT) - o->op_private |= OPpOPEN_OUT_CRLF; - } - } - if (o->op_type == OP_BACKTICK) { - if (!(o->op_flags & OPf_KIDS)) { - OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else - op_free(o); -#endif - return newop; - } - return o; - } + S_io_hints(aTHX_ o); { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ @@ -9701,7 +9755,7 @@ OP * Perl_ck_require(pTHX_ OP *o) { dVAR; - GV* gv = NULL; + GV* gv; PERL_ARGS_ASSERT_CK_REQUIRE; @@ -9736,16 +9790,9 @@ Perl_ck_require(pTHX_ OP *o) } } - if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */ + if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */ /* handle override, if any */ - gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV); - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { - GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE); - gv = gvp ? *gvp : NULL; - } - } - - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { + && (gv = gv_override("require", 7))) { OP *kid, *newop; if (o->op_flags & OPf_KIDS) { kid = cUNOPo->op_first; @@ -9757,11 +9804,7 @@ Perl_ck_require(pTHX_ OP *o) #ifndef PERL_MAD op_free(o); #endif - newop = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, kid, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv))))); + newop = S_new_entersubop(aTHX_ gv, kid); op_getmad(o,newop,'O'); return newop; } @@ -9910,8 +9953,6 @@ S_simplify_sort(pTHX_ OP *o) PERL_ARGS_ASSERT_SIMPLIFY_SORT; - 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 */ if (!(have_scopeop = kid->op_type == OP_SCOPE) && kid->op_type != OP_LEAVE) @@ -11044,6 +11085,9 @@ S_inplace_aassign(pTHX_ OP *o) { defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \ } STMT_END +#define IS_AND_OP(o) (o->op_type == OP_AND) +#define IS_OR_OP(o) (o->op_type == OP_OR) + /* 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 */ @@ -11083,6 +11127,45 @@ Perl_rpeep(pTHX_ OP *o) case OP_NEXTSTATE: PL_curcop = ((COP*)o); /* for warnings */ + /* Optimise a "return ..." at the end of a sub to just be "...". + * This saves 2 ops. Before: + * 1 <;> nextstate(main 1 -e:1) v ->2 + * 4 <@> return K ->5 + * 2 <0> pushmark s ->3 + * - <1> ex-rv2sv sK/1 ->4 + * 3 <#> gvsv[*cat] s ->4 + * + * After: + * - <@> return K ->- + * - <0> pushmark s ->2 + * - <1> ex-rv2sv sK/1 ->- + * 2 <$> gvsv(*cat) s ->3 + */ + { + OP *next = o->op_next; + OP *sibling = o->op_sibling; + if ( OP_TYPE_IS(next, OP_PUSHMARK) + && OP_TYPE_IS(sibling, OP_RETURN) + && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) + && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) + && cUNOPx(sibling)->op_first == next + && next->op_sibling && next->op_sibling->op_next + && next->op_next + ) { + /* Look through the PUSHMARK's siblings for one that + * points to the RETURN */ + OP *top = next->op_sibling; + while (top && top->op_next) { + if (top->op_next == sibling) { + top->op_next = sibling->op_next; + o->op_next = next->op_next; + break; + } + top = top->op_sibling; + } + } + } + /* Two NEXTSTATEs in a row serve no purpose. Except if they happen to carry two labels. For now, take the easier option, and skip this optimisation if the first NEXTSTATE has a label. */ @@ -11511,6 +11594,21 @@ Perl_rpeep(pTHX_ OP *o) 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; + + /* if we're an OR and our next is a AND in void context, we'll + follow it's op_other on short circuit, same for reverse. + We can't do this with OP_DOR since if it's true, its return + value is the underlying value which must be evaluated + by the next op */ + if (o->op_next && + ( + (IS_AND_OP(o) && IS_OR_OP(o->op_next)) + || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) + ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + ) { + o->op_next = ((LOGOP*)o->op_next)->op_other; + } DEFER(cLOGOP->op_other); o->op_opt = 1; @@ -11773,7 +11871,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_CUSTOM: { Perl_cpeep_t cpeep = - XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep); + XopENTRYCUSTOM(o, xop_peep); if (cpeep) cpeep(aTHX_ o, oldop); break; @@ -11796,14 +11894,16 @@ Perl_peep(pTHX_ OP *o) =head1 Custom Operators =for apidoc Ao||custom_op_xop -Return the XOP structure for a given custom op. This function should be +Return the XOP structure for a given custom op. This macro should be considered internal to OP_NAME and the other access macros: use them instead. +This macro does call a function. Prior to 5.19.8, this was implemented as a +function. =cut */ -const XOP * -Perl_custom_op_xop(pTHX_ const OP *o) +XOPRETANY +Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) { SV *keysv; HE *he = NULL; @@ -11811,7 +11911,7 @@ Perl_custom_op_xop(pTHX_ const OP *o) static const XOP xop_null = { 0, 0, 0, 0, 0 }; - PERL_ARGS_ASSERT_CUSTOM_OP_XOP; + PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD; assert(o->op_type == OP_CUSTOM); /* This is wrong. It assumes a function pointer can be cast to IV, @@ -11843,13 +11943,59 @@ Perl_custom_op_xop(pTHX_ const OP *o) XopENTRY_set(xop, xop_desc, savepvn(pv, l)); } Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); - return xop; } - - if (!he) return &xop_null; - - xop = INT2PTR(XOP *, SvIV(HeVAL(he))); - return xop; + else { + if (!he) + xop = (XOP *)&xop_null; + else + xop = INT2PTR(XOP *, SvIV(HeVAL(he))); + } + { + XOPRETANY any; + if(field == XOPe_xop_ptr) { + any.xop_ptr = xop; + } else { + const U32 flags = XopFLAGS(xop); + if(flags & field) { + switch(field) { + case XOPe_xop_name: + any.xop_name = xop->xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = xop->xop_desc; + break; + case XOPe_xop_class: + any.xop_class = xop->xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = xop->xop_peep; + break; + default: + NOT_REACHED; + break; + } + } else { + switch(field) { + case XOPe_xop_name: + any.xop_name = XOPd_xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = XOPd_xop_desc; + break; + case XOPe_xop_class: + any.xop_class = XOPd_xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = XOPd_xop_peep; + break; + default: + NOT_REACHED; + break; + } + } + } + return any; + } } /* @@ -11883,7 +12029,7 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) 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. C is a code as returned -by C. It must not be equal to 0 or -KEY_CORE. +by C. It must not be equal to 0. =cut */ @@ -11900,7 +12046,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, PERL_ARGS_ASSERT_CORE_PROTOTYPE; - assert (code && code != -KEY_CORE); + assert (code); if (!sv) sv = sv_newmortal();