X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=44c2b52eb35b5a8e8da3c27224a5a42b3abeae57;hb=ba106d47906768b6e657462b9a484fe0c3a0f0d5;hp=8d432916136f3ea08b77d7e62a9168a9ff767279;hpb=e24b16f93601a2fb49f1bbf6bab19c3bfe09c0e8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 8d43291..44c2b52 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, 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. @@ -29,6 +29,7 @@ #define CALLOP this->*PL_op #else #define CALLOP *PL_op +static void *docatch_body _((va_list args)); static OP *docatch _((OP *o)); static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); @@ -41,6 +42,14 @@ static void save_lines _((AV *array, SV *sv)); static I32 sortcv _((SV *a, SV *b)); static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); static OP *doeval _((int gimme, OP** startop)); +static PerlIO *doopen_pmc _((const char *name, const char *mode)); +static I32 sv_ncmp _((SV *a, SV *b)); +static I32 sv_i_ncmp _((SV *a, SV *b)); +static I32 amagic_ncmp _((SV *a, SV *b)); +static I32 amagic_i_ncmp _((SV *a, SV *b)); +static I32 amagic_cmp _((SV *str1, SV *str2)); +static I32 amagic_cmp_locale _((SV *str1, SV *str2)); +static void free_closures _((void)); #endif PP(pp_wantarray) @@ -162,8 +171,10 @@ PP(pp_substcont) /* Are we done */ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, - s == m, Nullsv, NULL, - cx->sb_safebase ? 0 : REXEC_COPY_STR)) + s == m, cx->sb_targ, NULL, + ((cx->sb_rflags & REXEC_COPY_STR) + ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) + : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); @@ -191,16 +202,16 @@ PP(pp_substcont) RETURNOP(pm->op_next); } } - if (rx->subbase && rx->subbase != orig) { + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - cx->sb_orig = orig = rx->subbase; + cx->sb_orig = orig = rx->subbeg; s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); } - cx->sb_m = m = rx->startp[0]; + cx->sb_m = m = rx->startp[0] + orig; sv_catpvn(dstr, s, m-s); - cx->sb_s = rx->endp[0]; + cx->sb_s = rx->endp[0] + orig; cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); @@ -221,13 +232,13 @@ rxres_save(void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = (UV)rx->subbase; - rx->subbase = Nullch; + *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); + RX_MATCH_COPIED_off(rx); *p++ = rx->nparens; *p++ = (UV)rx->subbeg; - *p++ = (UV)rx->subend; + *p++ = (UV)rx->sublen; for (i = 0; i <= rx->nparens; ++i) { *p++ = (UV)rx->startp[i]; *p++ = (UV)rx->endp[i]; @@ -240,17 +251,18 @@ rxres_restore(void **rsp, REGEXP *rx) UV *p = (UV*)*rsp; U32 i; - Safefree(rx->subbase); - rx->subbase = (char*)(*p); + if (RX_MATCH_COPIED(rx)) + Safefree(rx->subbeg); + RX_MATCH_COPIED_set(rx, *p); *p++ = 0; rx->nparens = *p++; rx->subbeg = (char*)(*p++); - rx->subend = (char*)(*p++); + rx->sublen = (I32)(*p++); for (i = 0; i <= rx->nparens; ++i) { - rx->startp[i] = (char*)(*p++); - rx->endp[i] = (char*)(*p++); + rx->startp[i] = (I32)(*p++); + rx->endp[i] = (I32)(*p++); } } @@ -615,7 +627,13 @@ PP(pp_formline) break; case FF_MORE: - if (itemsize) { + s = chophere; + send = item + len; + if (chopspace) { + while (*s && isSPACE(*s) && s < send) + s++; + } + if (s < send) { arg = fieldsize - itemsize; if (arg) { fieldsize -= arg; @@ -651,7 +669,7 @@ PP(pp_grepstart) if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - XPUSHs(&PL_sv_no); + XPUSHs(sv_2mortal(newSViv(0))); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; @@ -660,12 +678,8 @@ PP(pp_grepstart) ENTER; /* enter outer scope */ SAVETMPS; -#ifdef USE_THREADS - /* SAVE_DEFSV does *not* suffice here */ - save_sptr(&THREADSV(0)); -#else - SAVESPTR(GvSV(PL_defgv)); -#endif /* USE_THREADS */ + /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ + SAVESPTR(DEFSV); ENTER; /* enter inner scope */ SAVESPTR(PL_curpm); @@ -747,6 +761,119 @@ PP(pp_mapwhile) } } +STATIC I32 +sv_ncmp (SV *a, SV *b) +{ + double nv1 = SvNV(a); + double nv2 = SvNV(b); + return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; +} +STATIC I32 +sv_i_ncmp (SV *a, SV *b) +{ + IV iv1 = SvIV(a); + IV iv2 = SvIV(b); + return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0; +} +#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \ + *svp = Nullsv; \ + if (PL_amagic_generation) { \ + if (SvAMAGIC(left)||SvAMAGIC(right))\ + *svp = amagic_call(left, \ + right, \ + CAT2(meth,_amg), \ + 0); \ + } \ + } STMT_END + +STATIC I32 +amagic_ncmp(register SV *a, register SV *b) +{ + SV *tmpsv; + tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_ncmp(a, b); +} + +STATIC I32 +amagic_i_ncmp(register SV *a, register SV *b) +{ + SV *tmpsv; + tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_i_ncmp(a, b); +} + +STATIC I32 +amagic_cmp(register SV *str1, register SV *str2) +{ + SV *tmpsv; + tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_cmp(str1, str2); +} + +STATIC I32 +amagic_cmp_locale(register SV *str1, register SV *str2) +{ + SV *tmpsv; + tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_cmp_locale(str1, str2); +} + PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -758,6 +885,7 @@ PP(pp_sort) CV *cv; I32 gimme = GIMME; OP* nextop = PL_op->op_next; + I32 overloading = 0; if (gimme != G_ARRAY) { SP = MARK; @@ -794,7 +922,7 @@ PP(pp_sort) } PL_sortcop = CvSTART(cv); SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL]; + CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; SAVESPTR(PL_curpad); PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); @@ -810,8 +938,13 @@ PP(pp_sort) /*SUPPRESS 560*/ if (*up = *++MARK) { /* Weed out nulls. */ SvTEMP_off(*up); - if (!PL_sortcop && !SvPOK(*up)) - (void)sv_2pv(*up, &PL_na); + if (!PL_sortcop && !SvPOK(*up)) { + STRLEN n_a; + if (SvAMAGIC(*up)) + overloading = 1; + else + (void)sv_2pv(*up, &n_a); + } up++; } } @@ -849,6 +982,7 @@ PP(pp_sort) qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv)); POPBLOCK(cx,PL_curpm); + PL_stack_sp = newsp; POPSTACK; CATCH_SET(oldcatch); } @@ -857,9 +991,30 @@ PP(pp_sort) if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ qsortsv(ORIGMARK+1, max, - (PL_op->op_private & OPpLOCALE) - ? FUNC_NAME_TO_PTR(sv_cmp_locale) - : FUNC_NAME_TO_PTR(sv_cmp)); + (PL_op->op_private & OPpSORT_NUMERIC) + ? ( (PL_op->op_private & OPpSORT_INTEGER) + ? ( overloading + ? FUNC_NAME_TO_PTR(amagic_i_ncmp) + : FUNC_NAME_TO_PTR(sv_i_ncmp)) + : ( overloading + ? FUNC_NAME_TO_PTR(amagic_ncmp) + : FUNC_NAME_TO_PTR(sv_ncmp))) + : ( (PL_op->op_private & OPpLOCALE) + ? ( overloading + ? FUNC_NAME_TO_PTR(amagic_cmp_locale) + : FUNC_NAME_TO_PTR(sv_cmp_locale)) + : ( overloading + ? FUNC_NAME_TO_PTR(amagic_cmp) + : FUNC_NAME_TO_PTR(sv_cmp) ))); + if (PL_op->op_private & OPpSORT_REVERSE) { + SV **p = ORIGMARK+1; + SV **q = ORIGMARK+max; + while (p < q) { + SV *tmp = *p; + *p++ = *q; + *q-- = tmp; + } + } } } LEAVE; @@ -873,7 +1028,10 @@ PP(pp_range) { if (GIMME == G_ARRAY) return cCONDOP->op_true; - return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; + if (SvTRUEx(PAD_SV(PL_op->op_targ))) + return cCONDOP->op_false; + else + return cCONDOP->op_true; } PP(pp_flip) @@ -914,33 +1072,41 @@ PP(pp_flop) if (GIMME == G_ARRAY) { dPOPPOPssrl; - register I32 i; + register I32 i, j; register SV *sv; I32 max; + if (SvGMAGICAL(left)) + mg_get(left); + if (SvGMAGICAL(right)) + mg_get(right); + if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { - if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX) + if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) croak("Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { - EXTEND_MORTAL(max - i + 1); - EXTEND(SP, max - i + 1); + j = max - i + 1; + EXTEND_MORTAL(j); + EXTEND(SP, j); } - while (i <= max) { + else + j = 0; + while (j--) { sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } else { SV *final = sv_mortalcopy(right); - STRLEN len; + STRLEN len, n_a; char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - SvPV_force(sv,PL_na); + SvPV_force(sv,n_a); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX(sv),tmps)) @@ -977,26 +1143,26 @@ dopoptolabel(char *label) for (i = cxstack_ix; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting substitution via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting subroutine via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting eval via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting pseudo-block via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || @@ -1058,7 +1224,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstk[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: @@ -1078,7 +1244,7 @@ dopoptoeval(I32 startingblock) register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: @@ -1097,26 +1263,26 @@ dopoptoloop(I32 startingblock) register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting substitution via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); break; case CXt_SUB: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting subroutine via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); break; case CXt_EVAL: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting eval via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); break; case CXt_NULL: if (ckWARN(WARN_UNSAFE)) warner(WARN_UNSAFE, "Exiting pseudo-block via %s", - op_name[PL_op->op_type]); + PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: DEBUG_l( deb("(Found loop #%ld)\n", (long)i)); @@ -1137,9 +1303,9 @@ dounwind(I32 cxix) while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", - (long) cxstack_ix, block_type[cx->cx_type])); + (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); /* Note: we don't need to restore the base context info till the end. */ - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUBST: POPSUBST(cx); continue; /* not break */ @@ -1159,10 +1325,47 @@ dounwind(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 +free_closures(void) +{ + dTHR; + 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; + } + } + } +} + OP * -die_where(char *message) +die_where(char *message, STRLEN msglen) { dSP; + STRLEN n_a; if (PL_in_eval) { I32 cxix; register PERL_CONTEXT *cx; @@ -1170,11 +1373,10 @@ die_where(char *message) SV **newsp; if (message) { - if (PL_in_eval & 4) { + if (PL_in_eval & EVAL_KEEPERR) { SV **svp; - STRLEN klen = strlen(message); - svp = hv_fetch(ERRHV, message, klen, TRUE); + svp = hv_fetch(ERRHV, message, msglen, TRUE); if (svp) { if (!SvIOK(*svp)) { static char prefix[] = "\t(in cleanup) "; @@ -1183,18 +1385,22 @@ die_where(char *message) (void)SvIOK_only(*svp); if (!SvPOK(err)) sv_setpv(err,""); - SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); + SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catpvn(err, message, klen); + sv_catpvn(err, message, msglen); + if (ckWARN(WARN_UNSAFE)) { + STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; + warner(WARN_UNSAFE, SvPVX(err)+start); + } } sv_inc(*svp); } } else - sv_setpv(ERRSV, message); + sv_setpvn(ERRSV, message, msglen); } else - message = SvPVx(ERRSV, PL_na); + message = SvPVx(ERRSV, msglen); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { dounwind(-1); @@ -1208,8 +1414,9 @@ die_where(char *message) dounwind(cxix); POPBLOCK(cx,PL_curpm); - if (cx->cx_type != CXt_EVAL) { - PerlIO_printf(PerlIO_stderr(), "panic: die %s", message); + if (CxTYPE(cx) != CXt_EVAL) { + PerlIO_write(PerlIO_stderr(), "panic: die ", 11); + PerlIO_write(PerlIO_stderr(), message, msglen); my_exit(1); } POPEVAL(cx); @@ -1221,14 +1428,25 @@ die_where(char *message) LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); } } - PerlIO_printf(PerlIO_stderr(), "%s",message); - PerlIO_flush(PerlIO_stderr()); + if (!message) + message = SvPVx(ERRSV, msglen); + { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + int e = errno; +#endif + PerlIO_write(PerlIO_stderr(), message, msglen); + (void)PerlIO_flush(PerlIO_stderr()); +#ifdef USE_SFIO + errno = e; +#endif + } my_failure_exit(); /* NOTREACHED */ return 0; @@ -1298,7 +1516,7 @@ PP(pp_caller) } cx = &ccstack[cxix]; - if (ccstack[cxix].cx_type == CXt_SUB) { + if (CxTYPE(cx) == CXt_SUB) { dbcxix = dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ @@ -1323,18 +1541,19 @@ PP(pp_caller) PUSHs(&PL_sv_undef); else PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0))); - PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); + PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), + SvCUR(GvSV(cx->blk_oldcop->cop_filegv))))); PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) RETURN; - if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */ + if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */ sv = NEWSV(49, 0); gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); PUSHs(sv_2mortal(sv)); PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); } else { - PUSHs(sv_2mortal(newSVpv("(eval)",0))); + PUSHs(sv_2mortal(newSVpvn("(eval)",6))); PUSHs(sv_2mortal(newSViv(0))); } gimme = (I32)cx->blk_gimme; @@ -1342,7 +1561,7 @@ PP(pp_caller) PUSHs(&PL_sv_undef); else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); - if (cx->cx_type == CXt_EVAL) { + if (CxTYPE(cx) == CXt_EVAL) { if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); @@ -1353,7 +1572,7 @@ PP(pp_caller) PUSHs(&PL_sv_yes); } } - else if (cx->cx_type == CXt_SUB && + else if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs && PL_curcop->cop_stash == PL_debstash) { @@ -1404,11 +1623,12 @@ PP(pp_reset) { djSP; char *tmps; + STRLEN n_a; if (MAXARG < 1) tmps = ""; else - tmps = POPp; + tmps = POPpx; sv_reset(tmps, PL_curcop->cop_stash); PUSHs(&PL_sv_yes); RETURN; @@ -1481,8 +1701,12 @@ PP(pp_enteriter) SAVETMPS; #ifdef USE_THREADS - if (PL_op->op_flags & OPf_SPECIAL) - svp = save_threadsv(PL_op->op_targ); /* per-thread variable */ + if (PL_op->op_flags & OPf_SPECIAL) { + dTHR; + svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); + } else #endif /* USE_THREADS */ if (PL_op->op_targ) { @@ -1490,9 +1714,9 @@ PP(pp_enteriter) SAVESPTR(*svp); } else { - GV *gv = (GV*)POPs; - (void)save_scalar(gv); - svp = &GvSV(gv); /* symbol table variable */ + svp = &GvSV((GV*)POPs); /* symbol table variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); } ENTER; @@ -1610,13 +1834,16 @@ PP(pp_return) dounwind(cxix); POPBLOCK(cx,newpm); - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_SUB: POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ popsub2 = TRUE; break; case CXt_EVAL: POPEVAL(cx); + if (AvFILLp(PL_comppad_name) >= 0) + free_closures(); + lex_end(); if (optype == OP_REQUIRE && (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { @@ -1698,7 +1925,7 @@ PP(pp_last) dounwind(cxix); POPBLOCK(cx,newpm); - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_LOOP: POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */ pop2 = CXt_LOOP; @@ -1860,10 +2087,12 @@ PP(pp_goto) OP *enterops[GOTO_DEPTH]; char *label; int do_dump = (PL_op->op_type == OP_DUMP); + static char must_have_label[] = "goto must have label"; label = 0; if (PL_op->op_flags & OPf_STACKED) { SV *sv = POPs; + STRLEN n_a; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { @@ -1873,6 +2102,7 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; + int arg_was_real = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -1901,10 +2131,10 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) DIE("Can't goto subroutine from an eval-string"); mark = PL_stack_sp; - if (cx->cx_type == CXt_SUB && + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; @@ -1917,7 +2147,10 @@ PP(pp_goto) SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; #endif /* USE_THREADS */ - AvREAL_off(av); + if (AvREAL(av)) { + arg_was_real = 1; + AvREAL_off(av); /* so av_clear() won't clobber elts */ + } av_clear(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ @@ -1934,7 +2167,7 @@ PP(pp_goto) Copy(AvARRAY(av), PL_stack_sp, items, SV*); PL_stack_sp += items; } - if (cx->cx_type == CXt_SUB && + if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); oldsave = PL_scopestack[PL_scopestack_ix - 1]; @@ -1943,6 +2176,7 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; if (CvXSUB(cv)) { +#ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); while (SP > mark) { @@ -1955,7 +2189,9 @@ PP(pp_goto) items); SP = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { SV **newsp; I32 gimme; @@ -1973,7 +2209,7 @@ PP(pp_goto) else { AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); - if (cx->cx_type == CXt_EVAL) { + if (CxTYPE(cx) == CXt_EVAL) { PL_in_eval = cx->blk_eval.old_in_eval; PL_eval_root = cx->blk_eval.old_eval_root; cx->cx_type = CXt_SUB; @@ -2073,7 +2309,11 @@ PP(pp_goto) } Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + /* preserve @_ nature */ + if (arg_was_real) { + AvREIFY_off(av); + AvREAL_on(av); + } while (items--) { if (*mark) SvTEMP_off(*mark); @@ -2104,12 +2344,15 @@ PP(pp_goto) RETURNOP(CvSTART(cv)); } } - else - label = SvPV(sv,PL_na); + else { + label = SvPV(sv,n_a); + if (!(do_dump || *label)) + DIE(must_have_label); + } } else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) - DIE("goto must have label"); + DIE(must_have_label); } else label = cPVOP->op_pv; @@ -2123,7 +2366,7 @@ PP(pp_goto) *enterops = 0; for (ix = cxstack_ix; ix >= 0; ix--) { cx = &cxstack[ix]; - switch (cx->cx_type) { + switch (CxTYPE(cx)) { case CXt_EVAL: gotoprobe = PL_eval_root; /* XXX not good for nested eval */ break; @@ -2204,11 +2447,6 @@ PP(pp_goto) PL_do_undump = FALSE; } - if (PL_top_env->je_prev) { - PL_restartop = retop; - JMPENV_JUMP(3); - } - RETURNOP(retop); } @@ -2259,7 +2497,8 @@ PP(pp_cswitch) if (PL_multiline) PL_op = PL_op->op_next; /* can't assume anything */ else { - match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255; + STRLEN n_a; + match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; @@ -2297,39 +2536,41 @@ save_lines(AV *array, SV *sv) } } +STATIC void * +docatch_body(va_list args) +{ + CALLRUNOPS(); + return NULL; +} + STATIC OP * docatch(OP *o) { dTHR; int ret; OP *oldop = PL_op; - dJMPENV; - PL_op = o; #ifdef DEBUGGING assert(CATCH_GET == TRUE); - DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env)); #endif - JMPENV_PUSH(ret); + PL_op = o; + redo_body: + CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body)); switch (ret) { - default: /* topmost level handles it */ - JMPENV_POP; - PL_op = oldop; - JMPENV_JUMP(ret); - /* NOTREACHED */ + case 0: + break; case 3: - if (!PL_restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - break; + if (PL_restartop) { + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; } - PL_op = PL_restartop; - PL_restartop = 0; /* FALL THROUGH */ - case 0: - CALLRUNOPS(); - break; + default: + PL_op = oldop; + JMPENV_JUMP(ret); + /* NOTREACHED */ } - JMPENV_POP; PL_op = oldop; return Nullop; } @@ -2389,7 +2630,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) POPEVAL(cx); (*startop)->op_type = OP_NULL; - (*startop)->op_ppaddr = ppaddr[OP_NULL]; + (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); *avp = (AV*)SvREFCNT_inc(PL_comppad); LEAVE; @@ -2412,7 +2653,7 @@ doeval(int gimme, OP** startop) AV* comppadlist; I32 i; - PL_in_eval = 1; + PL_in_eval = EVAL_INEVAL; PUSHMARK(SP); @@ -2427,11 +2668,11 @@ doeval(int gimme, OP** startop) SAVEI32(PL_max_intro_pending); caller = PL_compcv; - for (i = cxstack_ix; i >= 0; i--) { + for (i = cxstack_ix - 1; i >= 0; i--) { PERL_CONTEXT *cx = &cxstack[i]; - if (cx->cx_type == CXt_EVAL) + if (CxTYPE(cx) == CXt_EVAL) break; - else if (cx->cx_type == CXt_SUB) { + else if (CxTYPE(cx) == CXt_SUB) { caller = cx->blk_sub.cv; break; } @@ -2440,7 +2681,7 @@ doeval(int gimme, OP** startop) SAVESPTR(PL_compcv); PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); - CvUNIQUE_on(PL_compcv); + CvEVAL_on(PL_compcv); #ifdef USE_THREADS CvOWNER(PL_compcv) = 0; New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); @@ -2455,7 +2696,7 @@ doeval(int gimme, OP** startop) PL_min_intro_pending = 0; PL_padix = 0; #ifdef USE_THREADS - av_store(PL_comppad_name, 0, newSVpv("@_", 2)); + av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); PL_curpad[0] = (SV*)newAV(); SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ #endif /* USE_THREADS */ @@ -2489,9 +2730,9 @@ doeval(int gimme, OP** startop) PL_curcop = &PL_compiling; PL_curcop->cop_arybase = 0; SvREFCNT_dec(PL_rs); - PL_rs = newSVpv("\n", 1); + PL_rs = newSVpvn("\n", 1); if (saveop && saveop->op_flags & OPf_SPECIAL) - PL_in_eval |= 4; + PL_in_eval |= EVAL_KEEPERR; else sv_setpv(ERRSV,""); if (yyparse() || PL_error_count || !PL_eval_root) { @@ -2499,6 +2740,7 @@ doeval(int gimme, OP** startop) I32 gimme; PERL_CONTEXT *cx; I32 optype = 0; /* Might be reset by POPEVAL. */ + STRLEN n_a; PL_op = saveop; if (PL_eval_root) { @@ -2514,10 +2756,10 @@ doeval(int gimme, OP** startop) lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } else if (startop) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2578,6 +2820,38 @@ doeval(int gimme, OP** startop) RETURNOP(PL_eval_start); } +STATIC PerlIO * +doopen_pmc(const char *name, const char *mode) +{ + STRLEN namelen = strlen(name); + PerlIO *fp; + + if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) { + SV *pmcsv = newSVpvf("%s%c", name, 'c'); + char *pmc = SvPV_nolen(pmcsv); + Stat_t pmstat; + Stat_t pmcstat; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { + fp = PerlIO_open(name, mode); + } + else { + if (PerlLIO_stat(name, &pmstat) < 0 || + pmstat.st_mtime < pmcstat.st_mtime) + { + fp = PerlIO_open(pmc, mode); + } + else { + fp = PerlIO_open(name, mode); + } + } + SvREFCNT_dec(pmcsv); + } + else { + fp = PerlIO_open(name, mode); + } + return fp; +} + PP(pp_require) { djSP; @@ -2590,13 +2864,14 @@ PP(pp_require) SV** svp; I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; + STRLEN n_a; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { SET_NUMERIC_STANDARD(); if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) DIE("Perl %s required--this is only version %s, stopped", - SvPV(sv,PL_na),PL_patchlevel); + SvPV(sv,n_a),PL_patchlevel); RETPUSHYES; } name = SvPV(sv, len); @@ -2627,7 +2902,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(PL_incgv); @@ -2639,7 +2914,7 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -2649,8 +2924,9 @@ PP(pp_require) #else sv_setpvf(namesv, "%s/%s", dir, name); #endif + TAINT_PROPER("require"); tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -2664,23 +2940,28 @@ PP(pp_require) SvREFCNT_dec(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { - SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name)); - SV *dirmsgsv = NEWSV(0, 0); - AV *ar = GvAVn(PL_incgv); - I32 i; - if (instr(SvPVX(msg), ".h ")) - sv_catpv(msg, " (change .h to .ph maybe?)"); - if (instr(SvPVX(msg), ".ph ")) - sv_catpv(msg, " (did you run h2ph?)"); - sv_catpv(msg, " (@INC contains:"); - for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); - sv_setpvf(dirmsgsv, " %s", dir); - sv_catsv(msg, dirmsgsv); + char *msgstr = name; + if (namesv) { /* did we lookup @INC? */ + SV *msg = sv_2mortal(newSVpv(msgstr,0)); + SV *dirmsgsv = NEWSV(0, 0); + AV *ar = GvAVn(PL_incgv); + I32 i; + sv_catpvn(msg, " in @INC", 8); + if (instr(SvPVX(msg), ".h ")) + sv_catpv(msg, " (change .h to .ph maybe?)"); + if (instr(SvPVX(msg), ".ph ")) + sv_catpv(msg, " (did you run h2ph?)"); + sv_catpv(msg, " (@INC contains:"); + for (i = 0; i <= AvFILL(ar); i++) { + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); + sv_setpvf(dirmsgsv, " %s", dir); + sv_catsv(msg, dirmsgsv); + } + sv_catpvn(msg, ")", 1); + SvREFCNT_dec(dirmsgsv); + msgstr = SvPV_nolen(msg); } - sv_catpvn(msg, ")", 1); - SvREFCNT_dec(dirmsgsv); - DIE("%_", msg); + DIE("Can't locate %s", msgstr); } RETPUSHUNDEF; @@ -2694,11 +2975,9 @@ PP(pp_require) ENTER; SAVETMPS; - lex_start(sv_2mortal(newSVpv("",0))); - if (PL_rsfp_filters){ - save_aptr(&PL_rsfp_filters); - PL_rsfp_filters = NULL; - } + lex_start(sv_2mortal(newSVpvn("",0))); + SAVEGENERICSV(PL_rsfp_filters); + PL_rsfp_filters = Nullav; PL_rsfp = tryrsfp; name = savepv(name); @@ -2777,7 +3056,7 @@ PP(pp_entereval) } push_return(PL_op->op_next); - PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); PUSHEVAL(cx, 0, PL_compiling.cop_filegv); /* prepare to compile string */ @@ -2844,35 +3123,8 @@ PP(pp_leaveeval) } PL_curpm = newpm; /* Don't pop $1 et al till now */ - /* - * 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 - */ - if (AvFILLp(PL_comppad_name) >= 0) { - 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; - } - } - } - } + if (AvFILLp(PL_comppad_name) >= 0) + free_closures(); #ifdef DEBUGGING assert(CvDEPTH(PL_compcv) == 1); @@ -2912,7 +3164,7 @@ PP(pp_entertry) PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ - PL_in_eval = 1; + PL_in_eval = EVAL_INEVAL; sv_setpv(ERRSV,""); PUTBACK; return DOCATCH(PL_op->op_next); @@ -3339,10 +3591,7 @@ STATIC void #ifdef PERL_OBJECT qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare) #else -qsortsv( - SV ** array, - size_t num_elts, - I32 (*compare)(SV *a, SV *b)) +qsortsv(SV ** array, size_t num_elts, I32 (*compare)(SV *a, SV *b)) #endif { register SV * temp;