X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f3548bdc4d2efd11e139d110e60764b9dae81319..ad33f57d74879c2996a4b4d81b95694b3eb74e93:/op.c diff --git a/op.c b/op.c index 8c947b7..b39d81e 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,7 @@ /* op.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 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. @@ -29,13 +30,8 @@ #define PERL_SLAB_SIZE 2048 #endif -#define NewOp(m,var,c,type) \ - STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END - -#define FreeOp(p) Slab_Free(p) - -STATIC void * -S_Slab_Alloc(pTHX_ int m, size_t sz) +void * +Perl_Slab_Alloc(pTHX_ int m, size_t sz) { /* * To make incrementing use count easy PL_OpSlab is an I32 * @@ -73,8 +69,8 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) return (void *)(PL_OpPtr + 1); } -STATIC void -S_Slab_Free(pTHX_ void *op) +void +Perl_Slab_Free(pTHX_ void *op) { I32 **ptr = (I32 **) op; I32 *slab = ptr[-1]; @@ -82,9 +78,9 @@ S_Slab_Free(pTHX_ void *op) assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); if (--(*slab) == 0) { - #ifdef NETWARE - #define PerlMemShared PerlMem - #endif +# ifdef NETWARE +# define PerlMemShared PerlMem +# endif PerlMemShared_free(slab); if (slab == PL_OpSlab) { @@ -92,10 +88,6 @@ S_Slab_Free(pTHX_ void *op) } } } - -#else -#define NewOp(m, var, c, type) Newz(m, var, c, type) -#define FreeOp(p) Safefree(p) #endif /* * In the following definition, the ", Nullop" is just to make the compiler @@ -152,8 +144,8 @@ STATIC void S_no_bareword_allowed(pTHX_ OP *o) { qerror(Perl_mess(aTHX_ - "Bareword \"%s\" not allowed while \"strict subs\" in use", - SvPV_nolen(cSVOPo_sv))); + "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", + cSVOPo_sv)); } /* "register" allocation */ @@ -193,7 +185,7 @@ Perl_allocmy(pTHX_ char *name) /* check for duplicate declaration */ pad_check_dup(name, - PL_in_my == KEY_our, + (bool)(PL_in_my == KEY_our), (PL_curstash ? PL_curstash : PL_defstash) ); @@ -299,6 +291,18 @@ Perl_op_clear(pTHX_ OP *o) case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; +#ifdef USE_ITHREADS + /** Bug #15654 + Even if op_clear does a pad_free for the target of the op, + pad_free doesn't actually remove the sv that exists in the bad + instead it lives on. This results in that it could be reused as + a target later on when the pad was reallocated. + **/ + if(o->op_targ) { + pad_swipe(o->op_targ,1); + o->op_targ = 0; + } +#endif break; case OP_GOTO: case OP_NEXT: @@ -875,10 +879,23 @@ S_modkids(pTHX_ OP *o, I32 type) return o; } +/* Propagate lvalue ("modifiable") context to an op and it's children. + * 'type' represents the context type, roughly based on the type of op that + * would do the modifying, although local() is represented by OP_NULL. + * It's responsible for detecting things that can't be modified, flag + * things that need to behave specially in an lvalue context (e.g., "$$x = 5" + * might have to vivify a reference in $x), and so on. + * + * For example, "$a+1 = 2" would cause mod() to be called with o being + * OP_ADD and type being OP_SASSIGN, and would output an error. + */ + OP * Perl_mod(pTHX_ OP *o, I32 type) { OP *kid; + /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ + int localize = -1; if (!o || PL_error_count) return o; @@ -891,6 +908,7 @@ Perl_mod(pTHX_ OP *o, I32 type) switch (o->op_type) { case OP_UNDEF: + localize = 0; PL_modcount++; return o; case OP_CONST: @@ -1047,14 +1065,13 @@ Perl_mod(pTHX_ OP *o, I32 type) break; case OP_COND_EXPR: + localize = 1; for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); break; case OP_RV2AV: case OP_RV2HV: - if (!type && cUNOPo->op_first->op_type != OP_GV) - Perl_croak(aTHX_ "Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ @@ -1069,6 +1086,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_HSLICE: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; + localize = 1; /* FALL THROUGH */ case OP_AASSIGN: case OP_NEXTSTATE: @@ -1076,9 +1094,8 @@ Perl_mod(pTHX_ OP *o, I32 type) PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: - if (!type && cUNOPo->op_first->op_type != OP_GV) - Perl_croak(aTHX_ "Can't localize through a reference"); ref(cUNOPo->op_first, o->op_type); + localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: @@ -1087,7 +1104,11 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: + PL_modcount++; + break; + case OP_AELEMFAST: + localize = 1; PL_modcount++; break; @@ -1103,17 +1124,13 @@ Perl_mod(pTHX_ OP *o, I32 type) /* FALL THROUGH */ case OP_PADSV: PL_modcount++; - if (!type) - { /* XXX DAPM 2002.08.25 tmp assert test */ - /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE)); - /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE)); - + if (!type) /* local() */ Perl_croak(aTHX_ "Can't localize lexical variable %s", PAD_COMPNAME_PV(o->op_targ)); - } break; case OP_PUSHMARK: + localize = 0; break; case OP_KEYS: @@ -1144,6 +1161,7 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_private |= OPpLVAL_DEFER; if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; + localize = 1; PL_modcount++; break; @@ -1151,11 +1169,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_LEAVE: case OP_ENTER: case OP_LINESEQ: + localize = 0; if (o->op_flags & OPf_KIDS) mod(cLISTOPo->op_last, type); break; case OP_NULL: + localize = 0; if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ goto nomod; else if (!(o->op_flags & OPf_KIDS)) @@ -1166,6 +1186,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } /* FALL THROUGH */ case OP_LIST: + localize = 0; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; @@ -1188,10 +1209,21 @@ Perl_mod(pTHX_ OP *o, I32 type) if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; - else if (!type) { - o->op_private |= OPpLVAL_INTRO; - o->op_flags &= ~OPf_SPECIAL; - PL_hints |= HINT_BLOCK_SCOPE; + else if (!type) { /* local() */ + switch (localize) { + case 1: + o->op_private |= OPpLVAL_INTRO; + o->op_flags &= ~OPf_SPECIAL; + PL_hints |= HINT_BLOCK_SCOPE; + break; + case 0: + break; + case -1: + if (ckWARN(WARN_SYNTAX)) { + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless localization of %s", OP_DESC(o)); + } + } } else if (type != OP_GREPSTART && type != OP_ENTERSUB && type != OP_LEAVESUBLV) @@ -1705,18 +1737,16 @@ Perl_scope(pTHX_ OP *o) o->op_type = OP_LEAVE; o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } - else { - if (o->op_type == OP_LINESEQ) { - OP *kid; - o->op_type = OP_SCOPE; - o->op_ppaddr = PL_ppaddr[OP_SCOPE]; - kid = ((LISTOP*)o)->op_first; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - op_null(kid); - } - else - o = newLISTOP(OP_SCOPE, 0, o, Nullop); + else if (o->op_type == OP_LINESEQ) { + OP *kid; + o->op_type = OP_SCOPE; + o->op_ppaddr = PL_ppaddr[OP_SCOPE]; + kid = ((LISTOP*)o)->op_first; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) + op_null(kid); } + else + o = newLISTOP(OP_SCOPE, 0, o, Nullop); } return o; } @@ -1734,6 +1764,8 @@ int Perl_block_start(pTHX_ int full) { int retval = PL_savestack_ix; + /* If there were syntax errors, don't try to start a block */ + if (PL_yynerrs) return retval; pad_block_start(full); SAVEHINTS(); @@ -1755,10 +1787,9 @@ OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { int needblockscope = PL_hints & HINT_BLOCK_SCOPE; - line_t copline = PL_copline; - /* there should be a nextstate in every block */ - OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq); - PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ + OP* retval = scalarseq(seq); + /* If there were syntax errors, don't try to close a block */ + if (PL_yynerrs) return retval; LEAVE_SCOPE(floor); PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); if (needblockscope) @@ -1789,8 +1820,12 @@ Perl_newPROG(pTHX_ OP *o) CALL_PEEP(PL_eval_start); } else { - if (!o) + if (o->op_type == OP_STUB) { + PL_comppad_name = 0; + PL_compcv = 0; + FreeOp(o); return; + } PL_main_root = scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; PL_main_start = LINKLIST(PL_main_root); @@ -1830,14 +1865,23 @@ Perl_localize(pTHX_ OP *o, I32 lex) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { char *s = PL_bufptr; + int sigil = 0; - while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s))) + /* some heuristics to detect a potential error */ + while (*s && (strchr(", \t\n", *s) + || (strchr("@$%*", *s) && ++sigil) )) s++; - - if (*s == ';' || *s == '=') - Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), - "Parentheses missing around \"%s\" list", - lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); + if (sigil) { + while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) + || strchr("@$%*, \t\n", *s))) + s++; + + if (*s == ';' || *s == '=') + Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), + "Parentheses missing around \"%s\" list", + lex ? (PL_in_my == KEY_our ? "our" : "my") + : "local"); + } } } if (lex) @@ -1933,19 +1977,7 @@ Perl_fold_constants(pTHX_ register OP *o) op_free(o); if (type == OP_RV2GV) return newGVOP(OP_GV, 0, (GV*)sv); - else { - /* try to smush double to int, but don't smush -2.0 to -2 */ - if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && - type != OP_NEGATE) - { -#ifdef PERL_PRESERVE_IVUV - /* Only bother to attempt to fold to IV if - most operators will benefit */ - SvIV_please(sv); -#endif - } - return newSVOP(OP_CONST, 0, sv); - } + return newSVOP(OP_CONST, 0, sv); nope: return o; @@ -1972,6 +2004,8 @@ Perl_gen_constant_list(pTHX_ register OP *o) o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; + o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ + o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_seq = 0; /* needs to be revisited in peep() */ curop = ((UNOP*)o)->op_first; ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); @@ -2132,7 +2166,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_last = pushop; } - return (OP*)listop; + return CHECKOP(type, listop); } OP * @@ -2255,13 +2289,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) U8* tend = t + tlen; U8* rend = r + rlen; STRLEN ulen; - U32 tfirst = 1; - U32 tlast = 0; - I32 tdiff; - U32 rfirst = 1; - U32 rlast = 0; - I32 rdiff; - I32 diff; + UV tfirst = 1; + UV tlast = 0; + IV tdiff; + UV rfirst = 1; + UV rlast = 0; + IV rdiff; + IV diff; I32 none = 0; U32 max = 0; I32 bits; @@ -2569,7 +2603,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) PmopSTASH_set(pmop,PL_curstash); } - return (OP*)pmop; + return CHECKOP(type, pmop); } OP * @@ -2616,6 +2650,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) : OPf_KIDS); rcop->op_private = 1; rcop->op_other = o; + /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ + PL_cv_has_eval = 1; /* establish postfix order */ if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { @@ -2635,7 +2671,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) OP *curop; if (pm->op_pmflags & PMf_EVAL) { curop = 0; - if (CopLINE(PL_curcop) < PL_multi_end) + if (CopLINE(PL_curcop) < (line_t)PL_multi_end) CopLINE_set(PL_curcop, (line_t)PL_multi_end); } else if (repl->op_type == OP_CONST) @@ -2647,7 +2683,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); repl_has_vars = 1; - if (strchr("&`'123456789+", *GvENAME(gv))) + if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) break; } else if (curop->op_type == OP_RV2CV) @@ -2794,13 +2830,13 @@ Perl_package(pTHX_ OP *o) } void -Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) +Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { OP *pack; OP *imop; OP *veop; - if (id->op_type != OP_CONST) + if (idop->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); veop = Nullop; @@ -2818,8 +2854,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) if (version->op_type != OP_CONST || !SvNIOKp(vesv)) Perl_croak(aTHX_ "Version number must be constant number"); - /* Make copy of id so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to VERSION */ meth = newSVpvn("VERSION",7); @@ -2836,14 +2872,14 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) imop = arg; /* no import on explicit () */ - else if (SvNIOKp(((SVOP*)id)->op_sv)) { + else if (SvNIOKp(((SVOP*)idop)->op_sv)) { imop = Nullop; /* use 5.0; */ } else { SV *meth; - /* Make copy of id so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); /* Fake up a method call to import/unimport */ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8); @@ -2863,7 +2899,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, - newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)), + newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); @@ -2887,6 +2923,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; + PL_cop_seqmax++; /* Purely for B::*'s benefit */ } /* @@ -2955,12 +2992,14 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) } { line_t ocopline = PL_copline; + COP *ocurcop = PL_curcop; 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; } } @@ -3099,7 +3138,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) curop->op_type == OP_PADANY) { if (PAD_COMPNAME_GEN(curop->op_targ) - == PL_generation) + == (STRLEN)PL_generation) break; PAD_COMPNAME_GEN(curop->op_targ) = PL_generation; @@ -3313,7 +3352,9 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return first; } } - else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) { + else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && + type != OP_DOR) /* [#24076] Don't warn for err FOO. */ + { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; @@ -3371,6 +3412,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first->op_next = (OP*)logop; first->op_sibling = other; + CHECKOP(type,logop); + o = newUNOP(OP_NULL, 0, (OP*)logop); other->op_next = o; @@ -3415,6 +3458,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); + CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ + logop); /* establish postfix order */ start = LINKLIST(first); @@ -3579,11 +3624,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (!next) next = unstack; cont = append_elem(OP_LINESEQ, cont, unstack); - if ((line_t)whileline != NOLINE) { - PL_copline = (line_t)whileline; - cont = append_elem(OP_LINESEQ, cont, - newSTATEOP(0, Nullch, Nullop)); - } } listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); @@ -3636,13 +3676,16 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo OP *wop; PADOFFSET padoff = 0; I32 iterflags = 0; + I32 iterpflags = 0; 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]; } else if (sv->op_type == OP_PADSV) { /* private variable */ + iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ padoff = sv->op_targ; sv->op_targ = 0; op_free(sv); @@ -3701,6 +3744,9 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, append_elem(OP_LIST, expr, scalar(sv)))); assert(!loop->op_next); + /* for my $x () sets OPpLVAL_INTRO; + * for our $x () sets OPpOUR_INTRO */ + loop->op_private = (U8)iterpflags; #ifdef PL_OP_SLAB_ALLOC { LOOP *tmp; @@ -3736,7 +3782,9 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) op_free(label); } else { - if (label->op_type == OP_ENTERSUB) + /* Check whether it's going to be a goto &function */ + if (label->op_type == OP_ENTERSUB + && !(label->op_flags & OPf_STACKED)) label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); o = newUNOP(type, OPf_STACKED, label); } @@ -3744,12 +3792,20 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) return o; } +/* +=for apidoc cv_undef + +Clear out all the active components of a CV. This can happen either +by an explicit C, or by the reference count going to zero. +In the former case, we keep the CvOUTSIDE pointer, so that any anonymous +children can still follow the full lexical scope chain. + +=cut +*/ + void Perl_cv_undef(pTHX_ CV *cv) { - CV *outsidecv; - CV *freecv = Nullcv; - #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ @@ -3771,26 +3827,24 @@ Perl_cv_undef(pTHX_ CV *cv) } SvPOK_off((SV*)cv); /* forget prototype */ CvGV(cv) = Nullgv; - outsidecv = CvOUTSIDE(cv); - /* Since closure prototypes have the same lifetime as the containing - * CV, they don't hold a refcount on the outside CV. This avoids - * the refcount loop between the outer CV (which keeps a refcount to - * the closure prototype in the pad entry for pp_anoncode()) and the - * closure prototype, and the ensuing memory leak. --GSAR */ - if (!CvANON(cv) || CvCLONED(cv)) - freecv = outsidecv; - CvOUTSIDE(cv) = Nullcv; + + pad_undef(cv); + + /* remove CvOUTSIDE unless this is an undef rather than a free */ + if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { + if (!CvWEAKOUTSIDE(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = Nullcv; + } if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); CvCONST_off(cv); } - pad_undef(cv, outsidecv); - if (freecv) - SvREFCNT_dec(freecv); if (CvXSUB(cv)) { CvXSUB(cv) = 0; } - CvFLAGS(cv) = 0; + /* delete all flags except WEAKOUTSIDE */ + CvFLAGS(cv) &= CVf_WEAKOUTSIDE; } void @@ -3806,7 +3860,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv)); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv); sv_catpv(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); @@ -3840,6 +3894,26 @@ Perl_cv_const_sv(pTHX_ CV *cv) return (SV*)CvXSUBANY(cv).any_ptr; } +/* op_const_sv: examine an optree to determine whether it's in-lineable. + * Can be called in 3 ways: + * + * !cv + * look for a single OP_CONST with attached value: return the value + * + * cv && CvCLONE(cv) && !CvCONST(cv) + * + * examine the clone prototype, and if contains only a single + * OP_CONST referencing a pad const, or a single PADSV referencing + * an outer lexical, return a non-zero value to indicate the CV is + * a candidate for "constizing" at clone time + * + * cv && CvCONST(cv) + * + * We have just cloned an anon prototype that was marked as a const + * candidiate. Try to grab the current value, and in the case of + * PADSV, ignore it if it has multiple references. Return the value. + */ + SV * Perl_op_const_sv(pTHX_ OP *o, CV *cv) { @@ -3868,26 +3942,31 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) return Nullsv; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; - else if ((type == OP_PADSV || type == OP_CONST) && cv) { + else if (cv && type == OP_CONST) { sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) return Nullsv; - if (CvCONST(cv)) { - /* We get here only from cv_clone2() while creating a closure. - Copy the const value here instead of in cv_clone2 so that - SvREADONLY_on doesn't lead to problems when leaving - scope. - */ + } + else if (cv && type == OP_PADSV) { + if (CvCONST(cv)) { /* newly cloned anon */ + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + /* the candidate should have 1 ref from this pad and 1 ref + * from the parent */ + if (!sv || SvREFCNT(sv) != 2) + return Nullsv; sv = newSVsv(sv); + SvREADONLY_on(sv); + return sv; + } + else { + if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) + sv = &PL_sv_undef; /* an arbitrary non-null value */ } - if (!SvREADONLY(sv) && SvREFCNT(sv) > 1) - return Nullsv; } - else + else { return Nullsv; + } } - if (sv) - SvREADONLY_on(sv); return sv; } @@ -4077,9 +4156,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREESV(PL_compcv); goto done; } + /* transfer PL_compcv to cv */ cv_undef(cv); CvFLAGS(cv) = CvFLAGS(PL_compcv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; @@ -4087,6 +4168,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); + PL_compcv = cv; if (PERLDB_INTER)/* Advice debugger on the new sub. */ ++PL_sub_generation; } @@ -4119,7 +4201,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_ "%s", SvPVx(ERRSV, n_a)); + Perl_croak(aTHX_ "%"SVf, ERRSV); } } } @@ -4132,6 +4214,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) mod(scalarseq(block), OP_LEAVESUBLV)); } else { + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + op_free(block); + block = newSTATEOP(0, Nullch, 0); + } CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } CvROOT(cv)->op_private |= OPpREFCOUNTED; @@ -4150,13 +4237,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvCONST_on(cv); } - /* If a potential closure prototype, don't keep a refcount on outer CV. - * This is okay as the lifetime of the prototype is tied to the - * lifetime of the outer CV. Avoids memory leak due to reference - * loop. --GSAR */ - if (!name) - SvREFCNT_dec(CvOUTSIDE(cv)); - if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -4193,7 +4273,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') goto done; - if (strEQ(s, "BEGIN")) { + if (strEQ(s, "BEGIN") && !PL_error_count) { I32 oldscope = PL_scopestack_ix; ENTER; SAVECOPFILE(&PL_compiling); @@ -4275,11 +4355,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) CopSTASH_set(PL_curcop,stash); } - cv = newXS(name, const_sv_xsub, __FILE__); + cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); sv_setpv((SV*)cv, ""); /* prototype is "" */ + if (stash) + CopSTASH_free(PL_curcop); + LEAVE; return cv; @@ -4607,13 +4690,17 @@ Perl_ck_bitop(pTHX_ OP *o) (op) == OP_NE || (op) == OP_I_NE || \ (op) == OP_NCMP || (op) == OP_I_NCMP) o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); - if (o->op_type == OP_BIT_OR - || o->op_type == OP_BIT_AND - || o->op_type == OP_BIT_XOR) + if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ + && (o->op_type == OP_BIT_OR + || o->op_type == OP_BIT_AND + || o->op_type == OP_BIT_XOR)) { - OPCODE typfirst = cBINOPo->op_first->op_type; - OPCODE typlast = cBINOPo->op_first->op_sibling->op_type; - if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast)) + OP * left = cBINOPo->op_first; + OP * right = left->op_sibling; + if ((OP_IS_NUMCOMPARE(left->op_type) && + (left->op_flags & OPf_PARENS) == 0) || + (OP_IS_NUMCOMPARE(right->op_type) && + (right->op_flags & OPf_PARENS) == 0)) if (ckWARN(WARN_PRECEDENCE)) Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), "Possible precedence problem on bitwise %c operator", @@ -4627,8 +4714,10 @@ Perl_ck_bitop(pTHX_ OP *o) OP * Perl_ck_concat(pTHX_ OP *o) { - if (cUNOPo->op_first->op_type == OP_CONCAT) - o->op_flags |= OPf_STACKED; + OP *kid = cUNOPo->op_first; + if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && + !(kUNOP->op_first->op_flags & OPf_MOD)) + o->op_flags |= OPf_STACKED; return o; } @@ -4702,8 +4791,7 @@ Perl_ck_eof(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { if (cLISTOPo->op_first->op_type == OP_STUB) { op_free(o); - o = newUNOP(type, OPf_SPECIAL, - newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV))); + o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); } return ck_fun(o); } @@ -4721,10 +4809,9 @@ Perl_ck_eval(pTHX_ OP *o) o->op_flags &= ~OPf_KIDS; op_null(o); } - else if (kid->op_type == OP_LINESEQ) { + else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; - kid->op_next = o->op_next; cUNOPo->op_first = 0; op_free(o); @@ -4742,8 +4829,10 @@ Perl_ck_eval(pTHX_ OP *o) enter->op_other = o; return o; } - else + else { scalar((OP*)kid); + PL_cv_has_eval = 1; + } } else { op_free(o); @@ -4936,12 +5025,16 @@ Perl_ck_ftst(pTHX_ OP *o) op_free(o); o = newop; } + else { + if ((PL_hints & HINT_FILETEST_ACCESS) && + OP_IS_FILETEST_ACCESS(o)) + o->op_private |= OPpFT_ACCESS; + } } else { op_free(o); if (type == OP_FTTTY) - o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE, - SVt_PVIO)); + o = newGVOP(type, OPf_REF, PL_stdingv); else o = newUNOP(type, 0, newDEFSVOP()); } @@ -5091,10 +5184,6 @@ Perl_ck_fun(pTHX_ OP *o) */ priv = OPpDEREF; if (kid->op_type == OP_PADSV) { - /*XXX DAPM 2002.08.25 tmp assert test */ - /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE)); - /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE)); - name = PAD_COMPNAME_PV(kid->op_targ); /* SvCUR of a pad namesv can't be trusted * (see PL_generation), so calc its length @@ -5113,9 +5202,50 @@ Perl_ck_fun(pTHX_ OP *o) else if (kid->op_type == OP_AELEM || kid->op_type == OP_HELEM) { - name = "__ANONIO__"; - len = 10; - mod(kid,type); + OP *op; + + name = 0; + if ((op = ((BINOP*)kid)->op_first)) { + SV *tmpstr = Nullsv; + char *a = + kid->op_type == OP_AELEM ? + "[]" : "{}"; + if (((op->op_type == OP_RV2AV) || + (op->op_type == OP_RV2HV)) && + (op = ((UNOP*)op)->op_first) && + (op->op_type == OP_GV)) { + /* packagevar $a[] or $h{} */ + GV *gv = cGVOPx_gv(op); + if (gv) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + GvNAME(gv), + a[0], a[1]); + } + else if (op->op_type == OP_PADAV + || op->op_type == OP_PADHV) { + /* lexicalvar $a[] or $h{} */ + char *padname = + PAD_COMPNAME_PV(op->op_targ); + if (padname) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + padname + 1, + a[0], a[1]); + + } + if (tmpstr) { + name = SvPV(tmpstr, len); + sv_2mortal(tmpstr); + } + } + if (!name) { + name = "__ANONIO__"; + len = 10; + } + mod(kid, type); } if (name) { SV *namesv; @@ -5181,7 +5311,7 @@ Perl_ck_glob(pTHX_ OP *o) #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ - if (!gv) { + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { GV *glob_gv; ENTER; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, @@ -5202,6 +5332,7 @@ Perl_ck_glob(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_LIST]; cLISTOPo->op_first->op_type = OP_PUSHMARK; cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; + cLISTOPo->op_first->op_targ = 0; o = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, @@ -5462,6 +5593,25 @@ Perl_ck_open(pTHX_ OP *o) } if (o->op_type == OP_BACKTICK) return o; + { + /* In case of three-arg dup open remove strictness + * from the last arg if it is a bareword. */ + OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ + OP *last = cLISTOPx(o)->op_last; /* The bareword. */ + OP *oa; + char *mode; + + if ((last->op_type == OP_CONST) && /* The bareword. */ + (last->op_private & OPpCONST_BARE) && + (last->op_private & OPpCONST_STRICT) && + (oa = first->op_sibling) && /* The fh. */ + (oa = oa->op_sibling) && /* The mode. */ + SvPOK(((SVOP*)oa)->op_sv) && + (mode = SvPVX(((SVOP*)oa)->op_sv)) && + mode[0] == '>' && mode[1] == '&' && /* A dup open. */ + (last == oa->op_sibling)) /* The bareword. */ + last->op_private &= ~OPpCONST_STRICT; + } return ck_fun(o); } @@ -5574,8 +5724,7 @@ Perl_ck_shift(pTHX_ OP *o) op_free(o); argop = newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ? - PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); + scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); return newUNOP(type, 0, scalar(argop)); } return scalar(modkids(ck_fun(o), type)); @@ -5795,6 +5944,7 @@ Perl_ck_subr(pTHX_ OP *o) I32 contextclass = 0; char *e = 0; STRLEN n_a; + bool delete=0; o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; @@ -5808,9 +5958,24 @@ Perl_ck_subr(pTHX_ OP *o) cv = GvCVu(gv); if (!cv) tmpop->op_private |= OPpEARLY_CV; - else if (SvPOK(cv)) { - namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV((SV*)cv, n_a); + else { + if (SvPOK(cv)) { + namegv = CvANON(cv) ? gv : CvGV(cv); + proto = SvPV((SV*)cv, n_a); + } + if (CvASSERTION(cv)) { + if (PL_hints & HINT_ASSERTING) { + if (PERLDB_ASSERTION && PL_curstash != PL_debstash) + o->op_private |= OPpENTERSUB_DB; + } + else { + delete=1; + if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) { + Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), + "Impossible to activate assertion call"); + } + } + } } } } @@ -5981,8 +6146,8 @@ Perl_ck_subr(pTHX_ OP *o) continue; default: oops: - Perl_croak(aTHX_ "Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, n_a)); + Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, + gv_ename(namegv), cv); } } else @@ -5994,6 +6159,10 @@ Perl_ck_subr(pTHX_ OP *o) if (proto && !optional && (*proto && *proto != '@' && *proto != '%' && *proto != ';')) return too_few_arguments(o, gv_ename(namegv)); + if(delete) { + op_free(o); + o=newSVOP(OP_CONST, 0, newSViv(0)); + } return o; } @@ -6023,6 +6192,18 @@ Perl_ck_trunc(pTHX_ OP *o) } OP * +Perl_ck_unpack(pTHX_ OP *o) +{ + OP *kid = cLISTOPo->op_first; + if (kid->op_sibling) { + kid = kid->op_sibling; + if (!kid->op_sibling) + kid->op_sibling = newDEFSVOP(); + } + return ck_fun(o); +} + +OP * Perl_ck_substr(pTHX_ OP *o) { o = ck_fun(o); @@ -6053,8 +6234,10 @@ Perl_peep(pTHX_ register OP *o) for (; o; o = o->op_next) { if (o->op_seq) break; - if (!PL_op_seqmax) - PL_op_seqmax++; + /* The special value -1 is used by the B::C compiler backend to indicate + * that an op is statically defined and should not be freed */ + if (!PL_op_seqmax || PL_op_seqmax == (U16)-1) + PL_op_seqmax = 1; PL_op = o; switch (o->op_type) { case OP_SETSTATE: @@ -6068,12 +6251,13 @@ Perl_peep(pTHX_ register OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); #ifdef USE_ITHREADS + case OP_METHOD_NAMED: /* Relocate sv to the pad for thread safety. * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - if (SvPADTMP(cSVOPo->op_sv)) { + if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by * some pad, so make a copy. */ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); @@ -6187,8 +6371,8 @@ Perl_peep(pTHX_ register OP *o) SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), - "%s() called too early to check prototype", - SvPV_nolen(sv)); + "%"SVf"() called too early to check prototype", + sv); } } else if (o->op_next->op_type == OP_READLINE