X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=3bd44fc280d36931409ea038595f33242f7b5aa6;hb=1d64a758d60d7ded97c59c753fea85d3365ca0df;hp=bd2f09aa3606f691883b92851d57de744fb33c27;hpb=12ca11f6c16e7b63e13bbf5bc251f214e8de5211;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index bd2f09a..3bd44fc 100644 --- a/op.c +++ b/op.c @@ -119,7 +119,7 @@ char *name; } croak("Can't use global %s in \"my\"",name); } - if (AvFILL(comppad_name) >= 0) { + if (dowarn && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) @@ -511,6 +511,45 @@ pad_reset() pad_reset_pending = FALSE; } +#ifdef USE_THREADS +/* find_thread_magical is not reentrant */ +PADOFFSET +find_thread_magical(name) +char *name; +{ + dTHR; + char *p; + PADOFFSET key; + SV **svp; + /* We currently only handle single character magicals */ + p = strchr(per_thread_magicals, *name); + if (!p) + return NOT_IN_PAD; + key = p - per_thread_magicals; + svp = av_fetch(thr->magicals, key, FALSE); + if (!svp) { + SV *sv = NEWSV(0, 0); + av_store(thr->magicals, key, sv); + /* + * Some magic variables used to be automagically initialised + * in gv_fetchpv. Those which are now per-thread magicals get + * initialised here instead. + */ + switch (*name) { + case ';': + sv_setpv(sv, "\034"); + break; + } + sv_magic(sv, 0, 0, name, 1); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "find_thread_magical: new SV %p for $%s%c\n", + sv, (*name < 32) ? "^" : "", + (*name < 32) ? toCTRL(*name) : *name)); + } + return key; +} +#endif /* USE_THREADS */ + /* Destructor */ void @@ -536,6 +575,11 @@ OP *o; case OP_ENTEREVAL: o->op_targ = 0; /* Was holding hints. */ break; +#ifdef USE_THREADS + case OP_SPECIFIC: + o->op_targ = 0; /* Was holding index into thr->magicals AV. */ + break; +#endif /* USE_THREADS */ default: if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst)) break; @@ -637,6 +681,7 @@ OP *o; { if (dowarn && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { + dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) @@ -697,7 +742,7 @@ OP *o; else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_SCOPE: case OP_LINESEQ: @@ -708,7 +753,7 @@ OP *o; else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; } return o; @@ -821,7 +866,7 @@ OP *o; case OP_NEXTSTATE: case OP_DBSTATE: - curcop = ((COP*)o); /* for warning below */ + WITH_THR(curcop = ((COP*)o)); /* for warning below */ break; case OP_CONST: @@ -860,7 +905,7 @@ OP *o; case OP_NULL: if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - curcop = ((COP*)o); /* for warning below */ + WITH_THR(curcop = ((COP*)o)); /* for warning below */ if (o->op_flags & OPf_STACKED) break; /* FALL THROUGH */ @@ -957,7 +1002,7 @@ OP *o; else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_SCOPE: case OP_LINESEQ: @@ -967,7 +1012,7 @@ OP *o; else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_REQUIRE: /* all requires must return a boolean value */ @@ -989,6 +1034,7 @@ OP *o; o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { + dTHR; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -1034,6 +1080,7 @@ I32 type; switch (o->op_type) { case OP_UNDEF: + modcount++; return o; case OP_CONST: if (!(o->op_private & (OPpCONST_ARYBASE))) @@ -1107,6 +1154,8 @@ I32 type; case OP_RV2AV: case OP_RV2HV: + if (!type && cUNOPo->op_first->op_type != OP_GV) + croak("Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { modcount = 10000; return o; /* Treat \(@foo) like ordinary list. */ @@ -1128,7 +1177,7 @@ I32 type; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) - croak("Can't localize a reference"); + croak("Can't localize through a reference"); ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_GV: @@ -1153,6 +1202,16 @@ I32 type; SvPV(*av_fetch(comppad_name, o->op_targ, 4), na)); break; +#ifdef USE_THREADS + case OP_SPECIFIC: + modcount++; /* XXX ??? */ +#if 0 + if (!type) + croak("Can't localize thread-specific variable"); +#endif + break; +#endif /* USE_THREADS */ + case OP_PUSHMARK: break; @@ -1283,7 +1342,7 @@ I32 type; switch (o->op_type) { case OP_ENTERSUB: - if ((type == OP_DEFINED) && + if ((type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = ppaddr[OP_RV2CV]; @@ -1309,6 +1368,10 @@ I32 type; } break; + case OP_SPECIFIC: + o->op_flags |= OPf_MOD; /* XXX ??? */ + break; + case OP_RV2AV: case OP_RV2HV: o->op_flags |= OPf_REF; @@ -1447,7 +1510,7 @@ scope(o) OP *o; { if (o) { - if (o->op_flags & OPf_PARENS || perldb || tainting) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = ppaddr[OP_LEAVE]; @@ -1534,7 +1597,7 @@ OP *o; compcv = 0; /* Register with debugger */ - if (perldb) { + if (PERLDB_INTER) { CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; @@ -1576,10 +1639,14 @@ jmaybe(o) OP *o; { if (o->op_type == OP_LIST) { - o = convert(OP_JOIN, 0, - prepend_elem(OP_LIST, - newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), - o)); + OP *o2; +#ifdef USE_THREADS + o2 = newOP(OP_SPECIFIC, 0); + o2->op_targ = find_thread_magical(";"); +#else + o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), +#endif /* USE_THREADS */ + o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; } @@ -1604,6 +1671,16 @@ register OP *o; if (!(opargs[type] & OA_FOLDCONST)) goto nope; + switch (type) { + case OP_SPRINTF: + case OP_UCFIRST: + case OP_LCFIRST: + case OP_UC: + case OP_LC: + if (o->op_private & OPpLOCALE) + goto nope; + } + if (error_count) goto nope; /* Don't try to run w/ errors */ @@ -2064,6 +2141,7 @@ OP *repl; if (o->op_type == OP_TRANS) return pmtrans(o, expr, repl); + hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; if (expr->op_type == OP_CONST) { @@ -2111,17 +2189,32 @@ OP *repl; OP *curop; if (pm->op_pmflags & PMf_EVAL) curop = 0; +#ifdef USE_THREADS + else if (repl->op_type == OP_SPECIFIC + && strchr("&`'123456789+", + per_thread_magicals[repl->op_targ])) + { + curop = 0; + } +#endif /* USE_THREADS */ else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (opargs[curop->op_type] & OA_DANGEROUS) { +#ifdef USE_THREADS + if (curop->op_type == OP_SPECIFIC + && strchr("&`'123456789+", curop->op_private)) { + break; + } +#else if (curop->op_type == OP_GV) { GV *gv = ((GVOP*)curop)->op_gv; if (strchr("&`'123456789+", *GvENAME(gv))) break; } +#endif /* USE_THREADS */ else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -2528,7 +2621,7 @@ OP *o; register COP *cop; Newz(1101, cop, 1, COP); - if (perldb && curcop->cop_line && curstash != debstash) { + if (PERLDB_LINE && curcop->cop_line && curstash != debstash) { cop->op_type = OP_DBSTATE; cop->op_ppaddr = ppaddr[ OP_DBSTATE ]; } @@ -2559,7 +2652,7 @@ OP *o; cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv); cop->cop_stash = curstash; - if (perldb && curstash != debstash) { + if (PERLDB_LINE && curstash != debstash) { SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); if (svp && *svp != &sv_undef && !SvIOK(*svp)) { (void)SvIOK_on(*svp); @@ -2820,7 +2913,8 @@ OP *block; if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ - if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) { + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); } @@ -2844,10 +2938,11 @@ OP *block; } OP * -newWHILEOP(flags, debuggable, loop, expr, block, cont) +newWHILEOP(flags, debuggable, loop, whileline, expr, block, cont) I32 flags; I32 debuggable; LOOP *loop; +I32 whileline; OP *expr; OP *block; OP *cont; @@ -2859,7 +2954,8 @@ OP *cont; OP *o; OP *condop; - if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) { + if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); } @@ -2869,8 +2965,14 @@ OP *cont; if (cont) next = LINKLIST(cont); - if (expr) + if (expr) { cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + if ((line_t)whileline != NOLINE) { + copline = whileline; + cont = append_elem(OP_LINESEQ, cont, + newSTATEOP(0, Nullch, Nullop)); + } + } listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); redo = LINKLIST(listop); @@ -2928,10 +3030,10 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont #endif /* CAN_PROTOTYPE */ { LOOP *loop; + OP *wop; int padoff = 0; I32 iterflags = 0; - copline = forline; if (sv) { if (sv->op_type == OP_RV2SV) { /* symbol table variable */ sv->op_type = OP_RV2GV; @@ -2958,8 +3060,9 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont assert(!loop->op_next); Renew(loop, 1, LOOP); loop->op_targ = padoff; - return newSTATEOP(0, label, newWHILEOP(flags, 1, loop, - newOP(OP_ITER, 0), block, cont)); + wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); + copline = forline; + return newSTATEOP(0, label, wop); } OP* @@ -2996,11 +3099,6 @@ CV *cv; Safefree(CvMUTEXP(cv)); CvMUTEXP(cv) = 0; } - if (CvCONDP(cv)) { - COND_DESTROY(CvCONDP(cv)); - Safefree(CvCONDP(cv)); - CvCONDP(cv) = 0; - } #endif /* USE_THREADS */ if (!CvXSUB(cv) && CvROOT(cv)) { @@ -3063,7 +3161,7 @@ CV* cv; SV** ppad; I32 ix; - PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n", + PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n", cv, (CvANON(cv) ? "ANON" : (cv == main_cv) ? "MAIN" @@ -3086,7 +3184,7 @@ CV* cv; for (ix = 1; ix <= AvFILL(pad_name); ix++) { if (SvPOK(pname[ix])) - PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%s\"%s\" %ld-%ld)\n", + PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n", ix, ppad[ix], SvFAKE(pname[ix]) ? "FAKE " : "", SvPVX(pname[ix]), @@ -3131,8 +3229,6 @@ CV* outside; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, perl_cond); - COND_INIT(CvCONDP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILEGV(cv) = CvFILEGV(proto); @@ -3373,8 +3469,6 @@ OP *block; CvOWNER(cv) = 0; New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, perl_cond); - COND_INIT(CvCONDP(cv)); #endif /* USE_THREADS */ if (ps) @@ -3393,8 +3487,8 @@ OP *block; croak(not_safe); else { /* force display of errors found but not reported */ - sv_catpv(GvSV(errgv), not_safe); - croak("%s", SvPVx(GvSV(errgv), na)); + sv_catpv(errsv, not_safe); + croak("%s", SvPV(errsv, na)); } } } @@ -3452,7 +3546,7 @@ OP *block; if (name) { char *s; - if (perldb && curstash != debstash) { + if (PERLDB_SUBLINE && curstash != debstash) { SV *sv = NEWSV(0,0); SV *tmpstr = sv_newmortal(); static GV *db_postponed; @@ -3508,10 +3602,10 @@ OP *block; av_store(endav, 0, (SV *)cv); GvCV(gv) = 0; } - else if (strEQ(s, "RESTART") && !error_count) { - if (!restartav) - restartav = newAV(); - av_push(restartav, SvREFCNT_inc(cv)); + else if (strEQ(s, "INIT") && !error_count) { + if (!initav) + initav = newAV(); + av_push(initav, SvREFCNT_inc(cv)); } } @@ -3521,21 +3615,6 @@ OP *block; return cv; } -#ifdef DEPRECATED -CV * -newXSUB(name, ix, subaddr, filename) -char *name; -I32 ix; -I32 (*subaddr)(); -char *filename; -{ - CV* cv = newXS(name, (void(*)())subaddr, filename); - CvOLDSTYLE_on(cv); - CvXSUBANY(cv).any_i32 = ix; - return cv; -} -#endif - CV * newXS(name, subaddr, filename) char *name; @@ -3580,8 +3659,6 @@ char *filename; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); - New(666, CvCONDP(cv), 1, perl_cond); - COND_INIT(CvCONDP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ CvFILEGV(cv) = gv_fetchfile(filename); @@ -3606,10 +3683,10 @@ char *filename; av_store(endav, 0, (SV *)cv); GvCV(gv) = 0; } - else if (strEQ(s, "RESTART")) { - if (!restartav) - restartav = newAV(); - av_push(restartav, (SV *)cv); + else if (strEQ(s, "INIT")) { + if (!initav) + initav = newAV(); + av_push(initav, (SV *)cv); } } else @@ -3799,6 +3876,8 @@ OP *o; o->op_ppaddr = ppaddr[OP_PADSV]; return o; } + else if (o->op_type == OP_SPECIFIC) + return o; return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -3896,7 +3975,7 @@ OP *o; 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))); + newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV))); } return ck_fun(o); } @@ -4069,7 +4148,7 @@ OP *o; else { op_free(o); if (type == OP_FTTTY) - return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE, + return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE, SVt_PVIO)); else return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv))); @@ -4220,7 +4299,13 @@ OP * ck_glob(o) OP *o; { - GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV); + GV *gv; + + if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + append_elem(OP_GLOB, o, newSVREF(newGVOP(OP_GV, 0, defgv))); + + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); if (gv && GvIMPORTED_CV(gv)) { static int glob_index; @@ -4235,10 +4320,10 @@ OP *o; append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); - return ck_subr(o); + o = newUNOP(OP_NULL, 0, ck_subr(o)); + o->op_targ = OP_GLOB; /* hint at what it used to be */ + return o; } - if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) - append_elem(OP_GLOB, o, newSVREF(newGVOP(OP_GV, 0, defgv))); gv = newGVgen("main"); gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); @@ -4649,7 +4734,7 @@ OP *o; } } o->op_private |= (hints & HINT_STRICT_REFS); - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { if (proto) { @@ -4739,7 +4824,8 @@ OP *o; prev = o2; o2 = o2->op_sibling; } - if (proto && !optional && *proto == '$') + if (proto && !optional && + (*proto && *proto != '@' && *proto != '%' && *proto != ';')) return too_few_arguments(o, gv_ename(namegv)); return o; } @@ -4864,6 +4950,24 @@ register OP* o; o->op_seq = op_seqmax++; break; + case OP_PADAV: + if (o->op_next->op_type == OP_RV2AV + && (o->op_next->op_flags && OPf_REF)) + { + null(o->op_next); + o->op_next = o->op_next->op_next; + } + break; + + case OP_PADHV: + if (o->op_next->op_type == OP_RV2HV + && (o->op_next->op_flags && OPf_REF)) + { + null(o->op_next); + o->op_next = o->op_next->op_next; + } + break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: