X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=86bd41967d2b65ebf6ae4d22fe75a3f62aca26b3;hb=517e7c645afd88cb6b76e340708d0fff8202d858;hp=592d16a5303fd7403bed86f565c9d0fdcb3e7435;hpb=d6b6943a97c6558b9dac96a87ed59af4004a298e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 592d16a..86bd419 100644 --- a/op.c +++ b/op.c @@ -22,19 +22,6 @@ /* #define PL_OP_SLAB_ALLOC */ -/* XXXXXX testing */ -#ifdef USE_ITHREADS -# define OP_REFCNT_LOCK NOOP -# define OP_REFCNT_UNLOCK NOOP -# define OpREFCNT_set(o,n) ((o)->op_targ = (n)) -# define OpREFCNT_dec(o) (--(o)->op_targ) -#else -# define OP_REFCNT_LOCK NOOP -# define OP_REFCNT_UNLOCK NOOP -# define OpREFCNT_set(o,n) NOOP -# define OpREFCNT_dec(o) 0 -#endif - #ifdef PL_OP_SLAB_ALLOC #define SLAB_SIZE 8192 static char *PL_OpPtr = NULL; @@ -124,11 +111,10 @@ Perl_pad_allocmy(pTHX_ char *name) PADOFFSET off; SV *sv; - if (!( - PL_in_my == KEY_our || - isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || - name[1] == '_' && (int)strlen(name) > 2 )) + if (!(PL_in_my == KEY_our || + isALPHA(name[1]) || + (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || + (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ @@ -173,20 +159,20 @@ Perl_pad_allocmy(pTHX_ char *name) } } if (PL_in_my == KEY_our) { - while (off >= 0 && off <= top) { + do { if ((sv = svp[off]) && sv != &PL_sv_undef + && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) && strEQ(name, SvPVX(sv))) { Perl_warner(aTHX_ WARN_MISC, "\"our\" variable %s redeclared", name); Perl_warner(aTHX_ WARN_MISC, - "(Did you mean \"local\" instead of \"our\"?)\n"); + "\t(Did you mean \"local\" instead of \"our\"?)\n"); break; } - --off; - } + } while ( off-- > 0 ); } } off = pad_alloc(OP_PADSV, SVs_PADMY); @@ -204,7 +190,7 @@ Perl_pad_allocmy(pTHX_ char *name) } if (PL_in_my == KEY_our) { (void)SvUPGRADE(sv, SVt_PVGV); - GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? PL_curstash : PL_defstash); + GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash); SvFLAGS(sv) |= SVpad_OUR; } av_store(PL_comppad_name, off, sv); @@ -336,9 +322,12 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } } else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)) + if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv) + && !(SvFLAGS(sv) & SVpad_OUR)) + { Perl_warner(aTHX_ WARN_CLOSURE, "Variable \"%s\" will not stay shared", name); + } } } av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv)); @@ -370,8 +359,9 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, if (CxREALEVAL(cx)) saweval = i; break; + case OP_DOFILE: case OP_REQUIRE: - /* require must have its own scope */ + /* require/do must have their own scope */ return 0; } break; @@ -794,6 +784,7 @@ S_op_clear(pTHX_ OP *o) cSVOPo->op_sv = Nullsv; #endif break; + case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; @@ -853,8 +844,8 @@ S_cop_free(pTHX_ COP* cop) { Safefree(cop->cop_label); #ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXXXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXXXX share in a pvtable? */ + Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ + Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ #else /* NOTE: COP.cop_stash is not refcounted */ SvREFCNT_dec(CopFILEGV(cop)); @@ -976,7 +967,7 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - while (kid = kid->op_sibling) { + while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else @@ -1174,7 +1165,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: - case OP_SCALAR: if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ @@ -1193,6 +1183,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_REQUIRE: /* all requires must return a boolean value */ o->op_flags &= ~OPf_WANT; + /* FALL THROUGH */ + case OP_SCALAR: return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { @@ -1269,7 +1261,7 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - while (kid = kid->op_sibling) { + while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else @@ -1339,7 +1331,6 @@ Perl_mod(pTHX_ OP *o, I32 type) { dTHR; OP *kid; - SV *sv; STRLEN n_a; if (!o || PL_error_count) @@ -1836,7 +1827,6 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - OP *modname; /* for 'use' */ SV *stashsv; /* fake up C */ @@ -1846,22 +1836,52 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) stashsv = newSVpv(HvNAME(stash), 0); else stashsv = &PL_sv_no; + #define ATTRSMODULE "attributes" - modname = newSVOP(OP_CONST, 0, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); - modname->op_private |= OPpCONST_BARE; - /* that flag is required to make 'use' work right */ - utilize(1, start_subparse(FALSE, 0), - Nullop, /* version */ - modname, - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, newRV(target)), - dup_attrlist(attrs)))); + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); LEAVE; } +void +Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, + char *attrstr, STRLEN len) +{ + OP *attrs = Nullop; + + if (!len) { + len = strlen(attrstr); + } + + while (len) { + for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; + if (len) { + char *sstr = attrstr; + for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(sstr, attrstr-sstr))); + } + } + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV((SV*)cv)), + attrs))); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs) { @@ -1963,11 +1983,14 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) desc, sample, sample); } - if (right->op_type == OP_MATCH || + if (!(right->op_flags & OPf_STACKED) && + (right->op_type == OP_MATCH || right->op_type == OP_SUBST || - right->op_type == OP_TRANS) { + right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH) + if (right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2355,8 +2378,11 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) if (!last) return first; - if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS) - return newLISTOP(type, 0, first, last); + if (first->op_type != type + || (type == OP_LIST && (first->op_flags & OPf_PARENS))) + { + return newLISTOP(type, 0, first, last); + } if (first->op_flags & OPf_KIDS) ((LISTOP*)first)->op_last->op_sibling = last; @@ -2582,6 +2608,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) complement = o->op_private & OPpTRANS_COMPLEMENT; del = o->op_private & OPpTRANS_DELETE; squash = o->op_private & OPpTRANS_SQUASH; + + if (SvUTF8(tstr)) + o->op_private |= OPpTRANS_FROM_UTF; + + if (SvUTF8(rstr)) + o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); @@ -2602,7 +2634,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 grows = 0; I32 havefinal = 0; U32 final; - HV *hv; I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; I32 to_utf = o->op_private & OPpTRANS_TO_UTF; @@ -2654,15 +2685,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) r = t; rlen = tlen; rend = tend; } if (!squash) { - if (to_utf && from_utf) { /* only counting characters */ - if (t == r || (tlen == rlen && memEQ(t, r, tlen))) - o->op_private |= OPpTRANS_IDENTICAL; - } - else { /* straight latin-1 translation */ - if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) && - rlen == 4 && memEQ(r, "\0\377\303\277", 4)) + if (t == r || + (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { o->op_private |= OPpTRANS_IDENTICAL; - } + } } while (t < tend || tfirst <= tlast) { @@ -2761,7 +2788,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SvREFCNT_dec(transv); if (!del && havefinal) - (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSViv((IV)final), 0); + (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, + newSVuv((UV)final), 0); if (grows && to_utf) o->op_private |= OPpTRANS_GROWS; @@ -3095,7 +3123,6 @@ void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) { OP *pack; - OP *meth; OP *rqop; OP *imop; OP *veop; @@ -3125,7 +3152,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) /* Fake up a method call to VERSION */ meth = newSVpvn("VERSION",7); sv_upgrade(meth, SVt_PVIV); - SvIOK_on(meth); + (void)SvIOK_on(meth); PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, @@ -3149,7 +3176,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) /* Fake up a method call to import/unimport */ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);; sv_upgrade(meth, SVt_PVIV); - SvIOK_on(meth); + (void)SvIOK_on(meth); PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, @@ -3189,6 +3216,65 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) PL_expect = XSTATE; } +void +Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#ifdef PERL_IMPLICIT_CONTEXT +void +Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) +{ + dTHX; + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} +#endif + +void +Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) +{ + OP *modname, *veop, *imop; + + modname = newSVOP(OP_CONST, 0, name); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = Nullop; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = Nullop; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + line_t ocopline = PL_copline; + int oexpect = PL_expect; + + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + PL_expect = oexpect; + PL_copline = ocopline; + } +} + OP * Perl_dofile(pTHX_ OP *term) { @@ -3273,6 +3359,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (list_assignment(left)) { dTHR; + OP *curop; + PL_modcount = 0; PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ left = mod(left, OP_AASSIGN); @@ -3283,12 +3371,19 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) op_free(right); return Nullop; } - o = newBINOP(OP_AASSIGN, flags, - list(force_list(right)), - list(force_list(left)) ); + curop = list(force_list(left)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); o->op_private = 0 | (flags >> 8); + for (curop = ((LISTOP*)curop)->op_first; + curop; curop = curop->op_sibling) + { + if (curop->op_type == OP_RV2HV && + ((UNOP*)curop)->op_first->op_type != OP_GV) { + o->op_private |= OPpASSIGN_HASH; + break; + } + } if (!(left->op_private & OPpLVAL_INTRO)) { - OP *curop; OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { @@ -3332,7 +3427,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) lastop = curop; } if (curop != o) - o->op_private = OPpASSIGN_COMMON; + o->op_private |= OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT) { OP* tmpop; @@ -3440,9 +3535,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) PL_copline = NOLINE; } #ifdef USE_ITHREADS - CopFILE_set(cop, CopFILE(PL_curcop)); /* XXXXX share in a pvtable? */ + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else - CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop))); + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif CopSTASH_set(cop, PL_curstash); @@ -3802,7 +3897,10 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * loopflags |= OPpLOOP_CONTINUE; } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3825,8 +3923,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -3859,7 +3955,6 @@ OP * Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) { LOOP *loop; - LOOP *tmp; OP *wop; int padoff = 0; I32 iterflags = 0; @@ -3934,9 +4029,12 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo append_elem(OP_LIST, expr, scalar(sv)))); assert(!loop->op_next); #ifdef PL_OP_SLAB_ALLOC - NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LOOP); - loop = tmp; + { + LOOP *tmp; + NewOp(1234,tmp,1,LOOP); + Copy(loop,tmp,1,LOOP); + loop = tmp; + } #else Renew(loop, 1, LOOP); #endif @@ -4104,9 +4202,8 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) cv = PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)cv, SvTYPE(proto)); + CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE; CvCLONED_on(cv); - if (CvANON(proto)) - CvANON_on(cv); #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); @@ -4368,10 +4465,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!name || GvCVGEN(gv)) cv = Nullcv; - else if (cv = GvCV(gv)) { - cv_ckproto(cv, gv, ps); + else if ((cv = GvCV(gv))) { + bool exists = CvROOT(cv) || CvXSUB(cv); + /* if the subroutine doesn't exist and wasn't pre-declared + * with a prototype, assume it will be AUTOLOADed, + * skipping the prototype check + */ + if (exists || SvPOK(cv)) + cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ - if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + if (exists || GvASSUMECV(gv)) { SV* const_sv; bool const_changed = TRUE; if (!block && !attrs) { @@ -4384,9 +4487,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); if (!block) goto withattrs; - if (const_sv = cv_const_sv(cv)) + if ((const_sv = cv_const_sv(cv))) const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); - if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE)) + if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); @@ -4552,7 +4655,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); CV *pcv; HV *hv; - char *t; Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", CopFILE(PL_curcop), @@ -4590,8 +4692,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; @@ -4603,23 +4705,27 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_endav = newAV(); DEBUG_x( dump_sub(gv) ); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + 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_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + 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) ); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } @@ -4645,10 +4751,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) dTHR; ENTER; - SAVECOPLINE(PL_curcop); - SAVEHINTS(); + SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); + + SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { @@ -4688,7 +4795,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - if (cv = (name ? GvCV(gv) : Nullcv)) { + if ((cv = (name ? GvCV(gv) : Nullcv))) { if (GvCVGEN(gv)) { /* just a cached method */ SvREFCNT_dec(cv); @@ -4745,28 +4852,32 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + 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, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + 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_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + 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(); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } else @@ -4792,7 +4903,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); GvMULTI_on(gv); - if (cv = GvFORM(gv)) { + if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); @@ -5110,6 +5221,20 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_exit(pTHX_ OP *o) +{ +#ifdef VMS + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + if (svp && *svp && SvTRUE(*svp)) + o->op_private |= OPpEXIT_VMSISH; + } +#endif + return ck_fun(o); +} + +OP * Perl_ck_exec(pTHX_ OP *o) { OP *kid; @@ -5256,6 +5381,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[kPADOP->op_padix]); GvIN_PAD_on(gv); PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); #else @@ -5328,7 +5454,7 @@ Perl_ck_fun(pTHX_ OP *o) tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || - kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK) + (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { tokid = &kid->op_sibling; kid = kid->op_sibling; @@ -5452,11 +5578,18 @@ Perl_ck_fun(pTHX_ OP *o) name = GvNAME(gv); len = GvNAMELEN(gv); } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + name = "__ANONIO__"; + len = 10; + mod(kid,type); + } if (name) { SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PL_curpad[targ]; - SvUPGRADE(namesv, SVt_PV); + (void)SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvn(namesv, "$", 1); sv_catpvn(namesv, name, len); @@ -5514,11 +5647,10 @@ Perl_ck_glob(pTHX_ OP *o) #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { - OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10)); - modname->op_private |= OPpCONST_BARE; ENTER; - utilize(1, start_subparse(FALSE, 0), Nullop, modname, - newSVOP(OP_CONST, 0, newSVpvn(":globally", 9))); + Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv, + /* null-terminated import list */ + newSVpvn(":globally", 9), Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); LEAVE; } @@ -5637,7 +5769,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ Perl_warner(aTHX_ WARN_DEPRECATED, "defined(@array) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: break; /* Globals via GV can be undef */ @@ -5645,7 +5777,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ Perl_warner(aTHX_ WARN_DEPRECATED, "defined(%%hash) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ @@ -5771,8 +5903,8 @@ Perl_ck_method(pTHX_ OP *o) SV* sv = kSVOP->op_sv; if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { OP *cmop; - sv_upgrade(sv, SVt_PVIV); - SvIOK_on(sv); + (void)SvUPGRADE(sv, SVt_PVIV); + (void)SvIOK_on(sv); PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv)); cmop = newSVOP(OP_METHOD_NAMED, 0, sv); kSVOP->op_sv = Nullsv; @@ -5790,6 +5922,36 @@ Perl_ck_null(pTHX_ OP *o) } OP * +Perl_ck_open(pTHX_ OP *o) +{ + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp; + I32 mode; + svp = hv_fetch(table, "open_IN", 7, FALSE); + if (svp && *svp) { + mode = mode_from_discipline(*svp); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; + } + + svp = hv_fetch(table, "open_OUT", 8, FALSE); + if (svp && *svp) { + mode = mode_from_discipline(*svp); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; + } + } + if (o->op_type == OP_BACKTICK) + return o; + return ck_fun(o); +} + +OP * Perl_ck_repeat(pTHX_ OP *o) { if (cBINOPo->op_first->op_flags & OPf_PARENS) { @@ -5816,7 +5978,13 @@ Perl_ck_require(pTHX_ OP *o) --SvCUR(kid->op_sv); } } - sv_catpvn(kid->op_sv, ".pm", 3); + if (SvREADONLY(kid->op_sv)) { + SvREADONLY_off(kid->op_sv); + sv_catpvn(kid->op_sv, ".pm", 3); + SvREADONLY_on(kid->op_sv); + } + else + sv_catpvn(kid->op_sv, ".pm", 3); } } return ck_fun(o); @@ -5884,6 +6052,7 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -5892,10 +6061,10 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -5911,6 +6080,12 @@ Perl_ck_sort(pTHX_ OP *o) for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; + /* don't descend into loops */ + else if (k->op_type == OP_ENTERLOOP + || k->op_type == OP_ENTERITER) + { + k = cLOOPx(k)->op_lastop; + } } } else @@ -5919,17 +6094,26 @@ Perl_ck_sort(pTHX_ OP *o) } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return o; } @@ -6018,7 +6202,7 @@ Perl_ck_split(pTHX_ OP *o) cLISTOPo->op_last = kid; /* There was only one element previously */ } - if (kid->op_type != OP_MATCH) { + if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); @@ -6135,7 +6319,9 @@ Perl_ck_subr(pTHX_ OP *o) proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o2); + bad_type(arg, + arg == 1 ? "block or sub {}" : "sub {}", + gv_ename(namegv), o2); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -6183,8 +6369,8 @@ Perl_ck_subr(pTHX_ OP *o) bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o2); + if (o2->op_type != OP_ENTERSUB) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV @@ -6301,26 +6487,32 @@ Perl_peep(pTHX_ register OP *o) * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[ix]); - SvPADTMP_on(cSVOPo->op_sv); - PL_curpad[ix] = cSVOPo->op_sv; + if (SvPADTMP(cSVOPo->op_sv)) { + /* If op_sv is already a PADTMP then it is being used by + * another pad, so make a copy. */ + sv_setsv(PL_curpad[ix],cSVOPo->op_sv); + SvREADONLY_on(PL_curpad[ix]); + SvREFCNT_dec(cSVOPo->op_sv); + } + else { + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + } cSVOPo->op_sv = Nullsv; o->op_targ = ix; } #endif - /* FALL THROUGH */ - case OP_UC: - case OP_UCFIRST: - case OP_LC: - case OP_LCFIRST: + o->op_seq = PL_op_seqmax++; + break; + case OP_CONCAT: - case OP_JOIN: - case OP_QUOTEMETA: 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; else { + /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; o->op_next->op_targ = 0; o->op_private |= OPpTARGET_MY; @@ -6449,7 +6641,7 @@ Perl_peep(pTHX_ register OP *o) Perl_warner(aTHX_ WARN_EXEC, "Statement unlikely to be reached"); Perl_warner(aTHX_ WARN_EXEC, - "(Maybe you meant system() when you said exec()?)\n"); + "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } }