X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=a69b5156a2c939189cb376b56bcca58be9302dd8;hb=788611b6a6a160290f10302fc348e5dff91edc6e;hp=2a7583eb7d7b0c280ee863e612f8d5603970029b;hpb=4c79ee7a1e7564ef83d0ac25d6677fdebb3ec7aa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 2a7583e..a69b515 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,7 @@ /* op.c * - * Copyright (c) 1991-2003, 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]; @@ -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 @@ -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,6 +1065,7 @@ 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; @@ -1067,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: @@ -1075,6 +1095,7 @@ Perl_mod(pTHX_ OP *o, I32 type) break; case OP_RV2SV: ref(cUNOPo->op_first, o->op_type); + localize = 1; /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: @@ -1083,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; @@ -1099,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: @@ -1140,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; @@ -1147,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)) @@ -1162,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; @@ -1184,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) @@ -1784,8 +1820,11 @@ 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; return; + } PL_main_root = scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; PL_main_start = LINKLIST(PL_main_root); @@ -1825,14 +1864,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) @@ -1955,6 +2003,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--)); @@ -2115,7 +2165,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_last = pushop; } - return (OP*)listop; + return CHECKOP(type, listop); } OP * @@ -2238,13 +2288,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; @@ -2552,7 +2602,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) PmopSTASH_set(pmop,PL_curstash); } - return (OP*)pmop; + return CHECKOP(type, pmop); } OP * @@ -2599,6 +2649,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)) { @@ -2618,7 +2670,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) @@ -2777,13 +2829,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; @@ -2801,8 +2853,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); @@ -2819,14 +2871,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); @@ -2846,7 +2898,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) )); @@ -2870,6 +2922,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 */ } /* @@ -3356,6 +3409,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; @@ -3400,6 +3455,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); @@ -3564,11 +3621,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); @@ -3621,13 +3673,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); @@ -3686,6 +3741,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; @@ -3831,6 +3889,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) { @@ -3859,26 +3937,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; } @@ -4080,6 +4163,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; } @@ -4179,7 +4263,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); @@ -4261,11 +4345,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; @@ -4593,13 +4680,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", @@ -4613,8 +4704,9 @@ 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 && !(kUNOP->op_first->op_flags & OPf_MOD)) + o->op_flags |= OPf_STACKED; return o; } @@ -4706,10 +4798,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); @@ -4727,8 +4818,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); @@ -4921,6 +5014,11 @@ 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); @@ -5075,10 +5173,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 @@ -5097,9 +5191,51 @@ 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 = savepv(SvPVX(tmpstr)); + len = strlen(name); + sv_2mortal(tmpstr); + } + } + if (!name) { + name = "__ANONIO__"; + len = 10; + } + mod(kid, type); } if (name) { SV *namesv; @@ -5165,7 +5301,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, @@ -5446,6 +5582,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); } @@ -5802,7 +5957,13 @@ Perl_ck_subr(pTHX_ OP *o) if (PERLDB_ASSERTION && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; } - else delete=1; + else { + delete=1; + if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) { + Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), + "Impossible to activate assertion call"); + } + } } } }