X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=86cfe236544a8cc3f2e42f5d5c10648b970405b8;hb=6a93df2e699ee31021f3373dcafbb41d67f7f951;hp=39089fbba87063c4362c6f914d70ca1701e78650;hpb=7678c486bb9005aaaba9a0134efb395936e5a9f7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 39089fb..86cfe23 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. @@ -1837,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) @@ -2789,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; @@ -2813,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); @@ -2831,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); @@ -2858,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) )); @@ -4273,7 +4283,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) CopSTASH_set(PL_curcop,stash); } - cv = newXS(name, const_sv_xsub, CopFILE(PL_curcop)); + cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); sv_setpv((SV*)cv, ""); /* prototype is "" */ @@ -4932,6 +4942,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); @@ -5108,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; @@ -5457,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); }