X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=d0c1c8b0e744ab0f20151e6ca31e549b6c5d205e;hb=410be5dba347e0340059d489e15d034982d73278;hp=a2f4bf9fc5fe8cd333c0e0c33ce1e93ef92d0cbe;hpb=04a4d38e84a8a9c5528d4a7aecd68cc820b7a6ac;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index a2f4bf9..d0c1c8b 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -73,6 +73,28 @@ into peep() to do that code's portion of the 3rd pass. It has to be recursive, but it's recursive on basic blocks, not on tree nodes. */ +/* To implement user lexical pragmas, there needs to be a way at run time to + get the compile time state of %^H for that block. Storing %^H in every + block (or even COP) would be very expensive, so a different approach is + taken. The (running) state of %^H is serialised into a tree of HE-like + structs. Stores into %^H are chained onto the current leaf as a struct + refcounted_he * with the key and the value. Deletes from %^H are saved + with a value of PL_sv_placeholder. The state of %^H at any point can be + turned back into a regular HV by walking back up the tree from that point's + leaf, ignoring any key you've already seen (placeholder or not), storing + the rest into the HV structure, then removing the placeholders. Hence + memory is only used to store the %^H deltas from the enclosing COP, rather + than the entire %^H on each COP. + + To cause actions on %^H to write out the serialisation records, it has + magic type 'H'. This magic (itself) does nothing, but its presence causes + the values to gain magic type 'h', which has entries for set and clear. + C updates C with a store + record, with deletes written by C. C + saves the current C on the save stack, so that + it will be correctly restored when any inner compiling scope is exited. +*/ + #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" @@ -82,12 +104,17 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #if defined(PL_OP_SLAB_ALLOC) +#ifdef PERL_DEBUG_READONLY_OPS +# define PERL_SLAB_SIZE 4096 +# include +#endif + #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif void * -Perl_Slab_Alloc(pTHX_ int m, size_t sz) +Perl_Slab_Alloc(pTHX_ size_t sz) { /* * To make incrementing use count easy PL_OpSlab is an I32 * @@ -97,11 +124,26 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { - PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); +#ifdef PERL_DEBUG_READONLY_OPS + /* We need to allocate chunk by chunk so that we can control the VM + mapping */ + PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0); + + DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", + (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), + PL_OpPtr)); + if(PL_OpPtr == MAP_FAILED) { + perror("mmap failed"); + abort(); + } +#else + + PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*)); +#endif if (!PL_OpPtr) { return NULL; } - Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); /* We reserve the 0'th I32 sized chunk as a use count */ PL_OpSlab = (I32 *) PL_OpPtr; /* Reduce size by the use count word, and by the size we need. @@ -113,6 +155,14 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; + +#ifdef PERL_DEBUG_READONLY_OPS + /* We remember this slab. */ + /* This implementation isn't efficient, but it is simple. */ + PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1)); + PL_slabs[PL_slab_count++] = PL_OpSlab; + DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab)); +#endif } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ @@ -125,6 +175,70 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) return (void *)(PL_OpPtr + 1); } +#ifdef PERL_DEBUG_READONLY_OPS +void +Perl_pending_Slabs_to_ro(pTHX) { + /* Turn all the allocated op slabs read only. */ + U32 count = PL_slab_count; + I32 **const slabs = PL_slabs; + + /* Reset the array of pending OP slabs, as we're about to turn this lot + read only. Also, do it ahead of the loop in case the warn triggers, + and a warn handler has an eval */ + + PL_slabs = NULL; + PL_slab_count = 0; + + /* Force a new slab for any further allocation. */ + PL_OpSpace = 0; + + while (count--) { + void *const start = slabs[count]; + const size_t size = PERL_SLAB_SIZE* sizeof(I32*); + if(mprotect(start, size, PROT_READ)) { + Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", + start, (unsigned long) size, errno); + } + } + + free(slabs); +} + +STATIC void +S_Slab_to_rw(pTHX_ void *op) +{ + I32 * const * const ptr = (I32 **) op; + I32 * const slab = ptr[-1]; + assert( ptr-1 > (I32 **) slab ); + assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); + assert( *slab > 0 ); + if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) { + Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", + slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno); + } +} + +OP * +Perl_op_refcnt_inc(pTHX_ OP *o) +{ + if(o) { + Slab_to_rw(o); + ++o->op_targ; + } + return o; + +} + +PADOFFSET +Perl_op_refcnt_dec(pTHX_ OP *o) +{ + Slab_to_rw(o); + return --o->op_targ; +} +#else +# define Slab_to_rw(op) +#endif + void Perl_Slab_Free(pTHX_ void *op) { @@ -133,12 +247,38 @@ Perl_Slab_Free(pTHX_ void *op) assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); + Slab_to_rw(op); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif +#ifdef PERL_DEBUG_READONLY_OPS + U32 count = PL_slab_count; + /* Need to remove this slab from our list of slabs */ + if (count) { + while (count--) { + if (PL_slabs[count] == slab) { + /* Found it. Move the entry at the end to overwrite it. */ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "Deallocate %p by moving %p from %lu to %lu\n", + PL_OpSlab, + PL_slabs[PL_slab_count - 1], + PL_slab_count, count)); + PL_slabs[count] = PL_slabs[--PL_slab_count]; + /* Could realloc smaller at this point, but probably not + worth it. */ + if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { + perror("munmap failed"); + abort(); + } + break; + } + } + } +#else PerlMemShared_free(slab); +#endif if (slab == PL_OpSlab) { PL_OpSpace = 0; } @@ -202,17 +342,17 @@ S_no_bareword_allowed(pTHX_ const OP *o) return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", - cSVOPo_sv)); + SVfARG(cSVOPo_sv))); } /* "register" allocation */ PADOFFSET -Perl_allocmy(pTHX_ char *name) +Perl_allocmy(pTHX_ const char *const name) { dVAR; PADOFFSET off; - const bool is_our = (PL_in_my == KEY_our); + const bool is_our = (PL_parser->in_my == KEY_our); /* complain about "my $" etc etc */ if (*name && @@ -223,50 +363,58 @@ Perl_allocmy(pTHX_ char *name) { /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { - /* 1999-02-27 mjd@plover.com */ - char *p; - p = strchr(name, '\0'); - /* The next block assumes the buffer is at least 205 chars - long. At present, it's always at least 256 chars. */ - if (p-name > 200) { - strcpy(name+200, "..."); - p = name+199; - } - else { - p[1] = '\0'; - } - /* Move everything else down one character */ - for (; p-name > 2; p--) - *p = *(p-1); - name[2] = toCTRL(name[1]); - name[1] = '^'; + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"", + name[0], toCTRL(name[1]), name + 2)); + } else { + yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } - yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } /* check for duplicate declaration */ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - if (PL_in_my_stash && *name != '$') { + if (PL_parser->in_my_stash && *name != '$') { yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", - name, is_our ? "our" : "my")); + name, + is_our ? "our" + : PL_parser->in_my == KEY_state ? "state" : "my")); } /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, - PL_in_my_stash, + PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : NULL ), - 0 /* not fake */ + 0, /* not fake */ + PL_parser->in_my == KEY_state ); return off; } +/* free the body of an op without examining its contents. + * Always use this rather than FreeOp directly */ + +static void +S_op_destroy(pTHX_ OP *o) +{ + if (o->op_latefree) { + o->op_latefreed = 1; + return; + } + FreeOp(o); +} + +#ifdef USE_ITHREADS +# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b) +#else +# define forget_pmop(a,b) S_forget_pmop(aTHX_ a) +#endif + /* Destructor */ void @@ -275,8 +423,13 @@ Perl_op_free(pTHX_ OP *o) dVAR; OPCODE type; - if (!o || o->op_static) + if (!o) return; + if (o->op_latefreed) { + if (o->op_latefree) + return; + goto do_free; + } type = o->op_type; if (o->op_private & OPpREFCOUNTED) { @@ -292,9 +445,13 @@ Perl_op_free(pTHX_ OP *o) OP_REFCNT_LOCK; refcnt = OpREFCNT_dec(o); OP_REFCNT_UNLOCK; - if (refcnt) + if (refcnt) { + /* Need to find and remove any pattern match ops from the list + we maintain for reset(). */ + find_and_forget_pmops(o); return; } + } break; default: break; @@ -311,12 +468,22 @@ Perl_op_free(pTHX_ OP *o) if (type == OP_NULL) type = (OPCODE)o->op_targ; +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_rw(o); +#endif + /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ - if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) + if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) { cop_free((COP*)o); + } op_clear(o); + if (o->op_latefree) { + o->op_latefreed = 1; + return; + } + do_free: FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) @@ -404,54 +571,40 @@ Perl_op_clear(pTHX_ OP *o) /* FALL THROUGH */ case OP_TRANS: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { +#ifdef USE_ITHREADS + if (cPADOPo->op_padix > 0) { + pad_swipe(cPADOPo->op_padix, TRUE); + cPADOPo->op_padix = 0; + } +#else SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; +#endif } else { - Safefree(cPVOPo->op_pv); + PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; } break; case OP_SUBST: - op_free(cPMOPo->op_pmreplroot); + op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS - if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { + if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ - pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); + pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else - SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); + SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: - { - HV * const pmstash = PmopSTASH(cPMOPo); - if (pmstash && !SvIS_FREED(pmstash)) { - MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); - if (mg) { - PMOP *pmop = (PMOP*) mg->mg_obj; - PMOP *lastpmop = NULL; - while (pmop) { - if (cPMOPo == pmop) { - if (lastpmop) - lastpmop->op_pmnext = pmop->op_pmnext; - else - mg->mg_obj = (SV*) pmop->op_pmnext; - break; - } - lastpmop = pmop; - pmop = pmop->op_pmnext; - } - } - } - PmopSTASH_free(cPMOPo); - } - cPMOPo->op_pmreplroot = NULL; + forget_pmop(cPMOPo, 1); + cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared @@ -463,6 +616,7 @@ clear_pmop: #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); + SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]); SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } @@ -480,17 +634,70 @@ clear_pmop: STATIC void S_cop_free(pTHX_ COP* cop) { - Safefree(cop->cop_label); /* FIXME: treaddead ??? */ + CopLABEL_free(cop); CopFILE_free(cop); CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) - SvREFCNT_dec(cop->cop_warnings); - if (! specialCopIO(cop->cop_io)) { + PerlMemShared_free(cop->cop_warnings); + Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash); +} + +STATIC void +S_forget_pmop(pTHX_ PMOP *const o #ifdef USE_ITHREADS - /*EMPTY*/ -#else - SvREFCNT_dec(cop->cop_io); + , U32 flags #endif + ) +{ + HV * const pmstash = PmopSTASH(o); + if (pmstash && !SvIS_FREED(pmstash)) { + MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP **const array = (PMOP**) mg->mg_ptr; + U32 count = mg->mg_len / sizeof(PMOP**); + U32 i = count; + + while (i--) { + if (array[i] == o) { + /* Found it. Move the entry at the end to overwrite it. */ + array[i] = array[--count]; + mg->mg_len = count * sizeof(PMOP**); + /* Could realloc smaller at this point always, but probably + not worth it. Probably worth free()ing if we're the + last. */ + if(!count) { + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + } + break; + } + } + } + } + if (PL_curpm == o) + PL_curpm = NULL; +#ifdef USE_ITHREADS + if (flags) + PmopSTASH_free(o); +#endif +} + +STATIC void +S_find_and_forget_pmops(pTHX_ OP *o) +{ + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; + while (kid) { + switch (kid->op_type) { + case OP_SUBST: + case OP_PUSHRE: + case OP_MATCH: + case OP_QR: + forget_pmop((PMOP*)kid, 0); + } + find_and_forget_pmops(kid); + kid = kid->op_sibling; + } } } @@ -576,8 +783,8 @@ S_scalarboolean(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const line_t oldline = CopLINE(PL_curcop); - if (PL_copline != NOLINE) - CopLINE_set(PL_curcop, PL_copline); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); CopLINE_set(PL_curcop, oldline); } @@ -592,7 +799,8 @@ Perl_scalar(pTHX_ OP *o) OP *kid; /* assumes no premature commitment */ - if (!o || PL_error_count || (o->op_flags & OPf_WANT) + if (!o || (PL_parser && PL_parser->error_count) + || (o->op_flags & OPf_WANT) || o->op_type == OP_RETURN) { return o; @@ -612,7 +820,7 @@ Perl_scalar(pTHX_ OP *o) break; case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) + if (!kPMOP->op_pmreplrootu.op_pmreplroot) deprecate_old("implicit split to @_"); } /* FALL THROUGH */ @@ -636,7 +844,7 @@ Perl_scalar(pTHX_ OP *o) else scalar(kid); } - WITH_THR(PL_curcop = &PL_compiling); + PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: @@ -647,7 +855,7 @@ Perl_scalar(pTHX_ OP *o) else scalar(kid); } - WITH_THR(PL_curcop = &PL_compiling); + PL_curcop = &PL_compiling; break; case OP_SORT: if (ckWARN(WARN_VOID)) @@ -690,7 +898,8 @@ Perl_scalarvoid(pTHX_ OP *o) /* assumes no premature commitment */ want = o->op_flags & OPf_WANT; - if ((want && want != OPf_WANT_SCALAR) || PL_error_count + if ((want && want != OPf_WANT_SCALAR) + || (PL_parser && PL_parser->error_count) || o->op_type == OP_RETURN) { return o; @@ -816,16 +1025,16 @@ Perl_scalarvoid(pTHX_ OP *o) if (ckWARN(WARN_VOID)) { useless = "a constant"; if (o->op_private & OPpCONST_ARYBASE) - useless = 0; + useless = NULL; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) - useless = 0; + useless = NULL; /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) - useless = 0; + useless = NULL; else if (SvPOK(sv)) { /* perl4's way of mixing documentation and code (before the invention of POD) was based on a @@ -837,7 +1046,7 @@ Perl_scalarvoid(pTHX_ OP *o) if (strnEQ(maybe_macro, "di", 2) || strnEQ(maybe_macro, "ds", 2) || strnEQ(maybe_macro, "ig", 2)) - useless = 0; + useless = NULL; } } } @@ -907,7 +1116,7 @@ Perl_scalarvoid(pTHX_ OP *o) return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) + if (!kPMOP->op_pmreplrootu.op_pmreplroot) deprecate_old("implicit split to @_"); } break; @@ -935,7 +1144,8 @@ Perl_list(pTHX_ OP *o) OP *kid; /* assumes no premature commitment */ - if (!o || (o->op_flags & OPf_WANT) || PL_error_count + if (!o || (o->op_flags & OPf_WANT) + || (PL_parser && PL_parser->error_count) || o->op_type == OP_RETURN) { return o; @@ -984,7 +1194,7 @@ Perl_list(pTHX_ OP *o) else list(kid); } - WITH_THR(PL_curcop = &PL_compiling); + PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: @@ -994,7 +1204,7 @@ Perl_list(pTHX_ OP *o) else list(kid); } - WITH_THR(PL_curcop = &PL_compiling); + PL_curcop = &PL_compiling; break; case OP_REQUIRE: /* all requires must return a boolean value */ @@ -1009,10 +1219,10 @@ Perl_scalarseq(pTHX_ OP *o) { dVAR; if (o) { - if (o->op_type == OP_LINESEQ || - o->op_type == OP_SCOPE || - o->op_type == OP_LEAVE || - o->op_type == OP_LEAVETRY) + const OPCODE type = o->op_type; + + if (type == OP_LINESEQ || type == OP_SCOPE || + type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { @@ -1061,7 +1271,7 @@ Perl_mod(pTHX_ OP *o, I32 type) /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ int localize = -1; - if (!o || PL_error_count) + if (!o || (PL_parser && PL_parser->error_count)) return o; if ((o->op_private & OPpTARGET_MY) @@ -1080,12 +1290,13 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; localize = 0; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { - PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); + CopARYBASE_set(&PL_compiling, + (I32)SvIV(cSVOPx(PL_eval_start)->op_sv)); PL_eval_start = 0; } else if (!type) { - SAVEI32(PL_compiling.cop_arybase); - PL_compiling.cop_arybase = 0; + SAVECOPARYBASE(&PL_compiling); + CopARYBASE_set(&PL_compiling, 0); } else if (type == OP_REFGEN) goto nomod; @@ -1093,7 +1304,7 @@ Perl_mod(pTHX_ OP *o, I32 type) Perl_croak(aTHX_ "That use of $[ is unsupported"); break; case OP_STUB: - if (o->op_flags & OPf_PARENS || PL_madskills) + if ((o->op_flags & OPf_PARENS) || PL_madskills) break; goto nomod; case OP_ENTERSUB: @@ -1124,15 +1335,14 @@ Perl_mod(pTHX_ OP *o, I32 type) CV *cv; OP *okid; - if (kid->op_type == OP_PUSHMARK) - goto skip_kids; - if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) - Perl_croak(aTHX_ - "panic: unexpected lvalue entersub " - "args: type/targ %ld:%"UVuf, - (long)kid->op_type, (UV)kid->op_targ); - kid = kLISTOP->op_first; - skip_kids: + if (kid->op_type != OP_PUSHMARK) { + if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) + Perl_croak(aTHX_ + "panic: unexpected lvalue entersub " + "args: type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); + kid = kLISTOP->op_first; + } while (kid->op_sibling) kid = kid->op_sibling; if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { @@ -1443,6 +1653,7 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_RECV: case OP_ANDASSIGN: case OP_ORASSIGN: + case OP_DORASSIGN: return TRUE; default: return FALSE; @@ -1489,7 +1700,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) dVAR; OP *kid; - if (!o || PL_error_count) + if (!o || (PL_parser && PL_parser->error_count)) return o; switch (o->op_type) { @@ -1523,10 +1734,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) } break; - case OP_THREADSV: - o->op_flags |= OPf_MOD; /* XXX ??? */ - break; - case OP_RV2AV: case OP_RV2HV: if (set_op_ref) @@ -1592,7 +1799,7 @@ S_dup_attrlist(pTHX_ OP *o) rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); #ifdef PERL_MAD else if (o->op_type == OP_NULL) - rop = Nullop; + rop = NULL; #endif else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); @@ -1615,7 +1822,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ - SAVEINT(PL_expect); stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" @@ -1625,7 +1831,7 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) /* Don't force the C if we don't need it. */ SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) - /*EMPTY*/; /* already in %INC */ + NOOP; /* already in %INC */ else Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs(ATTRSMODULE), NULL); @@ -1742,15 +1948,15 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) dVAR; I32 type; - if (!o || PL_error_count) + if (!o || (PL_parser && PL_parser->error_count)) return o; + type = o->op_type; if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { (void)my_kid(cUNOPo->op_first, attrs, imopsp); return o; } - type = o->op_type; if (type == OP_LIST) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) @@ -1765,12 +1971,15 @@ 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_in_my == KEY_our ? "our" : "my")); + 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")); } else if (attrs) { GV * const gv = cGVOPx_gv(cUNOPo->op_first); - PL_in_my = FALSE; - PL_in_my_stash = NULL; + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : type == OP_RV2AV ? (SV*)GvAV(gv) : @@ -1787,14 +1996,16 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), - PL_in_my == KEY_our ? "our" : "my")); + PL_parser->in_my == KEY_our + ? "our" + : PL_parser->in_my == KEY_state ? "state" : "my")); return o; } else if (attrs && type != OP_PUSHMARK) { HV *stash; - PL_in_my = FALSE; - PL_in_my_stash = NULL; + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; /* check for C when deciding package */ stash = PAD_COMPNAME_TYPE(o->op_targ); @@ -1804,6 +2015,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; + if (PL_parser->in_my == KEY_state) + o->op_private |= OPpPAD_STATE; return o; } @@ -1836,8 +2049,8 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) else o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); } - PL_in_my = FALSE; - PL_in_my_stash = NULL; + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; return o; } @@ -1861,48 +2074,50 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { OP *o; bool ismatchop = 0; + const OPCODE ltype = left->op_type; + const OPCODE rtype = right->op_type; - if ( (left->op_type == OP_RV2AV || - left->op_type == OP_RV2HV || - left->op_type == OP_PADAV || - left->op_type == OP_PADHV) - && ckWARN(WARN_MISC)) + if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV + || ltype == OP_PADHV) && ckWARN(WARN_MISC)) { - const char * const desc = PL_op_desc[(right->op_type == OP_SUBST || - right->op_type == OP_TRANS) - ? right->op_type : OP_MATCH]; - const char * const sample = ((left->op_type == OP_RV2AV || - left->op_type == OP_PADAV) - ? "@array" : "%hash"); + const char * const desc + = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) + ? (int)rtype : OP_MATCH]; + const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) + ? "@array" : "%hash"); Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } - if (right->op_type == OP_CONST && + if (rtype == OP_CONST && cSVOPx(right)->op_private & OPpCONST_BARE && cSVOPx(right)->op_private & OPpCONST_STRICT) { no_bareword_allowed(right); } - ismatchop = right->op_type == OP_MATCH || - right->op_type == OP_SUBST || - right->op_type == OP_TRANS; + ismatchop = rtype == OP_MATCH || + rtype == OP_SUBST || + rtype == OP_TRANS; if (ismatchop && right->op_private & OPpTARGET_MY) { right->op_targ = 0; right->op_private &= ~OPpTARGET_MY; } if (!(right->op_flags & OPf_STACKED) && ismatchop) { + OP *newleft; + right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH && - ! (right->op_type == OP_TRANS && + if (rtype != OP_MATCH && + ! (rtype == OP_TRANS && right->op_private & OPpTRANS_IDENTICAL)) - left = mod(left, right->op_type); + newleft = mod(left, rtype); + else + newleft = left; if (right->op_type == OP_TRANS) - o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); + o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right); else - o = prepend_elem(right->op_type, scalar(left), right); + o = prepend_elem(rtype, scalar(newleft), right); if (type == OP_NOT) return newUNOP(OP_NOT, 0, scalar(o)); return o; @@ -1916,8 +2131,7 @@ OP * Perl_invert(pTHX_ OP *o) { if (!o) - return o; - /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ + return NULL; return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } @@ -1951,7 +2165,7 @@ Perl_scope(pTHX_ OP *o) } return o; } - + int Perl_block_start(pTHX_ int full) { @@ -1960,16 +2174,8 @@ Perl_block_start(pTHX_ int full) pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; - SAVESPTR(PL_compiling.cop_warnings); - if (! specialWARN(PL_compiling.cop_warnings)) { - PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; - SAVEFREESV(PL_compiling.cop_warnings) ; - } - SAVESPTR(PL_compiling.cop_io); - if (! specialCopIO(PL_compiling.cop_io)) { - PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; - SAVEFREESV(PL_compiling.cop_io) ; - } + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); return retval; } @@ -1980,7 +2186,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* const retval = scalarseq(seq); LEAVE_SCOPE(floor); - PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + CopHINTS_set(&PL_compiling, PL_hints); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ pad_leavemy(); @@ -1991,7 +2197,7 @@ STATIC OP * S_newDEFSVOP(pTHX) { dVAR; - const I32 offset = pad_findmy("$_"); + const PADOFFSET offset = pad_findmy("$_"); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } @@ -2022,7 +2228,7 @@ Perl_newPROG(pTHX_ OP *o) if (o->op_type == OP_STUB) { PL_comppad_name = 0; PL_compcv = 0; - FreeOp(o); + S_op_destroy(aTHX_ o); return; } PL_main_root = scope(sawparens(scalarvoid(o))); @@ -2036,7 +2242,8 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv + = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); if (cv) { dSP; PUSHMARK(SP); @@ -2058,13 +2265,14 @@ Perl_localize(pTHX_ OP *o, I32 lex) #if 0 list(o); #else - /*EMPTY*/; + NOOP; #endif else { - if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',' + if ( PL_parser->bufptr > PL_parser->oldbufptr + && PL_parser->bufptr[-1] == ',' && ckWARN(WARN_PARENTHESIS)) { - char *s = PL_bufptr; + char *s = PL_parser->bufptr; bool sigil = FALSE; /* some heuristics to detect a potential error */ @@ -2087,8 +2295,13 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (sigil && (*s == ';' || *s == '=')) { Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", - lex ? (PL_in_my == KEY_our ? "our" : "my") - : "local"); + lex + ? (PL_parser->in_my == KEY_our + ? "our" + : PL_parser->in_my == KEY_state + ? "state" + : "my") + : "local"); } } } @@ -2096,8 +2309,8 @@ Perl_localize(pTHX_ OP *o, I32 lex) o = my(o); else o = mod(o, OP_NULL); /* a bit kludgey */ - PL_in_my = FALSE; - PL_in_my_stash = NULL; + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; return o; } @@ -2106,8 +2319,7 @@ Perl_jmaybe(pTHX_ OP *o) { if (o->op_type == OP_LIST) { OP * const o2 - = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, - SVt_PV))); + = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; @@ -2119,8 +2331,14 @@ Perl_fold_constants(pTHX_ register OP *o) dVAR; register OP *curop; OP *newop; - I32 type = o->op_type; - SV *sv; + VOL I32 type = o->op_type; + SV * VOL sv = NULL; + int ret = 0; + I32 oldscope; + OP *old_next; + SV * const oldwarnhook = PL_warnhook; + SV * const olddiehook = PL_diehook; + dJMPENV; if (PL_opargs[type] & OA_RETSCALAR) scalar(o); @@ -2158,44 +2376,81 @@ Perl_fold_constants(pTHX_ register OP *o) goto nope; } - if (PL_error_count) + if (PL_parser && PL_parser->error_count) goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { - if ((curop->op_type != OP_CONST || - (curop->op_private & OPpCONST_BARE)) && - curop->op_type != OP_LIST && - curop->op_type != OP_SCALAR && - curop->op_type != OP_NULL && - curop->op_type != OP_PUSHMARK) + const OPCODE type = curop->op_type; + if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && + type != OP_LIST && + type != OP_SCALAR && + type != OP_NULL && + type != OP_PUSHMARK) { goto nope; } } curop = LINKLIST(o); + old_next = o->op_next; o->op_next = 0; PL_op = curop; - CALLRUNOPS(aTHX); - sv = *(PL_stack_sp--); - if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ - pad_swipe(o->op_targ, FALSE); - else if (SvTEMP(sv)) { /* grab mortal temp? */ - SvREFCNT_inc_simple_void(sv); - SvTEMP_off(sv); - } + + oldscope = PL_scopestack_ix; + create_eval_scope(G_FAKINGEVAL); + + PL_warnhook = PERL_WARNHOOK_FATAL; + PL_diehook = NULL; + JMPENV_PUSH(ret); + + switch (ret) { + case 0: + CALLRUNOPS(aTHX); + sv = *(PL_stack_sp--); + if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ + pad_swipe(o->op_targ, FALSE); + else if (SvTEMP(sv)) { /* grab mortal temp? */ + SvREFCNT_inc_simple_void(sv); + SvTEMP_off(sv); + } + break; + case 3: + /* Something tried to die. Abandon constant folding. */ + /* Pretend the error never happened. */ + sv_setpvn(ERRSV,"",0); + o->op_next = old_next; + break; + default: + JMPENV_POP; + /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + /* XXX note that this croak may fail as we've already blown away + * the stack - eg any nested evals */ + Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); + } + JMPENV_POP; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + + if (PL_scopestack_ix > oldscope) + delete_eval_scope(); + + if (ret) + goto nope; #ifndef PERL_MAD op_free(o); #endif + assert(sv); if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, (GV*)sv); else - newop = newSVOP(OP_CONST, 0, sv); + newop = newSVOP(OP_CONST, 0, (SV*)sv); op_getmad(o,newop,'f'); return newop; - nope: + nope: return o; } @@ -2207,7 +2462,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) const I32 oldtmps_floor = PL_tmps_floor; list(o); - if (PL_error_count) + if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ PL_op = curop = LINKLIST(o); @@ -2216,6 +2471,8 @@ Perl_gen_constant_list(pTHX_ register OP *o) pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); pp_anonlist(); PL_tmps_floor = oldtmps_floor; @@ -2320,7 +2577,7 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) last->op_madprop = 0; #endif - FreeOp(last); + S_op_destroy(aTHX_ (OP*)last); return (OP*)first; } @@ -2574,7 +2831,7 @@ Perl_mad_free(pTHX_ MADPROP* mp) return; if (mp->mad_next) mad_free(mp->mad_next); -/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen) +/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen) PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ switch (mp->mad_type) { case MAD_NULL: @@ -2656,6 +2913,9 @@ Perl_newOP(pTHX_ I32 type, I32 flags) o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags = (U8)flags; + o->op_latefree = 0; + o->op_latefreed = 0; + o->op_attached = 0; o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); @@ -2744,7 +3004,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; - SV * const rstr = ((SVOP*)repl)->op_sv; + SV * const rstr = +#ifdef PERL_MAD + (repl->op_type == OP_NULL) + ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : +#endif + ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; const U8 *t = (U8*)SvPV_const(tstr, tlen); @@ -2757,6 +3022,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; const I32 squash = o->op_private & OPpTRANS_SQUASH; I32 del = o->op_private & OPpTRANS_DELETE; + SV* swash; PL_hints |= HINT_BLOCK_SCOPE; if (SvUTF8(tstr)) @@ -2787,6 +3053,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; U8* tsave = NULL; U8* rsave = NULL; + const U32 flags = UTF8_ALLOW_DEFAULT; if (!from_utf) { STRLEN len = tlen; @@ -2813,11 +3080,11 @@ Perl_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, 0); + cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags); t += ulen; if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { t++; - cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); + cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags); t += ulen; } else { @@ -2871,11 +3138,11 @@ Perl_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, 0); + tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); t += ulen; if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ t++; - tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); + tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); t += ulen; } else @@ -2885,11 +3152,11 @@ Perl_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, 0); + rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); r += ulen; if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ r++; - rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); + rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); r += ulen; } else @@ -2949,13 +3216,23 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; - Safefree(cPVOPo->op_pv); - cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); + PerlMemShared_free(cPVOPo->op_pv); + cPVOPo->op_pv = NULL; + + swash = (SV*)swash_init("utf8", "", listsv, bits, none); +#ifdef USE_ITHREADS + cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); + SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); + PAD_SETSV(cPADOPo->op_padix, swash); + SvPADTMP_on(swash); +#else + cSVOPo->op_sv = swash; +#endif SvREFCNT_dec(listsv); SvREFCNT_dec(transv); if (!del && havefinal && rlen) - (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, + (void)hv_store((HV*)SvRV(swash), "FINAL", 5, newSVuv((UV)final), 0); if (grows) @@ -3004,8 +3281,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } else if (j >= (I32)rlen) j = rlen - 1; - else - cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); + else { + tbl = + (short *) + PerlMemShared_realloc(tbl, + (0x101+rlen-j) * sizeof(short)); + cPVOPo->op_pv = (char*)tbl; + } tbl[0x100] = (short)(rlen - j); for (i=0; i < (I32)rlen - j; i++) tbl[0x101+i] = r[j+i]; @@ -3064,10 +3346,10 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_hints & HINT_RE_TAINT) - pmop->op_pmpermflags |= PMf_RETAINT; + pmop->op_pmflags |= PMf_RETAINT; if (PL_hints & HINT_LOCALE) - pmop->op_pmpermflags |= PMf_LOCALE; - pmop->op_pmflags = pmop->op_pmpermflags; + pmop->op_pmflags |= PMf_LOCALE; + #ifdef USE_ITHREADS if (av_len((AV*) PL_regex_pad[0]) > -1) { @@ -3083,18 +3365,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) } #endif - /* link into pm list */ - if (type != OP_TRANS && PL_curstash) { - MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); - - if (!mg) { - mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); - } - pmop->op_pmnext = (PMOP*)mg->mg_obj; - mg->mg_obj = (SV*)pmop; - PmopSTASH_set(pmop,PL_curstash); - } - return CHECKOP(type, pmop); } @@ -3154,35 +3424,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) pm = (PMOP*)o; if (expr->op_type == OP_CONST) { - STRLEN plen; SV * const pat = ((SVOP*)expr)->op_sv; - const char *p = SvPV_const(pat, plen); - if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { - U32 was_readonly = SvREADONLY(pat); + U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; - if (was_readonly) { - if (SvFAKE(pat)) { - sv_force_normal_flags(pat, 0); - assert(!SvREADONLY(pat)); - was_readonly = 0; - } else { - SvREADONLY_off(pat); - } - } + if (o->op_flags & OPf_SPECIAL) + pm_flags |= RXf_SPLIT; - sv_setpvn(pat, "\\s+", 3); + if (DO_UTF8(pat)) + pm_flags |= RXf_UTF8; - SvFLAGS(pat) |= was_readonly; + PM_SETRE(pm, CALLREGCOMP(pat, pm_flags)); - p = SvPV_const(pat, plen); - pm->op_pmflags |= PMf_SKIPWHITE; - } - if (DO_UTF8(pat)) - pm->op_pmdynflags |= PMdf_UTF8; - /* FIXME - can we make this function take const char * args? */ - PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); - if (strEQ("\\s+", PM_GETRE(pm)->precomp)) - pm->op_pmflags |= PMf_WHITE; #ifdef PERL_MAD op_getmad(expr,(OP*)pm,'e'); #else @@ -3228,15 +3480,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) OP *curop; if (pm->op_pmflags & PMf_EVAL) { curop = NULL; - if (CopLINE(PL_curcop) < (line_t)PL_multi_end) - CopLINE_set(PL_curcop, (line_t)PL_multi_end); + if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end) + CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end); } else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = NULL; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { - if (PL_opargs[curop->op_type] & OA_DANGEROUS) { + if (curop->op_type == OP_SCOPE + || curop->op_type == OP_LEAVE + || (PL_opargs[curop->op_type] & OA_DANGEROUS)) { if (curop->op_type == OP_GV) { GV * const gv = cGVOPx_gv(curop); repl_has_vars = 1; @@ -3255,11 +3509,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { + curop->op_type == OP_PADANY) + { repl_has_vars = 1; } else if (curop->op_type == OP_PUSHRE) - /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */ + NOOP; /* Okay here, dangerous in newASSIGNOP */ else break; } @@ -3269,15 +3524,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) - || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { + || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) + { pm->op_pmflags |= PMf_CONST; /* const for long enough */ - pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ prepend_elem(o->op_type, scalar(repl), o); } else { if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ pm->op_pmflags |= PMf_MAYBE_CONST; - pm->op_pmpermflags |= PMf_MAYBE_CONST; } NewOp(1101, rcop, 1, LOGOP); rcop->op_type = OP_SUBSTCONT; @@ -3291,8 +3545,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) rcop->op_next = LINKLIST(repl); repl->op_next = (OP*)rcop; - pm->op_pmreplroot = scalar((OP*)rcop); - pm->op_pmreplstart = LINKLIST(rcop); + pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); + assert(!(pm->op_pmflags & PMf_ONCE)); + pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); rcop->op_next = 0; } } @@ -3318,6 +3573,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) return CHECKOP(type, svop); } +#ifdef USE_ITHREADS OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { @@ -3329,8 +3585,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_padix = pad_alloc(type, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); - if (sv) - SvPADTMP_on(sv); + assert(sv); + SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) @@ -3339,17 +3595,18 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } +#endif OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { dVAR; + assert(gv); #ifdef USE_ITHREADS - if (gv) - GvIN_PAD_on(gv); - return newPADOP(type, flags, SvREFCNT_inc_simple(gv)); + GvIN_PAD_on(gv); + return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else - return newSVOP(type, flags, SvREFCNT_inc_simple(gv)); + return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #endif } @@ -3379,8 +3636,7 @@ void Perl_package(pTHX_ OP *o) { dVAR; - const char *name; - STRLEN len; + SV *const sv = cSVOPo->op_sv; #ifdef PERL_MAD OP *pegop; #endif @@ -3388,20 +3644,20 @@ Perl_package(pTHX_ OP *o) save_hptr(&PL_curstash); save_item(PL_curstname); - name = SvPV_const(cSVOPo->op_sv, len); - PL_curstash = gv_stashpvn(name, len, TRUE); - sv_setpvn(PL_curstname, name, len); + PL_curstash = gv_stashsv(sv, GV_ADD); + + sv_setsv(PL_curstname, sv); PL_hints |= HINT_BLOCK_SCOPE; - PL_copline = NOLINE; - PL_expect = XSTATE; + PL_parser->copline = NOLINE; + PL_parser->expect = XSTATE; #ifndef PERL_MAD op_free(o); #else if (!PL_madskills) { op_free(o); - return Nullop; + return NULL; } pegop = newOP(OP_NULL,0); @@ -3518,15 +3774,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) */ PL_hints |= HINT_BLOCK_SCOPE; - PL_copline = NOLINE; - PL_expect = XSTATE; + PL_parser->copline = NOLINE; + PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ #ifdef PERL_MAD if (!PL_madskills) { /* FIXME - don't allocate pegop if !PL_madskills */ op_free(pegop); - return Nullop; + return NULL; } return pegop; #endif @@ -3597,17 +3853,19 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) sv = va_arg(*args, SV*); } } - { - const line_t ocopline = PL_copline; - COP * const ocurcop = PL_curcop; - const int oexpect = PL_expect; - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), - veop, modname, imop); - PL_expect = oexpect; - PL_copline = ocopline; - PL_curcop = ocurcop; - } + /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure + * 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. */ + + ENTER; + SAVEVPTR(PL_curcop); + lex_start(NULL, NULL, FALSE); + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + LEAVE; } OP * @@ -3629,8 +3887,7 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv)))))); + newGVOP(OP_GV, 0, gv)))))); } else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); @@ -3649,13 +3906,18 @@ Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) STATIC I32 S_is_list_assignment(pTHX_ register const OP *o) { + unsigned type; + U8 flags; + if (!o) return TRUE; - if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) + if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) o = cUNOPo->op_first; - if (o->op_type == OP_COND_EXPR) { + flags = o->op_flags; + type = o->op_type; + if (type == OP_COND_EXPR) { const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); @@ -3666,20 +3928,20 @@ S_is_list_assignment(pTHX_ register const OP *o) return FALSE; } - if (o->op_type == OP_LIST && - (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && + if (type == OP_LIST && + (flags & OPf_WANT) == OPf_WANT_SCALAR && o->op_private & OPpLVAL_INTRO) return FALSE; - if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || - o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || - o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) + if (type == OP_LIST || flags & OPf_PARENS || + type == OP_RV2AV || type == OP_RV2HV || + type == OP_ASLICE || type == OP_HSLICE) return TRUE; - if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) + if (type == OP_PADAV || type == OP_PADHV) return TRUE; - if (o->op_type == OP_RV2SV) + if (type == OP_RV2SV) return FALSE; return FALSE; @@ -3733,10 +3995,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere - * to store these values, evil chicanery is done with SvCUR(). + * to store these values, evil chicanery is done with SvUVX(). */ - if (!(left->op_private & OPpLVAL_INTRO)) { + { OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { @@ -3769,19 +4031,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) break; } else if (curop->op_type == OP_PUSHRE) { - if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS - GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, - ((PMOP*)curop)->op_pmreplroot)); -#else - GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; -#endif + if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { + GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; GvASSIGN_GENERATION_set(gv, PL_generation); + } +#else + GV *const gv + = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; + if (gv) { + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) + break; GvASSIGN_GENERATION_set(gv, PL_generation); } +#endif } else break; @@ -3791,23 +4058,30 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (curop != o) o->op_private |= OPpASSIGN_COMMON; } - if (right && right->op_type == OP_SPLIT) { - OP* tmpop; - if ((tmpop = ((LISTOP*)right)->op_first) && - tmpop->op_type == OP_PUSHRE) - { + + if (right && right->op_type == OP_SPLIT && !PL_madskills) { + OP* tmpop = ((LISTOP*)right)->op_first; + if (tmpop && (tmpop->op_type == OP_PUSHRE)) { PMOP * const pm = (PMOP*)tmpop; if (left->op_type == OP_RV2AV && !(left->op_private & OPpLVAL_INTRO) && !(o->op_private & OPpASSIGN_COMMON) ) { tmpop = ((UNOP*)left)->op_first; - if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { + if (tmpop->op_type == OP_GV +#ifdef USE_ITHREADS + && !pm->op_pmreplrootu.op_pmtargetoff +#else + && !pm->op_pmreplrootu.op_pmtargetgv +#endif + ) { #ifdef USE_ITHREADS - pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); + pm->op_pmreplrootu.op_pmtargetoff + = cPADOPx(tmpop)->op_padix; cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else - pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; + pm->op_pmreplrootu.op_pmtargetgv + = (GV*)cSVOPx(tmpop)->op_sv; cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; @@ -3815,11 +4089,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ tmpop->op_sibling = NULL; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ -#ifdef PERL_MAD - op_getmad(o,right,'R'); /* blow off assign */ -#else op_free(o); /* blow off assign */ -#endif right->op_flags &= ~OPf_WANT; /* "I don't know and I don't care." */ return right; @@ -3853,7 +4123,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) else { /* FIXME for MAD */ op_free(o); - o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); + o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); o->op_private |= OPpCONST_ARYBASE; } } @@ -3877,34 +4147,35 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } cop->op_flags = (U8)flags; - cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + CopHINTS_set(cop, PL_hints); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif - PL_compiling.op_private = cop->op_private; + CopHINTS_set(&PL_compiling, CopHINTS_get(cop)); cop->op_next = (OP*)cop; if (label) { - cop->cop_label = label; + CopLABEL_set(cop, label); PL_hints |= HINT_BLOCK_SCOPE; } cop->cop_seq = seq; - cop->cop_arybase = PL_curcop->cop_arybase; - if (specialWARN(PL_curcop->cop_warnings)) - cop->cop_warnings = PL_curcop->cop_warnings ; - else - cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; - if (specialCopIO(PL_curcop->cop_io)) - cop->cop_io = PL_curcop->cop_io; - else - cop->cop_io = newSVsv(PL_curcop->cop_io) ; - + /* CopARYBASE is now "virtual", in that it's stored as a flag bit in + CopHINTS and a possible value in cop_hints_hash, so no need to copy it. + */ + cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + cop->cop_hints_hash = PL_curcop->cop_hints_hash; + if (cop->cop_hints_hash) { + HINTS_REFCNT_LOCK; + cop->cop_hints_hash->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } - if (PL_copline == NOLINE) + if (PL_parser && PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); else { - CopLINE_set(cop, PL_copline); - PL_copline = NOLINE; + CopLINE_set(cop, PL_parser->copline); + if (PL_parser) + PL_parser->copline = NOLINE; } #ifdef USE_ITHREADS CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ @@ -3914,10 +4185,13 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopSTASH_set(cop, PL_curstash); if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef ) { - (void)SvIOK_on(*svp); - SvIV_set(*svp, PTR2IV(cop)); + AV *av = CopFILEAVx(PL_curcop); + if (av) { + SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); + SvIV_set(*svp, PTR2IV(cop)); + } } } @@ -3948,7 +4222,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL) - && (first->op_flags & OPf_KIDS)) { + && (first->op_flags & OPf_KIDS) + && !PL_madskills) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; @@ -3959,11 +4234,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (o->op_next) first->op_next = o->op_next; cUNOPo->op_first = NULL; -#ifdef PERL_MAD - op_getmad(o,first,'O'); -#else op_free(o); -#endif } } if (first->op_type == OP_CONST) { @@ -4047,7 +4318,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } if (warnop) { const line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, PL_copline); + CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], @@ -4100,38 +4371,24 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) scalarboolean(first); if (first->op_type == OP_CONST) { + /* Left or right arm of the conditional? */ + const bool left = SvTRUE(((SVOP*)first)->op_sv); + OP *live = left ? trueop : falseop; + OP *const dead = left ? falseop : trueop; if (first->op_private & OPpCONST_BARE && first->op_private & OPpCONST_STRICT) { no_bareword_allowed(first); } - if (SvTRUE(((SVOP*)first)->op_sv)) { -#ifdef PERL_MAD - if (PL_madskills) { - trueop = newUNOP(OP_NULL, 0, trueop); - op_getmad(first,trueop,'C'); - op_getmad(falseop,trueop,'e'); - } - /* FIXME for MAD - should there be an ELSE here? */ -#else + if (PL_madskills) { + /* This is all dead code when PERL_MAD is not defined. */ + live = newUNOP(OP_NULL, 0, live); + op_getmad(first, live, 'C'); + op_getmad(dead, live, left ? 'e' : 't'); + } else { op_free(first); - op_free(falseop); -#endif - return trueop; - } - else { -#ifdef PERL_MAD - if (PL_madskills) { - falseop = newUNOP(OP_NULL, 0, falseop); - op_getmad(first,falseop,'C'); - op_getmad(trueop,falseop,'t'); - } - /* FIXME for MAD - should there be an ELSE here? */ -#else - op_free(first); - op_free(trueop); -#endif - return falseop; + op_free(dead); } + return live; } NewOp(1101, logop, 1, LOGOP); logop->op_type = OP_COND_EXPR; @@ -4236,10 +4493,10 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) break; case OP_SASSIGN: - if (k1->op_type == OP_READDIR + if (k1 && (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) - || k1->op_type == OP_EACH) + || k1->op_type == OP_EACH)) expr = newUNOP(OP_DEFINED, 0, expr); break; } @@ -4298,10 +4555,10 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my) break; case OP_SASSIGN: - if (k1->op_type == OP_READDIR + if (k1 && (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) - || k1->op_type == OP_EACH) + || k1->op_type == OP_EACH)) expr = newUNOP(OP_DEFINED, 0, expr); break; } @@ -4324,11 +4581,13 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my) cont = append_elem(OP_LINESEQ, cont, unstack); } + assert(block); listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); + assert(listop); redo = LINKLIST(listop); if (expr) { - PL_copline = (line_t)whileline; + PL_parser->copline = (line_t)whileline; scalar(listop); o = new_logop(OP_AND, 0, &expr, &listop); if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { @@ -4376,14 +4635,22 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP PADOFFSET padoff = 0; I32 iterflags = 0; I32 iterpflags = 0; - OP *madsv = 0; + OP *madsv = NULL; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ sv->op_type = OP_RV2GV; sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; - if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) + + /* The op_type check is needed to prevent a possible segfault + * if the loop variable is undeclared and 'strict vars' is in + * effect. This is illegal but is nonetheless parsed, so we + * may reach this point with an OP_CONST where we're expecting + * an OP_GV. + */ + if (cUNOPx(sv)->op_first->op_type == OP_GV + && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) iterpflags |= OPpITER_DEF; } else if (sv->op_type == OP_PADSV) { /* private variable */ @@ -4397,24 +4664,19 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP } sv = NULL; } - else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ - padoff = sv->op_targ; - if (PL_madskills) - madsv = sv; - else { - sv->op_targ = 0; - iterflags |= OPf_SPECIAL; - op_free(sv); - } - sv = NULL; - } else Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); - if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_")) - iterpflags |= OPpITER_DEF; + if (padoff) { + SV *const namesv = PAD_COMPNAME_SV(padoff); + STRLEN len; + const char *const name = SvPV_const(namesv, len); + + if (len == 2 && name[0] == '$' && name[1] == '_') + iterpflags |= OPpITER_DEF; + } } else { - const I32 offset = pad_findmy("$_"); + const PADOFFSET offset = pad_findmy("$_"); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { sv = newGVOP(OP_GV, 0, PL_defgv); } @@ -4435,7 +4697,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP * set the STACKED flag to indicate that these values are to be * treated as min/max values by 'pp_iterinit'. */ - UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; + const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* const range = (LOGOP*) flip->op_first; OP* const left = range->op_first; OP* const right = left->op_sibling; @@ -4474,17 +4736,17 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); - FreeOp(loop); + S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } #else - Renew(loop, 1, LOOP); + loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); #endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); if (madsv) op_getmad(madsv, (OP*)loop, 'v'); - PL_copline = forline; + PL_parser->copline = forline; return newSTATEOP(0, label, wop); } @@ -4499,8 +4761,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { - o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx_nolen_const(((SVOP*)label)->op_sv) + o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST + ? SvPV_nolen_const(((SVOP*)label)->op_sv) : "")); } #ifdef PERL_MAD @@ -4549,8 +4811,7 @@ S_ref_array_or_hash(pTHX_ OP *cond) op_other if the match fails.) */ -STATIC -OP * +STATIC OP * S_newGIVWHENOP(pTHX_ OP *cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg) @@ -4604,9 +4865,8 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, [*] possibly surprising */ -STATIC -bool -S_looks_like_bool(pTHX_ OP *o) +STATIC bool +S_looks_like_bool(pTHX_ const OP *o) { dVAR; switch(o->op_type) { @@ -4677,7 +4937,7 @@ Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) OP * Perl_newWHENOP(pTHX_ OP *cond, OP *block) { - bool cond_llb = (!cond || looks_like_bool(cond)); + const bool cond_llb = (!cond || looks_like_bool(cond)); OP *cond_op; if (cond_llb) @@ -4714,7 +4974,7 @@ Perl_cv_undef(pTHX_ CV *cv) /* for XSUBs CvFILE point directly to static memory; __FILE__ */ Safefree(CvFILE(cv)); } - CvFILE(cv) = 0; + CvFILE(cv) = NULL; #endif if (!CvISXSUB(cv) && CvROOT(cv)) { @@ -4752,27 +5012,33 @@ Perl_cv_undef(pTHX_ CV *cv) } void -Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) -{ - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { +Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, + const STRLEN len) +{ + /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by + relying on SvCUR, and doubling up the buffer to hold CvFILE(). */ + if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ + || (p && (len != SvCUR(cv) /* Not the same length. */ + || memNE(p, SvPVX_const(cv), len)))) + && ckWARN_d(WARN_PROTOTYPE)) { SV* const msg = sv_newmortal(); SV* name = NULL; if (gv) gv_efullname3(name = sv_newmortal(), gv, NULL); - sv_setpv(msg, "Prototype mismatch:"); + sv_setpvs(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); if (p) - Perl_sv_catpvf(aTHX_ msg, "(%s)", p); + Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p); else sv_catpvs(msg, "none"); - Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); } } @@ -4829,6 +5095,9 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) dVAR; SV *sv = NULL; + if (PL_madskills) + return NULL; + if (!o) return NULL; @@ -4933,11 +5202,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; - const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL; + const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; if (proto) { assert(proto->op_type == OP_CONST); - ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); } else ps = NULL; @@ -4974,15 +5243,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } - cv_ckproto((CV*)gv, NULL, ps); + cv_ckproto_len((CV*)gv, NULL, ps, ps_len); } if (ps) sv_setpvn((SV*)gv, ps, ps_len); else sv_setiv((SV*)gv, -1); + SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; - PL_sub_generation++; goto done; } @@ -5018,7 +5287,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) * skipping the prototype check */ if (exists || SvPOK(cv)) - cv_ckproto(cv, gv, ps); + cv_ckproto_len(cv, gv, ps, ps_len); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { if ((!block @@ -5044,8 +5313,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { const line_t oldline = CopLINE(PL_curcop); - if (PL_copline != NOLINE) - CopLINE_set(PL_curcop, PL_copline); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); @@ -5063,7 +5332,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } if (const_sv) { - SvREFCNT_inc_void_NN(const_sv); + SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ @@ -5076,7 +5345,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GvCV(gv) = NULL; cv = newCONSTSUB(NULL, name, const_sv); } - PL_sub_generation++; + mro_method_changed_in( /* sub Foo::Bar () { 123 } */ + (CvGV(cv) && GvSTASH(CvGV(cv))) + ? GvSTASH(CvGV(cv)) + : CvSTASH(cv) + ? CvSTASH(cv) + : PL_curstash + ); if (PL_madskills) goto install_block; op_free(block); @@ -5159,7 +5434,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } GvCVGEN(gv) = 0; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } CvGV(cv) = gv; @@ -5169,7 +5444,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (ps) sv_setpvn((SV*)cv, ps, ps_len); - if (PL_error_count) { + if (PL_parser && PL_parser->error_count) { op_free(block); block = NULL; if (name) { @@ -5183,7 +5458,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%"SVf, ERRSV); + Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); } } } @@ -5195,11 +5470,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); + block->op_attached = 1; } else { /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { - OP* newblock = newSTATEOP(0, NULL, 0); + OP* const newblock = newSTATEOP(0, NULL, 0); #ifdef PERL_MAD op_getmad(block,newblock,'B'); #else @@ -5207,6 +5483,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) #endif block = newblock; } + else + block->op_attached = 1; CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } CvROOT(cv)->op_private |= OPpREFCOUNTED; @@ -5226,9 +5504,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (name || aname) { - const char *s; - const char * const tname = (name ? name : aname); - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const sv = newSV(0); SV * const tmpstr = sv_newmortal(); @@ -5254,67 +5529,81 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - if ((s = strrchr(tname,':'))) - s++; - else - s = tname; + if (name && ! (PL_parser && PL_parser->error_count)) + process_special_blocks(name, gv, cv); + } - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') - goto done; + done: + if (PL_parser) + PL_parser->copline = NOLINE; + LEAVE_SCOPE(floor); + return cv; +} - if (strEQ(s, "BEGIN") && !PL_error_count) { +STATIC void +S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, + CV *const cv) +{ + const char *const colon = strrchr(fullname,':'); + const char *const name = colon ? colon + 1 : fullname; + + if (*name == 'B') { + if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - if (!PL_beginav) - PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; - PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + CopHINTS_set(&PL_compiling, PL_hints); LEAVE; } - else if (strEQ(s, "END") && !PL_error_count) { - if (!PL_endav) - PL_endav = newAV(); - DEBUG_x( dump_sub(gv) ); - av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "CHECK") && !PL_error_count) { - if (!PL_checkav) - PL_checkav = newAV(); - DEBUG_x( dump_sub(gv) ); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); - av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "INIT") && !PL_error_count) { - if (!PL_initav) - PL_initav = newAV(); - DEBUG_x( dump_sub(gv) ); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); - av_push(PL_initav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } + else + return; + } else { + if (*name == 'E') { + if strEQ(name, "END") { + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv); + } else + return; + } else if (*name == 'U') { + if (strEQ(name, "UNITCHECK")) { + /* It's never too late to run a unitcheck block */ + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv); + } + else + return; + } else if (*name == 'C') { + if (strEQ(name, "CHECK")) { + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv); + } + else + return; + } else if (*name == 'I') { + if (strEQ(name, "INIT")) { + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv); + } + else + return; + } else + return; + DEBUG_x( dump_sub(gv) ); + GvCV(gv) = 0; /* cv has been hijacked */ } - - done: - PL_copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; } -/* XXX unsafe for threads if eval_owner isn't held */ /* =for apidoc newCONSTSUB @@ -5329,11 +5618,20 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { dVAR; CV* cv; +#ifdef USE_ITHREADS + const char *const temp_p = CopFILE(PL_curcop); + const STRLEN len = temp_p ? strlen(temp_p) : 0; +#else + SV *const temp_sv = CopFILESV(PL_curcop); + STRLEN len; + const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL; +#endif + char *const file = savepvn(temp_p, temp_p ? len : 0); ENTER; SAVECOPLINE(PL_curcop); - CopLINE_set(PL_curcop, PL_copline); + CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; @@ -5345,10 +5643,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) CopSTASH_set(PL_curcop,stash); } - cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); + /* file becomes the CvFILE. For an XS, it's supposed to be static storage, + 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_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ + Safefree(file); #ifdef USE_ITHREADS if (stash) @@ -5359,10 +5661,56 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) return cv; } +CV * +Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, + const char *const filename, const char *const proto, + U32 flags) +{ + CV *cv = newXS(name, subaddr, filename); + + if (flags & XS_DYNAMIC_FILENAME) { + /* We need to "make arrangements" (ie cheat) to ensure that the + filename lasts as long as the PVCV we just created, but also doesn't + leak */ + STRLEN filename_len = strlen(filename); + STRLEN proto_and_file_len = filename_len; + char *proto_and_file; + STRLEN proto_len; + + if (proto) { + proto_len = strlen(proto); + proto_and_file_len += proto_len; + + Newx(proto_and_file, proto_and_file_len + 1, char); + Copy(proto, proto_and_file, proto_len, char); + Copy(filename, proto_and_file + proto_len, filename_len + 1, char); + } else { + proto_len = 0; + proto_and_file = savepvn(filename, filename_len); + } + + /* This gets free()d. :-) */ + sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len, + SV_HAS_TRAILING_NUL); + if (proto) { + /* This gives us the correct prototype, rather than one with the + file name appended. */ + SvCUR_set(cv, proto_len); + } else { + SvPOK_off(cv); + } + CvFILE(cv) = proto_and_file + proto_len; + } else { + sv_setpv((SV *)cv, proto); + } + return cv; +} + /* =for apidoc U||newXS -Used by C to hook up XSUBs as Perl subs. +Used by C to hook up XSUBs as Perl subs. I needs to be +static storage, as it is used directly as CvFILE(), without a copy being made. =cut */ @@ -5396,8 +5744,8 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) const char *redefined_name = HvNAME_get(stash); if ( strEQ(redefined_name,"autouse") ) { const line_t oldline = CopLINE(PL_curcop); - if (PL_copline != NOLINE) - CopLINE_set(PL_curcop, PL_copline); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined" @@ -5415,12 +5763,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)newSV(0); - sv_upgrade((SV *)cv, SVt_PVCV); + cv = (CV*)newSV_type(SVt_PVCV); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* newXS */ } } CvGV(cv) = gv; @@ -5430,51 +5777,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) CvISXSUB_on(cv); CvXSUB(cv) = subaddr; - if (name) { - const char *s = strrchr(name,':'); - if (s) - s++; - else - s = name; - - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') - goto done; - - if (strEQ(s, "BEGIN")) { - if (!PL_beginav) - PL_beginav = newAV(); - av_push(PL_beginav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "END")) { - if (!PL_endav) - PL_endav = newAV(); - av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "CHECK")) { - if (!PL_checkav) - PL_checkav = newAV(); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); - av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "INIT")) { - if (!PL_initav) - PL_initav = newAV(); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); - av_push(PL_initav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - } + if (name) + process_special_blocks(name, gv, cv); else CvANON_on(cv); -done: return cv; } @@ -5504,11 +5811,11 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { const line_t oldline = CopLINE(PL_curcop); - if (PL_copline != NOLINE) - CopLINE_set(PL_curcop, PL_copline); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), o ? "Format %"SVf" redefined" - : "Format STDOUT redefined" ,cSVOPo->op_sv); + : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -5532,7 +5839,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) #else op_free(o); #endif - PL_copline = NOLINE; + if (PL_parser) + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); #ifdef PERL_MAD return pegop; @@ -5542,15 +5850,13 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OP * Perl_newANONLIST(pTHX_ OP *o) { - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); + return convert(OP_ANONLIST, OPf_SPECIAL, o); } OP * Perl_newANONHASH(pTHX_ OP *o) { - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); + return convert(OP_ANONHASH, OPf_SPECIAL, o); } OP * @@ -5674,10 +5980,6 @@ Perl_newSVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADSV]; return o; } - else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { - o->op_flags |= OPpDONE_SVREF; - return o; - } return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -5689,7 +5991,7 @@ Perl_ck_anoncode(pTHX_ OP *o) { cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); if (!PL_madskills) - cSVOPo->op_sv = Nullsv; + cSVOPo->op_sv = NULL; return o; } @@ -5705,7 +6007,7 @@ Perl_ck_bitop(pTHX_ OP *o) (op) == OP_EQ || (op) == OP_I_EQ || \ (op) == OP_NE || (op) == OP_I_NE || \ (op) == OP_NCMP || (op) == OP_I_NCMP) - o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + o->op_private = (U8)(PL_hints & HINT_INTEGER); if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ && (o->op_type == OP_BIT_OR || o->op_type == OP_BIT_AND @@ -5749,13 +6051,12 @@ Perl_ck_spair(pTHX_ OP *o) o = modkids(ck_fun(o), type); kid = cUNOPo->op_first; newop = kUNOP->op_first->op_sibling; - if (newop && - (newop->op_sibling || - !(PL_opargs[newop->op_type] & OA_RETSCALAR) || - newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || - newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - - return o; + if (newop) { + const OPCODE type = newop->op_type; + if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || + type == OP_PADAV || type == OP_PADHV || + type == OP_RV2AV || type == OP_RV2HV) + return o; } #ifdef PERL_MAD op_getmad(kUNOP->op_first,newop,'K'); @@ -5809,12 +6110,11 @@ OP * Perl_ck_eof(pTHX_ OP *o) { dVAR; - const I32 type = o->op_type; if (o->op_flags & OPf_KIDS) { if (cLISTOPo->op_first->op_type == OP_STUB) { - OP* newop - = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); + OP * const newop + = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); #ifdef PERL_MAD op_getmad(o,newop,'O'); #else @@ -5842,7 +6142,7 @@ Perl_ck_eval(pTHX_ OP *o) else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; #ifdef PERL_MAD - OP* oldo = o; + OP* const oldo = o; #endif cUNOPo->op_first = 0; @@ -5872,7 +6172,7 @@ Perl_ck_eval(pTHX_ OP *o) } else { #ifdef PERL_MAD - OP* oldo = o; + OP* const oldo = o; #else op_free(o); #endif @@ -5881,8 +6181,12 @@ Perl_ck_eval(pTHX_ OP *o) } o->op_targ = (PADOFFSET)PL_hints; if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { - /* Store a copy of %^H that pp_entereval can pick up */ - OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv))); + /* Store a copy of %^H that pp_entereval can pick up. + OPf_SPECIAL flags the opcode as being for this purpose, + so that it in turn will return a copy at every + eval.*/ + OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL, + (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; } @@ -5928,7 +6232,8 @@ Perl_ck_exists(pTHX_ OP *o) OP * const kid = cUNOPo->op_first; if (kid->op_type == OP_ENTERSUB) { (void) ref(kid, o->op_type); - if (kid->op_type != OP_RV2CV && !PL_error_count) + 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)); o->op_private |= OPpEXISTS_SUB; @@ -5961,24 +6266,24 @@ Perl_ck_rvconst(pTHX_ register OP *o) /* Is it a constant from cv_const_sv()? */ if (SvROK(kidsv) && SvREADONLY(kidsv)) { SV * const rsv = SvRV(kidsv); - const int svtype = SvTYPE(rsv); + const svtype type = SvTYPE(rsv); const char *badtype = NULL; switch (o->op_type) { case OP_RV2SV: - if (svtype > SVt_PVMG) + if (type > SVt_PVMG) badtype = "a SCALAR"; break; case OP_RV2AV: - if (svtype != SVt_PVAV) + if (type != SVt_PVAV) badtype = "an ARRAY"; break; case OP_RV2HV: - if (svtype != SVt_PVHV) + if (type != SVt_PVHV) badtype = "a HASH"; break; case OP_RV2CV: - if (svtype != SVt_PVCV) + if (type != SVt_PVCV) badtype = "a CODE"; break; } @@ -6015,8 +6320,8 @@ Perl_ck_rvconst(pTHX_ register OP *o) } if (badthing) Perl_croak(aTHX_ - "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", - kidsv, badthing); + "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", + SVfARG(kidsv), badthing); } /* * This is a little tricky. We only want to add the symbol if we @@ -6066,12 +6371,13 @@ Perl_ck_ftst(pTHX_ OP *o) const I32 type = o->op_type; if (o->op_flags & OPf_REF) { - /*EMPTY*/; + NOOP; } else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { SVOP * const kid = (SVOP*)cUNOPo->op_first; + const OPCODE kidtype = kid->op_type; - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); #ifdef PERL_MAD @@ -6079,21 +6385,17 @@ Perl_ck_ftst(pTHX_ OP *o) #else op_free(o); #endif - o = newop; - return o; + return newop; } - else { - if ((PL_hints & HINT_FILETEST_ACCESS) && - OP_IS_FILETEST_ACCESS(o)) + if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o)) o->op_private |= OPpFT_ACCESS; - } - if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst) - && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT) + if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst) + && kidtype != OP_STAT && kidtype != OP_LSTAT) o->op_private |= OPpFT_STACKED; } else { #ifdef PERL_MAD - OP* oldo = o; + OP* const oldo = o; #else op_free(o); #endif @@ -6177,7 +6479,7 @@ Perl_ck_fun(pTHX_ OP *o) if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6200,7 +6502,7 @@ Perl_ck_fun(pTHX_ OP *o) if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6263,13 +6565,9 @@ Perl_ck_fun(pTHX_ OP *o) */ priv = OPpDEREF; if (kid->op_type == OP_PADSV) { - name = PAD_COMPNAME_PV(kid->op_targ); - /* SvCUR of a pad namesv can't be trusted - * (see PL_generation), so calc its length - * manually */ - if (name) - len = strlen(name); - + SV *const namesv + = PAD_COMPNAME_SV(kid->op_targ); + name = SvPV_const(namesv, len); } else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) @@ -6281,6 +6579,7 @@ Perl_ck_fun(pTHX_ OP *o) else if (kid->op_type == OP_AELEM || kid->op_type == OP_HELEM) { + OP *firstop; OP *op = ((BINOP*)kid)->op_first; name = NULL; if (op) { @@ -6290,10 +6589,10 @@ Perl_ck_fun(pTHX_ OP *o) "[]" : "{}"; if (((op->op_type == OP_RV2AV) || (op->op_type == OP_RV2HV)) && - (op = ((UNOP*)op)->op_first) && - (op->op_type == OP_GV)) { + (firstop = ((UNOP*)op)->op_first) && + (firstop->op_type == OP_GV)) { /* packagevar $a[] or $h{} */ - GV * const gv = cGVOPx_gv(op); + GV * const gv = cGVOPx_gv(firstop); if (gv) tmpstr = Perl_newSVpvf(aTHX_ @@ -6365,13 +6664,15 @@ Perl_ck_fun(pTHX_ OP *o) listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { - OP *newop = newUNOP(type, 0, newDEFSVOP()); #ifdef PERL_MAD + OP *newop = newUNOP(type, 0, newDEFSVOP()); op_getmad(o,newop,'O'); + return newop; #else + /* Ordering of these two is important to keep f_map.t passing. */ op_free(o); + return newUNOP(type, 0, newDEFSVOP()); #endif - return newop; } if (oa) { @@ -6442,13 +6743,13 @@ OP * Perl_ck_grep(pTHX_ OP *o) { dVAR; - LOGOP *gwop; + LOGOP *gwop = NULL; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - I32 offset; + PADOFFSET offset; o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; - NewOp(1101, gwop, 1, LOGOP); + /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { OP* k; @@ -6459,6 +6760,7 @@ Perl_ck_grep(pTHX_ OP *o) for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { kid = k; } + NewOp(1101, gwop, 1, LOGOP); kid->op_next = (OP*)gwop; o->op_flags &= ~OPf_STACKED; } @@ -6468,13 +6770,15 @@ Perl_ck_grep(pTHX_ OP *o) else scalar(kid); o = ck_fun(o); - if (PL_error_count) + if (PL_parser && PL_parser->error_count) return o; kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_grep"); kid = kUNOP->op_first; + if (!gwop) + NewOp(1101, gwop, 1, LOGOP); gwop->op_type = type; gwop->op_ppaddr = PL_ppaddr[type]; gwop->op_first = listkids(o); @@ -6566,6 +6870,22 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ } OP * +Perl_ck_readline(pTHX_ OP *o) +{ + if (!(o->op_flags & OPf_KIDS)) { + OP * const newop + = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); +#ifdef PERL_MAD + op_getmad(o,newop,'O'); +#else + op_free(o); +#endif + return newop; + } + return o; +} + +OP * Perl_ck_rfun(pTHX_ OP *o) { const OPCODE type = o->op_type; @@ -6603,16 +6923,6 @@ Perl_ck_listiob(pTHX_ OP *o) } OP * -Perl_ck_say(pTHX_ OP *o) -{ - o = ck_listiob(o); - o->op_type = OP_PRINT; - cLISTOPo->op_last = cLISTOPo->op_last->op_sibling - = newSVOP(OP_CONST, 0, newSVpvs("\n")); - return o; -} - -OP * Perl_ck_smartmatch(pTHX_ OP *o) { dVAR; @@ -6643,12 +6953,15 @@ Perl_ck_smartmatch(pTHX_ OP *o) OP * Perl_ck_sassign(pTHX_ OP *o) { - OP *kid = cLISTOPo->op_first; + OP * const kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) && !(kid->op_flags & OPf_STACKED) /* Cannot steal the second time! */ - && !(kid->op_private & OPpTARGET_MY)) + && !(kid->op_private & OPpTARGET_MY) + /* Keep the full thing for madskills */ + && !PL_madskills + ) { OP * const kkid = kid->op_sibling; @@ -6661,13 +6974,8 @@ Perl_ck_sassign(pTHX_ OP *o) /* Now we do not need PADSV and SASSIGN. */ kid->op_sibling = o->op_sibling; /* NULL */ cLISTOPo->op_first = NULL; -#ifdef PERL_MAD - op_getmad(o,kid,'O'); - op_getmad(kkid,kid,'M'); -#else op_free(o); op_free(kkid); -#endif kid->op_private |= OPpTARGET_MY; /* Used for context settings */ return kid; } @@ -6680,7 +6988,7 @@ Perl_ck_match(pTHX_ OP *o) { dVAR; if (o->op_type != OP_QR && PL_compcv) { - const I32 offset = pad_findmy("$_"); + const PADOFFSET offset = pad_findmy("$_"); if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { o->op_targ = offset; o->op_private |= OPpTARGET_MY; @@ -6749,8 +7057,18 @@ Perl_ck_open(pTHX_ OP *o) o->op_private |= OPpOPEN_OUT_CRLF; } } - if (o->op_type == OP_BACKTICK) + 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; + } { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ @@ -6834,18 +7152,18 @@ Perl_ck_require(pTHX_ OP *o) if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { OP * const kid = cUNOPo->op_first; - OP * newop - = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, kid, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv)))))); + OP * newop; + cUNOPo->op_first = 0; -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else +#ifndef PERL_MAD op_free(o); #endif + newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, kid, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, + gv)))))); + op_getmad(o,newop,'O'); return newop; } @@ -6895,7 +7213,7 @@ Perl_ck_shift(pTHX_ OP *o) OP *argop; /* FIXME - this can be refactored to reduce code in #ifdefs */ #ifdef PERL_MAD - OP *oldo = o; + OP * const oldo = o; #else op_free(o); #endif @@ -6918,8 +7236,7 @@ Perl_ck_sort(pTHX_ OP *o) dVAR; OP *firstkid; - if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) - { + if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) { HV * const hinthv = GvHV(PL_hintgv); if (hinthv) { SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); @@ -7111,6 +7428,7 @@ Perl_ck_split(pTHX_ OP *o) if (!kid->op_sibling) append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); + assert(kid->op_sibling); kid = kid->op_sibling; scalar(kid); @@ -7129,9 +7447,10 @@ Perl_ck_join(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const char *pmstr = re ? re->precomp : "STRING"; + const STRLEN len = re ? re->prelen : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%s/ should probably be written as \"%s\"", - pmstr, pmstr); + "/%.*s/ should probably be written as \"%.*s\"", + (int)len, pmstr, (int)len, pmstr); } } return ck_fun(o); @@ -7145,13 +7464,14 @@ Perl_ck_subr(pTHX_ OP *o) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; OP *cvop; - char *proto = NULL; + const char *proto = NULL; + const char *proto_end = NULL; CV *cv = NULL; GV *namegv = NULL; int optional = 0; I32 arg = 0; I32 contextclass = 0; - char *e = NULL; + const char *e = NULL; bool delete_op = 0; o->op_private |= OPpENTERSUB_HASTARG; @@ -7168,21 +7488,10 @@ Perl_ck_subr(pTHX_ OP *o) tmpop->op_private |= OPpEARLY_CV; else { if (SvPOK(cv)) { + STRLEN len; namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV_nolen((SV*)cv); - } - if (CvASSERTION(cv)) { - if (PL_hints & HINT_ASSERTING) { - if (PERLDB_ASSERTION && PL_curstash != PL_debstash) - o->op_private |= OPpENTERSUB_DB; - } - else { - delete_op = 1; - if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { - Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), - "Impossible to activate assertion call"); - } - } + proto = SvPV((SV*)cv, len); + proto_end = proto + len; } } } @@ -7201,18 +7510,27 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { OP* o3; + if (PL_madskills && o2->op_type == OP_STUB) { + o2 = o2->op_sibling; + continue; + } if (PL_madskills && o2->op_type == OP_NULL) o3 = ((UNOP*)o2)->op_first; else o3 = o2; if (proto) { - switch (*proto) { - case '\0': + if (proto >= proto_end) return too_many_arguments(o, gv_ename(namegv)); + + switch (*proto) { case ';': optional = 1; proto++; continue; + case '_': + /* _ must be at the end */ + if (proto[1] && proto[1] != ';') + goto oops; case '$': proto++; arg++; @@ -7256,7 +7574,7 @@ Perl_ck_subr(pTHX_ OP *o) OP * const sibling = o2->op_sibling; SV * const n = newSVpvs(""); #ifdef PERL_MAD - OP *oldo2 = o2; + OP * const oldo2 = o2; #else op_free(o2); #endif @@ -7291,15 +7609,13 @@ Perl_ck_subr(pTHX_ OP *o) break; case ']': if (contextclass) { - /* XXX We shouldn't be modifying proto, so we can const proto */ - char *p = proto; - const char s = *p; + const char *p = proto; + const char *const end = proto; contextclass = 0; - *p = '\0'; while (*--p != '['); - bad_type(arg, Perl_form(aTHX_ "one of %s", p), - gv_ename(namegv), o3); - *proto = s; + bad_type(arg, Perl_form(aTHX_ "one of %.*s", + (int)(end - p), p), + gv_ename(namegv), o3); } else goto oops; break; @@ -7320,8 +7636,7 @@ Perl_ck_subr(pTHX_ OP *o) if (o3->op_type == OP_RV2SV || o3->op_type == OP_PADSV || o3->op_type == OP_HELEM || - o3->op_type == OP_AELEM || - o3->op_type == OP_THREADSV) + o3->op_type == OP_AELEM) goto wrapref; if (!contextclass) bad_type(arg, "scalar", gv_ename(namegv), o3); @@ -7365,7 +7680,7 @@ Perl_ck_subr(pTHX_ OP *o) default: oops: Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, - gv_ename(namegv), cv); + gv_ename(namegv), SVfARG(cv)); } } else @@ -7374,12 +7689,18 @@ Perl_ck_subr(pTHX_ OP *o) prev = o2; o2 = o2->op_sibling; } /* while */ - if (proto && !optional && - (*proto && *proto != '@' && *proto != '%' && *proto != ';')) + if (o2 == cvop && proto && *proto == '_') { + /* generate an access to $_ */ + o2 = newDEFSVOP(); + o2->op_sibling = prev->op_sibling; + prev->op_sibling = o2; /* instead of cvop */ + } + if (proto && !optional && proto_end > proto && + (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) return too_few_arguments(o, gv_ename(namegv)); if(delete_op) { #ifdef PERL_MAD - OP *oldo = o; + OP * const oldo = o; #else op_free(o); #endif @@ -7401,7 +7722,7 @@ OP * Perl_ck_chdir(pTHX_ OP *o) { if (o->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOPo->op_first; + SVOP * const kid = (SVOP*)cUNOPo->op_first; if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) @@ -7447,7 +7768,7 @@ OP * Perl_ck_substr(pTHX_ OP *o) { o = ck_fun(o); - if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { + if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { OP *kid = cLISTOPo->op_first; if (kid->op_type == OP_NULL) @@ -7477,13 +7798,15 @@ Perl_peep(pTHX_ register OP *o) for (; o; o = o->op_next) { 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; PL_op = o; switch (o->op_type) { case OP_SETSTATE: case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ - o->op_opt = 1; break; case OP_CONST: @@ -7526,14 +7849,13 @@ Perl_peep(pTHX_ register OP *o) o->op_targ = ix; } #endif - o->op_opt = 1; break; case OP_CONCAT: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { if (o->op_flags & OPf_STACKED) /* chained concats */ - goto ignore_optimization; + break; /* ignore_optimization */ else { /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; @@ -7543,12 +7865,9 @@ Perl_peep(pTHX_ register OP *o) } op_null(o->op_next); } - ignore_optimization: - o->op_opt = 1; break; case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - o->op_opt = 1; break; /* Scalar stub must produce undef. List stub is noop */ } goto nothin; @@ -7564,20 +7883,17 @@ Perl_peep(pTHX_ register OP *o) has already occurred. This doesn't fix the real problem, though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ - if (oldop && o->op_next) { - oldop->op_next = o->op_next; - continue; - } - break; + o->op_opt = 0; + /* FALL THROUGH */ case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: - nothin: + nothin: if (oldop && o->op_next) { oldop->op_next = o->op_next; + o->op_opt = 0; continue; } - o->op_opt = 1; break; case OP_PADAV: @@ -7591,7 +7907,7 @@ Perl_peep(pTHX_ register OP *o) pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && - (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase) + (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop)) <= 255 && i >= 0) { @@ -7614,7 +7930,6 @@ Perl_peep(pTHX_ register OP *o) o->op_flags |= OPf_SPECIAL; o->op_type = OP_AELEMFAST; } - o->op_opt = 1; break; } @@ -7636,7 +7951,7 @@ Perl_peep(pTHX_ register OP *o) gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", - sv); + SVfARG(sv)); } } else if (o->op_next->op_type == OP_READLINE @@ -7651,7 +7966,6 @@ Perl_peep(pTHX_ register OP *o) op_null(o->op_next); } - o->op_opt = 1; break; case OP_MAPWHILE: @@ -7664,7 +7978,6 @@ Perl_peep(pTHX_ register OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - o->op_opt = 1; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ @@ -7672,7 +7985,6 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: case OP_ENTERITER: - o->op_opt = 1; while (cLOOP->op_redoop->op_type == OP_NULL) cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); @@ -7684,33 +7996,30 @@ Perl_peep(pTHX_ register OP *o) peep(cLOOP->op_lastop); break; - case OP_QR: - case OP_MATCH: case OP_SUBST: - o->op_opt = 1; - while (cPMOP->op_pmreplstart && - cPMOP->op_pmreplstart->op_type == OP_NULL) - cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; - peep(cPMOP->op_pmreplstart); + assert(!(cPMOP->op_pmflags & PMf_ONCE)); + while (cPMOP->op_pmstashstartu.op_pmreplstart && + cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmstashstartu.op_pmreplstart + = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; + peep(cPMOP->op_pmstashstartu.op_pmreplstart); break; case OP_EXEC: - o->op_opt = 1; if (o->op_next && o->op_next->op_type == OP_NEXTSTATE && ckWARN(WARN_SYNTAX)) { - if (o->op_next->op_sibling && - o->op_next->op_sibling->op_type != OP_EXIT && - o->op_next->op_sibling->op_type != OP_WARN && - o->op_next->op_sibling->op_type != OP_DIE) { - const line_t oldline = CopLINE(PL_curcop); - - CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); - Perl_warner(aTHX_ packWARN(WARN_EXEC), - "Statement unlikely to be reached"); - Perl_warner(aTHX_ packWARN(WARN_EXEC), - "\t(Maybe you meant system() when you said exec()?)\n"); - CopLINE_set(PL_curcop, oldline); + if (o->op_next->op_sibling) { + const OPCODE type = o->op_next->op_sibling->op_type; + if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { + const line_t oldline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); + Perl_warner(aTHX_ packWARN(WARN_EXEC), + "Statement unlikely to be reached"); + Perl_warner(aTHX_ packWARN(WARN_EXEC), + "\t(Maybe you meant system() when you said exec()?)\n"); + CopLINE_set(PL_curcop, oldline); + } } } break; @@ -7723,8 +8032,6 @@ Perl_peep(pTHX_ register OP *o) const char *key = NULL; STRLEN keylen; - o->op_opt = 1; - if (((BINOP*)o)->op_last->op_type != OP_CONST) break; @@ -7733,7 +8040,7 @@ Perl_peep(pTHX_ register OP *o) if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, - SvUTF8(sv) ? -(I32)keylen : keylen, + SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 0); SvREFCNT_dec(sv); *svp = lexname; @@ -7753,7 +8060,7 @@ Perl_peep(pTHX_ register OP *o) break; key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) + SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", @@ -7810,7 +8117,7 @@ Perl_peep(pTHX_ register OP *o) svp = cSVOPx_svp(key_op); key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) + SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { Perl_croak(aTHX_ "No such class field \"%s\" " "in variable %s of type %s", @@ -7851,8 +8158,6 @@ Perl_peep(pTHX_ register OP *o) /* make @a = sort @a act in-place */ - o->op_opt = 1; - oright = cUNOPx(oright)->op_sibling; if (!oright) break; @@ -7943,7 +8248,6 @@ Perl_peep(pTHX_ register OP *o) OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; LISTOP *enter, *exlist; - o->op_opt = 1; enter = (LISTOP *) o->op_next; if (!enter) @@ -8034,13 +8338,6 @@ Perl_peep(pTHX_ register OP *o) UNOP *refgen, *rv2cv; LISTOP *exlist; - /* I do not understand this, but if o->op_opt isn't set to 1, - various tests in ext/B/t/bytecode.t fail with no readily - apparent cause. */ - - o->op_opt = 1; - - if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID) break; @@ -8081,8 +8378,11 @@ Perl_peep(pTHX_ register OP *o) } - default: - o->op_opt = 1; + case OP_QR: + case OP_MATCH: + if (!(cPMOP->op_pmflags & PMf_ONCE)) { + assert (!cPMOP->op_pmstashstartu.op_pmreplstart); + } break; } oldop = o; @@ -8090,7 +8390,7 @@ Perl_peep(pTHX_ register OP *o) LEAVE; } -char* +const char* Perl_custom_op_name(pTHX_ const OP* o) { dVAR; @@ -8110,7 +8410,7 @@ Perl_custom_op_name(pTHX_ const OP* o) return SvPV_nolen(HeVAL(he)); } -char* +const char* Perl_custom_op_desc(pTHX_ const OP* o) { dVAR; @@ -8139,7 +8439,7 @@ const_sv_xsub(pTHX_ CV* cv) dVAR; dXSARGS; if (items != 0) { - /*EMPTY*/; + NOOP; #if 0 Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));