X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=86cfe236544a8cc3f2e42f5d5c10648b970405b8;hb=6a93df2e699ee31021f3373dcafbb41d67f7f951;hp=9bd7aaa46893e4cee797d22a60294feb841f6014;hpb=4927db4444d4255bf5c9a54ba1d153bb533bd274;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 9bd7aaa..86cfe23 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. @@ -299,6 +300,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: @@ -1053,8 +1066,6 @@ Perl_mod(pTHX_ OP *o, I32 type) 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. */ @@ -1076,8 +1087,6 @@ 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); /* FALL THROUGH */ case OP_GV: @@ -1788,7 +1797,7 @@ Perl_newPROG(pTHX_ OP *o) CALL_PEEP(PL_eval_start); } else { - if (!o) + if (o->op_type == OP_STUB) return; PL_main_root = scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; @@ -1829,14 +1838,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) @@ -2634,7 +2652,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) @@ -2781,13 +2799,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; @@ -2805,8 +2823,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); @@ -2823,14 +2841,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); @@ -2850,7 +2868,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) )); @@ -4183,7 +4201,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); @@ -4265,7 +4283,7 @@ 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 "" */ @@ -4692,8 +4710,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); } @@ -4711,10 +4728,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); @@ -4926,12 +4942,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()); } @@ -5103,9 +5123,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; @@ -5452,6 +5514,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); } @@ -5564,8 +5645,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)); @@ -5785,6 +5865,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) ; @@ -5798,9 +5879,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"); + } + } + } } } } @@ -5984,6 +6080,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; }