X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=a16137279419338aaf81366fa9ccb6d7e47ffb5c;hb=8935ee17b2edadcfca0c196679b39cd0ade49541;hp=dd4bae9ecbe5641a669b4a54a4f2d269e960eb2b;hpb=60aeb6fd4ca923078be883926562d30b13279552;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index dd4bae9..a161372 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -47,7 +47,7 @@ static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); PP(pp_wantarray) { - djSP; + dSP; I32 cxix; EXTEND(SP, 1); @@ -80,7 +80,7 @@ PP(pp_regcreset) PP(pp_regcomp) { - djSP; + dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; SV *tmpstr; @@ -91,7 +91,7 @@ PP(pp_regcomp) if (SvROK(tmpstr)) { SV *sv = SvRV(tmpstr); if(SvMAGICAL(sv)) - mg = mg_find(sv, 'r'); + mg = mg_find(sv, PERL_MAGIC_qr); } if (mg) { regexp *re = (regexp *)mg->mg_obj; @@ -116,10 +116,15 @@ PP(pp_regcomp) pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ if (DO_UTF8(tmpstr)) pm->op_pmdynflags |= PMdf_DYN_UTF8; - else + else { pm->op_pmdynflags &= ~PMdf_DYN_UTF8; + if (pm->op_pmdynflags & PMdf_UTF8) + t = (char*)bytes_to_utf8((U8*)t, &len); + } pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); - PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed + if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) + Safefree(t); + PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } } @@ -151,7 +156,7 @@ PP(pp_regcomp) PP(pp_substcont) { - djSP; + dSP; register PMOP *pm = (PMOP*) cLOGOP->op_other; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register SV *dstr = cx->sb_dstr; @@ -159,7 +164,7 @@ PP(pp_substcont) register char *m = cx->sb_m; char *orig = cx->sb_orig; register REGEXP *rx = cx->sb_rx; - + rxres_restore(&cx->sb_rxres, rx); if (cx->sb_iters++) { @@ -221,10 +226,10 @@ PP(pp_substcont) MAGIC *mg; I32 i; if (SvTYPE(sv) < SVt_PVMG) - SvUPGRADE(sv, SVt_PVMG); - if (!(mg = mg_find(sv, 'g'))) { - sv_magic(sv, Nullsv, 'g', Nullch, 0); - mg = mg_find(sv, 'g'); + (void)SvUPGRADE(sv, SVt_PVMG); + if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { + sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(sv, PERL_MAGIC_regex_global); } i = m - orig; if (DO_UTF8(sv)) @@ -299,7 +304,7 @@ Perl_rxres_free(pTHX_ void **rsp) PP(pp_formline) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register SV *tmpForm = *++MARK; register U16 *fpc; register char *t; @@ -307,18 +312,18 @@ PP(pp_formline) register char *s; register char *send; register I32 arg; - register SV *sv; - char *item; - I32 itemsize; - I32 fieldsize; + register SV *sv = Nullsv; + char *item = Nullch; + I32 itemsize = 0; + I32 fieldsize = 0; I32 lines = 0; bool chopspace = (strchr(PL_chopset, ' ') != Nullch); - char *chophere; - char *linemark; + char *chophere = Nullch; + char *linemark = Nullch; NV value; - bool gotsome; + bool gotsome = FALSE; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1; + STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1; bool item_is_utf = FALSE; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { @@ -368,7 +373,7 @@ PP(pp_formline) PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); else PerlIO_printf(Perl_debug_log, "%-16s\n", name); - } ) + } ); switch (*fpc++) { case FF_LINEMARK: linemark = t; @@ -545,8 +550,14 @@ PP(pp_formline) s = item; if (item_is_utf) { while (arg--) { - if (*s & 0x80) { - switch (UTF8SKIP(s)) { + if (UTF8_IS_CONTINUED(*s)) { + STRLEN skip = UTF8SKIP(s); + switch (skip) { + default: + Move(s,t,skip,char); + s += skip; + t += skip; + break; case 7: *t++ = *s++; case 6: *t++ = *s++; case 5: *t++ = *s++; @@ -745,7 +756,7 @@ PP(pp_formline) PP(pp_grepstart) { - djSP; + dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -782,7 +793,7 @@ PP(pp_mapstart) PP(pp_mapwhile) { - djSP; + dSP; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; @@ -870,13 +881,13 @@ PP(pp_mapwhile) PP(pp_sort) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register SV **up; SV **myorigmark = ORIGMARK; register I32 max; HV *stash; GV *gv; - CV *cv; + CV *cv = 0; I32 gimme = GIMME; OP* nextop = PL_op->op_next; I32 overloading = 0; @@ -1020,7 +1031,7 @@ PP(pp_sort) ? ( (PL_op->op_private & OPpSORT_INTEGER) ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) : ( overloading ? amagic_ncmp : sv_ncmp)) - : ( (PL_op->op_private & OPpLOCALE) + : ( IN_LOCALE_RUNTIME ? ( overloading ? amagic_cmp_locale : sv_cmp_locale_static) @@ -1055,7 +1066,7 @@ PP(pp_range) PP(pp_flip) { - djSP; + dSP; if (GIMME == G_ARRAY) { RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); @@ -1068,7 +1079,7 @@ PP(pp_flip) if (PL_op->op_private & OPpFLIP_LINENUM) { struct io *gp_io; flip = PL_last_in_gv - && (gp_io = GvIOp(PL_last_in_gv)) + && (gp_io = GvIO(PL_last_in_gv)) && SvIV(sv) == (IV)IoLINES(gp_io); } else { flip = SvTRUE(sv); @@ -1094,7 +1105,7 @@ PP(pp_flip) PP(pp_flop) { - djSP; + dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; @@ -1149,7 +1160,8 @@ PP(pp_flop) SV *targ = PAD_SV(cUNOP->op_first->op_targ); sv_inc(targ); if ((PL_op->op_private & OPpFLIP_LINENUM) - ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) + ? (GvIO(PL_last_in_gv) + && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) : SvTRUE(sv) ) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); sv_catpv(targ, "E0"); @@ -1240,6 +1252,20 @@ Perl_block_gimme(pTHX) } } +I32 +Perl_is_lvalue_sub(pTHX) +{ + I32 cxix; + + cxix = dopoptosub(cxstack_ix); + assert(cxix >= 0); /* We should only be called from inside subs */ + + if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) + return cxstack[cxix].blk_sub.lval; + else + return 0; +} + STATIC I32 S_dopoptosub(pTHX_ I32 startingblock) { @@ -1361,41 +1387,6 @@ Perl_dounwind(pTHX_ I32 cxix) } } -/* - * Closures mentioned at top level of eval cannot be referenced - * again, and their presence indirectly causes a memory leak. - * (Note that the fact that compcv and friends are still set here - * is, AFAIK, an accident.) --Chip - * - * XXX need to get comppad et al from eval's cv rather than - * relying on the incidental global values. - */ -STATIC void -S_free_closures(pTHX) -{ - SV **svp = AvARRAY(PL_comppad_name); - I32 ix; - for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) { - SV *sv = svp[ix]; - if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') { - SvREFCNT_dec(sv); - svp[ix] = &PL_sv_undef; - - sv = PL_curpad[ix]; - if (CvCLONE(sv)) { - SvREFCNT_dec(CvOUTSIDE(sv)); - CvOUTSIDE(sv) = Nullcv; - } - else { - SvREFCNT_dec(sv); - sv = NEWSV(0,0); - SvPADTMP_on(sv); - PL_curpad[ix] = sv; - } - } - } -} - void Perl_qerror(pTHX_ SV *err) { @@ -1443,10 +1434,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) } else { sv_setpvn(ERRSV, message, msglen); - if (PL_hints & HINT_UTF8) - SvUTF8_on(ERRSV); - else - SvUTF8_off(ERRSV); } } else @@ -1515,7 +1502,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) PP(pp_xor) { - djSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1524,7 +1511,7 @@ PP(pp_xor) PP(pp_andassign) { - djSP; + dSP; if (!SvTRUE(TOPs)) RETURN; else @@ -1533,7 +1520,7 @@ PP(pp_andassign) PP(pp_orassign) { - djSP; + dSP; if (SvTRUE(TOPs)) RETURN; else @@ -1542,7 +1529,7 @@ PP(pp_orassign) PP(pp_caller) { - djSP; + dSP; register I32 cxix = dopoptosub(cxstack_ix); register PERL_CONTEXT *cx; register PERL_CONTEXT *ccstack = cxstack; @@ -1685,7 +1672,7 @@ PP(pp_caller) PP(pp_reset) { - djSP; + dSP; char *tmps; STRLEN n_a; @@ -1712,7 +1699,7 @@ PP(pp_dbstate) if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { - djSP; + dSP; register CV *cv; register PERL_CONTEXT *cx; I32 gimme = G_ARRAY; @@ -1724,7 +1711,8 @@ PP(pp_dbstate) if (!cv) DIE(aTHX_ "No DB::DB routine defined"); - if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */ + if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) + /* don't do recursive DB::DB call */ return NORMAL; ENTER; @@ -1756,7 +1744,7 @@ PP(pp_scope) PP(pp_enteriter) { - djSP; dMARK; + dSP; dMARK; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; @@ -1835,7 +1823,7 @@ PP(pp_enteriter) PP(pp_enterloop) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -1851,7 +1839,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1891,7 +1879,7 @@ PP(pp_leaveloop) PP(pp_return) { - djSP; dMARK; + dSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; @@ -1931,8 +1919,6 @@ PP(pp_return) POPEVAL(cx); if (CxTRYBLOCK(cx)) break; - if (AvFILLp(PL_comppad_name) >= 0) - free_closures(); lex_end(); if (optype == OP_REQUIRE && (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) @@ -2002,7 +1988,7 @@ PP(pp_return) PP(pp_last) { - djSP; + dSP; I32 cxix; register PERL_CONTEXT *cx; I32 pop2 = 0; @@ -2189,7 +2175,7 @@ PP(pp_dump) PP(pp_goto) { - djSP; + dSP; OP *retop = 0; I32 ix; register PERL_CONTEXT *cx; @@ -2240,7 +2226,7 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + if (CxREALEVAL(cx)) DIE(aTHX_ "Can't goto subroutine from an eval-string"); mark = PL_stack_sp; if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { @@ -2471,6 +2457,8 @@ PP(pp_goto) if (label && *label) { OP *gotoprobe = 0; + bool leaving_eval = FALSE; + PERL_CONTEXT *last_eval_cx = 0; /* find label */ @@ -2480,8 +2468,15 @@ PP(pp_goto) cx = &cxstack[ix]; switch (CxTYPE(cx)) { case CXt_EVAL: - gotoprobe = PL_eval_root; /* XXX not good for nested eval */ - break; + leaving_eval = TRUE; + if (CxREALEVAL(cx)) { + gotoprobe = (last_eval_cx ? + last_eval_cx->blk_eval.old_eval_root : + PL_eval_root); + last_eval_cx = cx; + break; + } + /* else fall through */ case CXt_LOOP: gotoprobe = cx->blk_oldcop->op_sibling; break; @@ -2519,6 +2514,17 @@ PP(pp_goto) if (!retop) DIE(aTHX_ "Can't find label %s", label); + /* if we're leaving an eval, check before we pop any frames + that we're not going to punt, otherwise the error + won't be caught */ + + if (leaving_eval && *enterops && enterops[1]) { + I32 i; + for (i = 1; enterops[i]; i++) + if (enterops[i]->op_type == OP_ENTERITER) + DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); + } + /* pop unwanted frames */ if (ix < cxstack_ix) { @@ -2566,7 +2572,7 @@ PP(pp_goto) PP(pp_exit) { - djSP; + dSP; I32 anum; if (MAXARG < 1) @@ -2587,7 +2593,7 @@ PP(pp_exit) #ifdef NOTYET PP(pp_nswitch) { - djSP; + dSP; NV value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); @@ -2606,7 +2612,7 @@ PP(pp_nswitch) PP(pp_cswitch) { - djSP; + dSP; register I32 match; if (PL_multiline) @@ -2857,7 +2863,7 @@ S_doeval(pTHX_ int gimme, OP** startop) CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); } - SAVEFREESV(PL_compcv); + SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ @@ -3005,15 +3011,15 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode) PP(pp_require) { - djSP; + dSP; register PERL_CONTEXT *cx; SV *sv; char *name; STRLEN len; - char *tryname; + char *tryname = Nullch; SV *namesv = Nullsv; SV** svp; - I32 gimme = G_SCALAR; + I32 gimme = GIMME_V; PerlIO *tryrsfp = 0; STRLEN n_a; int filter_has_file = 0; @@ -3023,19 +3029,19 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv)) { - if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ + if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */ UV rev = 0, ver = 0, sver = 0; STRLEN len; U8 *s = (U8*)SvPVX(sv); U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); if (s < end) { - rev = utf8_to_uv(s, end - s, &len, 0); + rev = utf8n_to_uvchr(s, end - s, &len, 0); s += len; if (s < end) { - ver = utf8_to_uv(s, end - s, &len, 0); + ver = utf8n_to_uvchr(s, end - s, &len, 0); s += len; if (s < end) - sver = utf8_to_uv(s, end - s, &len, 0); + sver = utf8n_to_uvchr(s, end - s, &len, 0); } } if (PERL_REVISION < rev @@ -3091,22 +3097,27 @@ PP(pp_require) /* prepare to compile file */ +#ifdef MACOS_TRADITIONAL if (PERL_FILE_IS_ABSOLUTE(name) - || (*name == '.' && (name[1] == '/' || - (name[1] == '.' && name[2] == '/')))) + || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))) { tryname = name; tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); -#ifdef MACOS_TRADITIONAL /* We consider paths of the form :a:b ambiguous and interpret them first as global then as local */ - if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':')) + if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':')) goto trylocal; } else trylocal: { #else + if (PERL_FILE_IS_ABSOLUTE(name) + || (*name == '.' && (name[1] == '/' || + (name[1] == '.' && name[2] == '/')))) + { + tryname = name; + tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } else { #endif @@ -3142,7 +3153,10 @@ trylocal: { PUSHs(dirsv); PUSHs(sv); PUTBACK; - count = call_sv(loader, G_ARRAY); + if (sv_isobject(loader)) + count = call_method("INC", G_ARRAY); + else + count = call_sv(loader, G_ARRAY); SPAGAIN; if (count > 0) { @@ -3343,7 +3357,7 @@ trylocal: { PL_eval_owner = thr; MUTEX_UNLOCK(&PL_eval_mutex); #endif /* USE_THREADS */ - return DOCATCH(doeval(G_SCALAR, NULL)); + return DOCATCH(doeval(gimme, NULL)); } PP(pp_dofile) @@ -3353,7 +3367,7 @@ PP(pp_dofile) PP(pp_entereval) { - djSP; + dSP; register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; @@ -3437,7 +3451,7 @@ PP(pp_entereval) PP(pp_leaveeval) { - djSP; + dSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -3479,9 +3493,6 @@ PP(pp_leaveeval) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - if (AvFILLp(PL_comppad_name) >= 0) - free_closures(); - #ifdef DEBUGGING assert(CvDEPTH(PL_compcv) == 1); #endif @@ -3508,7 +3519,7 @@ PP(pp_leaveeval) PP(pp_entertry) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -3518,7 +3529,6 @@ PP(pp_entertry) push_return(cLOGOP->op_other->op_next); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ PL_in_eval = EVAL_INEVAL; sv_setpv(ERRSV,""); @@ -3528,7 +3538,7 @@ PP(pp_entertry) PP(pp_leavetry) { - djSP; + dSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -3579,14 +3589,14 @@ S_doparseform(pTHX_ SV *sv) STRLEN len; register char *s = SvPV_force(sv, len); register char *send = s + len; - register char *base; + register char *base = Nullch; register I32 skipspaces = 0; - bool noblank; - bool repeat; + bool noblank = FALSE; + bool repeat = FALSE; bool postspace = FALSE; U16 *fops; register U16 *fpc; - U16 *linepc; + U16 *linepc = 0; register I32 arg; bool ischop; @@ -3765,7 +3775,7 @@ S_doparseform(pTHX_ SV *sv) } Copy(fops, s, arg, U16); Safefree(fops); - sv_magic(sv, Nullsv, 'f', Nullch, 0); + sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); SvCOMPILED_on(sv); } @@ -4374,7 +4384,7 @@ run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) } if (filter_sub && len >= 0) { - djSP; + dSP; int count; ENTER;