X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9d116dd7c895b17badf4ad422ae44da0c4df7bc2..c8c62db702b7e7b28e0c00febb0781eff4341baf:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 7a1ad79..621024a 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 _((void *o)); static OP *docatch _((OP *o)); static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); @@ -41,6 +42,13 @@ 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)); #endif PP(pp_wantarray) @@ -162,8 +170,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_COPY_STR|REXEC_IGNOREPOS)))) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); @@ -287,6 +297,7 @@ PP(pp_formline) double value; bool gotsome; STRLEN len; + STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { SvREADONLY_off(tmpForm); @@ -294,7 +305,7 @@ PP(pp_formline) } SvPV_force(PL_formtarget, len); - t = SvGROW(PL_formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */ + t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; f = SvPV(tmpForm, len); /* need to jump to the next word */ @@ -356,14 +367,38 @@ PP(pp_formline) sv = *++MARK; else { sv = &PL_sv_no; - if (PL_dowarn) - warn("Not enough format arguments"); + if (ckWARN(WARN_SYNTAX)) + warner(WARN_SYNTAX, "Not enough format arguments"); } break; case FF_CHECKNL: item = s = SvPV(sv, len); itemsize = len; + if (IN_UTF8) { + itemsize = sv_len_utf8(sv); + if (itemsize != len) { + I32 itembytes; + if (itemsize > fieldsize) { + itemsize = fieldsize; + itembytes = itemsize; + sv_pos_u2b(sv, &itembytes, 0); + } + else + itembytes = len; + send = chophere = s + itembytes; + while (s < send) { + if (*s & ~31) + gotsome = TRUE; + else if (*s == '\n') + break; + s++; + } + itemsize = s - item; + sv_pos_b2u(sv, &itemsize); + break; + } + } if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; @@ -380,6 +415,47 @@ PP(pp_formline) case FF_CHECKCHOP: item = s = SvPV(sv, len); itemsize = len; + if (IN_UTF8) { + itemsize = sv_len_utf8(sv); + if (itemsize != len) { + I32 itembytes; + if (itemsize <= fieldsize) { + send = chophere = s + itemsize; + while (s < send) { + if (*s == '\r') { + itemsize = s - item; + break; + } + if (*s++ & ~31) + gotsome = TRUE; + } + } + else { + itemsize = fieldsize; + itembytes = itemsize; + sv_pos_u2b(sv, &itembytes, 0); + send = chophere = s + itembytes; + while (s < send || (s == send && isSPACE(*s))) { + if (isSPACE(*s)) { + if (chopspace) + chophere = s; + if (*s == '\r') + break; + } + else { + if (*s & ~31) + gotsome = TRUE; + if (strchr(PL_chopset, *s)) + chophere = s + 1; + } + s++; + } + itemsize = chophere - item; + sv_pos_b2u(sv, &itemsize); + } + break; + } + } if (itemsize <= fieldsize) { send = chophere = s + itemsize; while (s < send) { @@ -435,6 +511,26 @@ PP(pp_formline) case FF_ITEM: arg = itemsize; s = item; + if (IN_UTF8) { + while (arg--) { + if (*s & 0x80) { + switch (UTF8SKIP(s)) { + case 7: *t++ = *s++; + case 6: *t++ = *s++; + case 5: *t++ = *s++; + case 4: *t++ = *s++; + case 3: *t++ = *s++; + case 2: *t++ = *s++; + case 1: *t++ = *s++; + } + } + else { + if ( !((*t++ = *s++) & ~31) ) + t[-1] = ' '; + } + } + break; + } while (arg--) { #ifdef EBCDIC int ch = *t++ = *s++; @@ -471,7 +567,7 @@ PP(pp_formline) } SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); sv_catpvn(PL_formtarget, item, itemsize); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + SvCUR(tmpForm) + 1); + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); } break; @@ -529,7 +625,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; @@ -574,12 +676,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); @@ -661,6 +759,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; @@ -672,6 +883,7 @@ PP(pp_sort) CV *cv; I32 gimme = GIMME; OP* nextop = PL_op->op_next; + I32 overloading = 0; if (gimme != G_ARRAY) { SP = MARK; @@ -708,7 +920,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]); @@ -724,8 +936,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++; } } @@ -763,6 +980,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); } @@ -771,9 +989,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; @@ -828,33 +1067,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)) @@ -891,22 +1138,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 (PL_dowarn) - warn("Exiting substitution via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting substitution via %s", + PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (PL_dowarn) - warn("Exiting subroutine via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting subroutine via %s", + PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (PL_dowarn) - warn("Exiting eval via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting eval via %s", + PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (PL_dowarn) - warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting pseudo-block via %s", + PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || @@ -968,7 +1219,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: @@ -988,7 +1239,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: @@ -1007,22 +1258,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 (PL_dowarn) - warn("Exiting substitution via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting substitution via %s", + PL_op_name[PL_op->op_type]); break; case CXt_SUB: - if (PL_dowarn) - warn("Exiting subroutine via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting subroutine via %s", + PL_op_name[PL_op->op_type]); break; case CXt_EVAL: - if (PL_dowarn) - warn("Exiting eval via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting eval via %s", + PL_op_name[PL_op->op_type]); break; case CXt_NULL: - if (PL_dowarn) - warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Exiting pseudo-block via %s", + PL_op_name[PL_op->op_type]); return -1; case CXt_LOOP: DEBUG_l( deb("(Found loop #%ld)\n", (long)i)); @@ -1043,9 +1298,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 */ @@ -1066,9 +1321,10 @@ dounwind(I32 cxix) } 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; @@ -1078,9 +1334,8 @@ die_where(char *message) if (message) { if (PL_in_eval & 4) { 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) "; @@ -1089,18 +1344,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); @@ -1114,8 +1373,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); @@ -1127,14 +1387,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; @@ -1204,7 +1475,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. */ @@ -1229,18 +1500,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; @@ -1248,7 +1520,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); @@ -1259,7 +1531,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) { @@ -1310,11 +1582,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; @@ -1387,8 +1660,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) { @@ -1396,9 +1673,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; @@ -1516,7 +1793,7 @@ 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; @@ -1604,7 +1881,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; @@ -1766,10 +2043,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) { @@ -1779,11 +2058,23 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; + int arg_was_real = 0; + retry: if (!CvROOT(cv) && !CvXSUB(cv)) { - if (CvGV(cv)) { - SV *tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), Nullch); + GV *gv = CvGV(cv); + GV *autogv; + if (gv) { + SV *tmpstr; + /* autoloaded stub? */ + if (cv != GvCV(gv) && (cv = GvCV(gv))) + goto retry; + autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), + GvNAMELEN(gv), FALSE); + if (autogv && (cv = GvCV(autogv))) + goto retry; + tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, Nullch); DIE("Goto undefined subroutine &%s",SvPVX(tmpstr)); } DIE("Goto undefined subroutine"); @@ -1796,10 +2087,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; @@ -1812,7 +2103,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 */ @@ -1829,7 +2123,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]; @@ -1838,6 +2132,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) { @@ -1850,7 +2145,9 @@ PP(pp_goto) items); SP = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { SV **newsp; I32 gimme; @@ -1868,7 +2165,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; @@ -1880,7 +2177,7 @@ PP(pp_goto) if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && PL_dowarn) + if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *newpad = newAV(); @@ -1968,7 +2265,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); @@ -1999,12 +2300,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; @@ -2018,7 +2322,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; @@ -2099,11 +2403,6 @@ PP(pp_goto) PL_do_undump = FALSE; } - if (PL_top_env->je_prev) { - PL_restartop = retop; - JMPENV_JUMP(3); - } - RETURNOP(retop); } @@ -2154,7 +2453,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; @@ -2192,39 +2492,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; } @@ -2275,7 +2577,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) PL_hints = 0; PL_op = &dummy; - PL_op->op_type = 0; /* Avoid uninit warning. */ + PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, 0, PL_compiling.cop_filegv); @@ -2284,10 +2586,12 @@ 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; + if (PL_curcop == &PL_compiling) + PL_compiling.op_private = PL_hints; #ifdef OP_IN_REGISTER op = PL_opsave; #endif @@ -2320,11 +2624,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; } @@ -2333,7 +2637,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); @@ -2348,7 +2652,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 */ @@ -2382,7 +2686,7 @@ 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; else @@ -2392,6 +2696,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) { @@ -2407,10 +2712,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); @@ -2471,6 +2776,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; @@ -2483,13 +2820,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); @@ -2520,7 +2858,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); @@ -2532,7 +2870,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) @@ -2542,8 +2880,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; @@ -2567,7 +2906,7 @@ PP(pp_require) 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); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); sv_setpvf(dirmsgsv, " %s", dir); sv_catsv(msg, dirmsgsv); } @@ -2578,6 +2917,8 @@ PP(pp_require) RETPUSHUNDEF; } + else + SETERRNO(0, SS$_NORMAL); /* Assume success here to prevent recursive requirement. */ (void)hv_store(GvHVn(PL_incgv), name, strlen(name), @@ -2585,17 +2926,18 @@ 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); SAVEFREEPV(name); SAVEHINTS(); PL_hints = 0; + SAVEPPTR(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL + : WARN_NONE); /* switch to eval mode */ @@ -2603,6 +2945,7 @@ PP(pp_require) PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name, PL_compiling.cop_filegv); + SAVEI16(PL_compiling.cop_line); PL_compiling.cop_line = 0; PUTBACK; @@ -2656,9 +2999,15 @@ PP(pp_entereval) SAVEDELETE(PL_defstash, safestr, strlen(safestr)); SAVEHINTS(); PL_hints = PL_op->op_targ; + SAVEPPTR(PL_compiling.cop_warnings); + if (PL_compiling.cop_warnings != WARN_ALL + && PL_compiling.cop_warnings != WARN_NONE){ + PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; + SAVEFREESV(PL_compiling.cop_warnings) ; + } 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 */