X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a577af66bcfd9e2196e6de9a29cda9fd20b50841..91e83b736b8e78a0acc723337e6e9a57ac548ef5:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 27113c0..0260a87 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -83,7 +83,7 @@ PP(pp_regcomp) REGEXP *re = NULL; REGEXP *new_re; const regexp_engine *eng; - bool is_bare_re; + bool is_bare_re= FALSE; if (PL_op->op_flags & OPf_STACKED) { dMARK; @@ -107,14 +107,27 @@ PP(pp_regcomp) assert (re != (REGEXP*) &PL_sv_undef); eng = re ? RX_ENGINE(re) : current_re_engine(); + /* + In the below logic: these are basically the same - check if this regcomp is part of a split. + + (PL_op->op_pmflags & PMf_split ) + (PL_op->op_next->op_type == OP_PUSHRE) + + We could add a new mask for this and copy the PMf_split, if we did + some bit definition fiddling first. + + For now we leave this + */ + new_re = (eng->op_comp ? eng->op_comp : &Perl_re_op_compile )(aTHX_ args, nargs, pm->op_code_list, eng, re, &is_bare_re, - (pm->op_pmflags & RXf_PMf_COMPILETIME), + (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK), pm->op_pmflags | (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); + if (pm->op_pmflags & PMf_HAS_CV) ReANY(new_re)->qr_anoncv = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); @@ -129,7 +142,7 @@ PP(pp_regcomp) some day. */ if (pm->op_type == OP_MATCH) { SV *lhs; - const bool was_tainted = PL_tainted; + const bool was_tainted = TAINT_get; if (pm->op_flags & OPf_STACKED) lhs = args[-1]; else if (pm->op_private & OPpTARGET_MY) @@ -138,24 +151,27 @@ PP(pp_regcomp) SvGETMAGIC(lhs); /* Restore the previous value of PL_tainted (which may have been modified by get-magic), to avoid incorrectly setting the - RXf_TAINTED flag further down. */ - PL_tainted = was_tainted; + RXf_TAINTED flag with RX_TAINT_on further down. */ + TAINT_set(was_tainted); +#ifdef NO_TAINT_SUPPORT + PERL_UNUSED_VAR(was_tainted); +#endif } tmp = reg_temp_copy(NULL, new_re); ReREFCNT_dec(new_re); new_re = tmp; } + if (re != new_re) { ReREFCNT_dec(re); PM_SETRE(pm, new_re); } -#ifndef INCOMPLETE_TAINTS - if (PL_tainting && PL_tainted) { + + if (TAINTING_get && TAINT_get) { SvTAINTED_on((SV*)new_re); - RX_EXTFLAGS(new_re) |= RXf_TAINTED; + RX_TAINT_on(new_re); } -#endif #if !defined(USE_ITHREADS) /* can't change the optree at runtime either */ @@ -196,7 +212,6 @@ PP(pp_substcont) } rxres_restore(&cx->sb_rxres, rx); - RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ)); if (cx->sb_iters++) { const I32 saviters = cx->sb_iters; @@ -209,14 +224,10 @@ PP(pp_substcont) if (SvTAINTED(TOPs)) cx->sb_rxtainted |= SUBST_TAINT_REPL; sv_catsv_nomg(dstr, POPs); - /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ - s -= RX_GOFS(rx); - - /* Are we done */ if (CxONCE(cx) || s < orig || - !CALLREGEXEC(rx, s, cx->sb_strend, orig, - (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, - (REXEC_IGNOREPOS|REXEC_NOT_FIRST))) + !CALLREGEXEC(rx, s, cx->sb_strend, orig, + (s == m), cx->sb_targ, NULL, + (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW))) { SV *targ = cx->sb_targ; @@ -237,12 +248,9 @@ PP(pp_substcont) targ = dstr; } else { - if (SvIsCOW(targ)) { - sv_force_normal_flags(targ, SV_COW_DROP_PV); - } else - { - SvPV_free(targ); - } + SV_CHECK_THINKFIRST_COW_DROP(targ); + if (isGV(targ)) Perl_croak_no_modify(); + SvPV_free(targ); SvPV_set(targ, SvPVX(dstr)); SvCUR_set(targ, SvCUR(dstr)); SvLEN_set(targ, SvLEN(dstr)); @@ -259,7 +267,7 @@ PP(pp_substcont) /* update the taint state of various various variables in * preparation for final exit. * See "how taint works" above pp_subst() */ - if (PL_tainting) { + if (TAINTING_get) { if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) @@ -271,8 +279,10 @@ PP(pp_substcont) ) SvTAINTED_on(TOPs); /* taint return value */ /* needed for mg_set below */ - PL_tainted = cBOOL(cx->sb_rxtainted & - (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + TAINT_set( + cBOOL(cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + ); SvTAINT(TARG); } /* PL_tainted must be correctly set for this mg_set */ @@ -280,6 +290,7 @@ PP(pp_substcont) TAINT_NOT; LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); + PERL_ASYNC_CHECK(); RETURNOP(pm->op_next); assert(0); /* NOTREACHED */ } @@ -305,23 +316,18 @@ PP(pp_substcont) SV * const sv = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; MAGIC *mg; - SvUPGRADE(sv, SVt_PVMG); - if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); -#endif - mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, - NULL, 0); + if (!(mg = mg_find_mglob(sv))) { + mg = sv_magicext_mglob(sv); } - mg->mg_len = m - orig; + assert(SvPOK(dstr)); + MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig); } if (old != rx) (void)ReREFCNT_inc(rx); /* update the taint state of various various variables in preparation * for calling the code block. * See "how taint works" above pp_subst() */ - if (PL_tainting) { + if (TAINTING_get) { if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; @@ -352,7 +358,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) PERL_UNUSED_CONTEXT; if (!p || p[1] < RX_NPARENS(rx)) { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW i = 7 + (RX_NPARENS(rx)+1) * 2; #else i = 6 + (RX_NPARENS(rx)+1) * 2; @@ -369,7 +375,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) RX_MATCH_COPIED_off(rx); *p++ = RX_NPARENS(rx); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW *p++ = PTR2UV(RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = NULL; #endif @@ -398,7 +404,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) *p++ = 0; RX_NPARENS(rx) = *p++; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (RX_SAVED_COPY(rx)) SvREFCNT_dec (RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); @@ -426,14 +432,14 @@ S_rxres_free(pTHX_ void **rsp) if (p) { void *tmp = INT2PTR(char*,*p); #ifdef PERL_POISON -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW U32 i = 9 + p[1] * 2; #else U32 i = 8 + p[1] * 2; #endif #endif -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW SvREFCNT_dec (INT2PTR(SV*,p[2])); #endif #ifdef PERL_POISON @@ -460,7 +466,8 @@ PP(pp_formline) I32 arg; SV *sv = NULL; /* current item */ const char *item = NULL;/* string value of current item */ - I32 itemsize = 0; /* length of current item, possibly truncated */ + I32 itemsize = 0; /* length (chars) of item, possibly truncated */ + I32 itembytes = 0; /* as itemsize, but length in bytes */ I32 fieldsize = 0; /* width of current field */ I32 lines = 0; /* number of lines that have been output */ bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */ @@ -468,7 +475,7 @@ PP(pp_formline) STRLEN linemark = 0; /* pos of start of line in output */ NV value; bool gotsome = FALSE; /* seen at least one non-blank item on this line */ - STRLEN len; + STRLEN len; /* length of current sv */ STRLEN linemax; /* estimate of output size in bytes */ bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; @@ -528,13 +535,13 @@ PP(pp_formline) PerlIO_printf(Perl_debug_log, "%-16s\n", name); } ); switch (*fpc++) { - case FF_LINEMARK: + case FF_LINEMARK: /* start (or end) of a line */ linemark = t - SvPVX(PL_formtarget); lines++; gotsome = FALSE; break; - case FF_LITERAL: + case FF_LITERAL: /* append literal chars */ to_copy = *fpc++; source = (U8 *)f; f += to_copy; @@ -542,11 +549,11 @@ PP(pp_formline) item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv); goto append; - case FF_SKIP: + case FF_SKIP: /* skip chars in format */ f += *fpc++; break; - case FF_FETCH: + case FF_FETCH: /* get next item and set field size to */ arg = *fpc++; f += arg; fieldsize = arg; @@ -561,137 +568,91 @@ PP(pp_formline) SvTAINTED_on(PL_formtarget); break; - case FF_CHECKNL: + case FF_CHECKNL: /* find max len of item (up to \n) that fits field */ { - const char *send; const char *s = item = SvPV_const(sv, len); - itemsize = len; - if (DO_UTF8(sv)) { - itemsize = sv_len_utf8(sv); - if (itemsize != (I32)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++; - } - item_is_utf8 = TRUE; - itemsize = s - item; - sv_pos_b2u(sv, &itemsize); - break; - } - } - item_is_utf8 = FALSE; - if (itemsize > fieldsize) - itemsize = fieldsize; - send = chophere = s + itemsize; - while (s < send) { - if (*s & ~31) - gotsome = TRUE; - else if (*s == '\n') - break; - s++; - } - itemsize = s - item; + const char *send = s + len; + + itemsize = 0; + item_is_utf8 = DO_UTF8(sv); + while (s < send) { + if (!isCNTRL(*s)) + gotsome = TRUE; + else if (*s == '\n') + break; + + if (item_is_utf8) + s += UTF8SKIP(s); + else + s++; + itemsize++; + if (itemsize == fieldsize) + break; + } + itembytes = s - item; break; } - case FF_CHECKCHOP: + case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */ { const char *s = item = SvPV_const(sv, len); - itemsize = len; - if (DO_UTF8(sv)) { - itemsize = sv_len_utf8(sv); - if (itemsize != (I32)len) { - I32 itembytes; - if (itemsize <= fieldsize) { - const char *send = chophere = s + itemsize; - while (s < send) { - if (*s == '\r') { - itemsize = s - item; - chophere = s; - break; - } - if (*s++ & ~31) - gotsome = TRUE; - } - } - else { - const char *send; - 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); - } - item_is_utf8 = TRUE; - break; - } - } - item_is_utf8 = FALSE; - if (itemsize <= fieldsize) { - const char *const send = chophere = s + itemsize; - while (s < send) { - if (*s == '\r') { - itemsize = s - item; - chophere = s; - break; - } - if (*s++ & ~31) - gotsome = TRUE; - } - } - else { - const char *send; - itemsize = fieldsize; - send = chophere = s + itemsize; - 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; - } + const char *send = s + len; + I32 size = 0; + + chophere = NULL; + item_is_utf8 = DO_UTF8(sv); + while (s < send) { + /* look for a legal split position */ + if (isSPACE(*s)) { + if (*s == '\r') { + chophere = s; + itemsize = size; + break; + } + if (chopspace) { + /* provisional split point */ + chophere = s; + itemsize = size; + } + /* we delay testing fieldsize until after we've + * processed the possible split char directly + * following the last field char; so if fieldsize=3 + * and item="a b cdef", we consume "a b", not "a". + * Ditto further down. + */ + if (size == fieldsize) + break; + } + else { + if (strchr(PL_chopset, *s)) { + /* provisional split point */ + /* for a non-space split char, we include + * the split char; hence the '+1' */ + chophere = s + 1; + itemsize = size; + } + if (size == fieldsize) + break; + if (!isCNTRL(*s)) + gotsome = TRUE; + } + + if (item_is_utf8) + s += UTF8SKIP(s); + else + s++; + size++; + } + if (!chophere || s == send) { + chophere = s; + itemsize = size; + } + itembytes = chophere - item; + break; } - case FF_SPACE: + case FF_SPACE: /* append padding space (diff of field, item size) */ arg = fieldsize - itemsize; if (arg) { fieldsize -= arg; @@ -700,7 +661,7 @@ PP(pp_formline) } break; - case FF_HALFSPACE: + case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */ arg = fieldsize - itemsize; if (arg) { arg /= 2; @@ -710,34 +671,34 @@ PP(pp_formline) } break; - case FF_ITEM: - to_copy = itemsize; + case FF_ITEM: /* append a text item, while blanking ctrl chars */ + to_copy = itembytes; source = (U8 *)item; trans = 1; - if (item_is_utf8) { - /* convert to_copy from chars to bytes */ - U8 *s = source; - while (to_copy--) - s += UTF8SKIP(s); - to_copy = s - source; - } goto append; - case FF_CHOP: + case FF_CHOP: /* (for ^*) chop the current item */ { const char *s = chophere; if (chopspace) { while (isSPACE(*s)) s++; } - sv_chop(sv,s); + if (SvPOKp(sv)) + sv_chop(sv,s); + else + /* tied, overloaded or similar strangeness. + * Do it the hard way */ + sv_setpvn(sv, s, len - (s-item)); SvSETMAGIC(sv); break; } - case FF_LINESNGL: + case FF_LINESNGL: /* process ^* */ chopspace = 0; - case FF_LINEGLOB: + /* FALLTHROUGH */ + + case FF_LINEGLOB: /* process @* */ { const bool oneline = fpc[-1] == FF_LINESNGL; const char *s = item = SvPV_const(sv, len); @@ -754,7 +715,7 @@ PP(pp_formline) while (s < send) { if (*s++ == '\n') { if (oneline) { - to_copy = s - SvPVX_const(sv) - 1; + to_copy = s - item - 1; chophere = s; break; } else { @@ -821,13 +782,7 @@ PP(pp_formline) U8 *send = s + to_copy; while (s < send) { const int ch = *s; - if (trans == '~' ? (ch == '~') : -#ifdef EBCDIC - iscntrl(ch) -#else - (!(ch & ~31)) -#endif - ) + if (trans == '~' ? (ch == '~') : isCNTRL(ch)) *s = ' '; s++; } @@ -840,7 +795,7 @@ PP(pp_formline) break; } - case FF_0DECIMAL: + case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */ arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (const char *) @@ -852,7 +807,8 @@ PP(pp_formline) "%#0*.*f" : "%0*.*f"); #endif goto ff_dec; - case FF_DECIMAL: + + case FF_DECIMAL: /* do @##, ^##, where =(precision|flags) */ arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (const char *) @@ -881,22 +837,25 @@ PP(pp_formline) } /* Formats aren't yet marked for locales, so assume "yes". */ { - STORE_NUMERIC_STANDARD_SET_LOCAL(); + DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); + /* we generate fmt ourselves so it is safe */ + GCC_DIAG_IGNORE(-Wformat-nonliteral); my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value); - RESTORE_NUMERIC_STANDARD(); + GCC_DIAG_RESTORE; + RESTORE_LC_NUMERIC(); } t += fieldsize; break; - case FF_NEWLINE: + case FF_NEWLINE: /* delete trailing spaces, then append \n */ f++; while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ; t++; *t++ = '\n'; break; - case FF_BLANK: + case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */ arg = *fpc++; if (gotsome) { if (arg) { /* repeat until fields exhausted? */ @@ -910,7 +869,7 @@ PP(pp_formline) } break; - case FF_MORE: + case FF_MORE: /* replace long end of string with '...' */ { const char *s = chophere; const char *send = item + len; @@ -937,7 +896,8 @@ PP(pp_formline) } break; } - case FF_END: + + case FF_END: /* tidy up, then return */ end: assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget)); *t = '\0'; @@ -979,6 +939,11 @@ PP(pp_grepstart) SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; + if (SvPADTMP(src)) { + assert(!IS_PADGV(src)); + src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); + PL_tmps_floor++; + } SvTEMP_off(src); if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; @@ -1127,6 +1092,10 @@ PP(pp_mapwhile) /* set $_ to the new source item */ src = PL_stack_base[PL_markstack_ptr[-1]]; + if (SvPADTMP(src)) { + assert(!IS_PADGV(src)); + src = sv_mortalcopy(src); + } SvTEMP_off(src); if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; @@ -1216,21 +1185,33 @@ PP(pp_flop) SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { - IV i, j; - IV max; - if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) || - (SvOK(right) && SvNV_nomg(right) > IV_MAX)) + IV i, j, n; + if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) || + (SvOK(right) && (SvIOK(right) + ? SvIsUV(right) && SvUV(right) > IV_MAX + : SvNV_nomg(right) > IV_MAX))) DIE(aTHX_ "Range iterator outside integer range"); i = SvIV_nomg(left); - max = SvIV_nomg(right); - if (max >= i) { - j = max - i + 1; - EXTEND_MORTAL(j); - EXTEND(SP, j); + j = SvIV_nomg(right); + if (j >= i) { + /* Dance carefully around signed max. */ + bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1); + if (!overflow) { + n = j - i + 1; + /* The wraparound of signed integers is undefined + * behavior, but here we aim for count >=1, and + * negative count is just wrong. */ + if (n < 1) + overflow = TRUE; + } + if (overflow) + Perl_croak(aTHX_ "Out of memory during list extend"); + EXTEND_MORTAL(n); + EXTEND(SP, n); } else - j = 0; - while (j--) { + n = 0; + while (n--) { SV * const sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } @@ -1421,8 +1402,15 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) switch (CxTYPE(cx)) { default: continue; - case CXt_EVAL: case CXt_SUB: + /* in sub foo { /(?{...})/ }, foo ends up on the CX stack + * twice; the first for the normal foo() call, and the second + * for a faked up re-entry into the sub to execute the + * code block. Hide this faked entry from the world. */ + if (cx->cx_type & CXp_SUB_RE_FAKE) + continue; + /* FALLTHROUGH */ + case CXt_EVAL: case CXt_FORMAT: DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); return i; @@ -1636,6 +1624,11 @@ Perl_die_unwind(pTHX_ SV *msv) sv_setsv(ERRSV, exceptsv); } + if (in_eval & EVAL_KEEPERR) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + SVfARG(exceptsv)); + } + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { @@ -1694,13 +1687,8 @@ Perl_die_unwind(pTHX_ SV *msv) SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } - if (in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, - SVfARG(exceptsv)); - } - else { + if (!(in_eval & EVAL_KEEPERR)) sv_setsv(ERRSV, exceptsv); - } PL_restartjmpenv = restartjmpenv; PL_restartop = restartop; JMPENV_JUMP(3); @@ -1725,17 +1713,17 @@ PP(pp_xor) /* =for apidoc caller_cx -The XSUB-writer's equivalent of L. The +The XSUB-writer's equivalent of L. The returned C structure can be interrogated to find all the -information returned to Perl by C. Note that XSUBs don't get a +information returned to Perl by C. Note that XSUBs don't get a stack frame, so C will return information for the immediately-surrounding Perl code. This function skips over the automatic calls to C<&DB::sub> made on the -behalf of the debugger. If the stack frame requested was a sub called by +behalf of the debugger. If the stack frame requested was a sub called by C, the return value will be the frame for the call to C, since that has the correct line number/etc. for the call -site. If I is non-C, it will be set to a pointer to the +site. If I is non-C, it will be set to a pointer to the frame for the sub call itself. =cut @@ -1792,6 +1780,7 @@ PP(pp_caller) const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; + const COP *lcop; if (MAXARG) { if (has_arg) @@ -1835,7 +1824,11 @@ PP(pp_caller) PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); - mPUSHi((I32)CopLINE(cx->blk_oldcop)); + lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling, + cx->blk_sub.retop, TRUE); + if (!lcop) + lcop = cx->blk_oldcop; + mPUSHi((I32)CopLINE(lcop)); if (!has_arg) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { @@ -1864,9 +1857,16 @@ PP(pp_caller) if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { - PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), - SvCUR(cx->blk_eval.cur_text)-2, - SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); + SV *cur_text = cx->blk_eval.cur_text; + if (SvCUR(cur_text) >= 2) { + PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2, + SvUTF8(cur_text)|SVs_TEMP)); + } + else { + /* I think this is will always be "", but be sure */ + PUSHs(sv_2mortal(newSVsv(cur_text))); + } + PUSHs(&PL_sv_no); } /* require */ @@ -1888,7 +1888,7 @@ PP(pp_caller) && CopSTASH_eq(PL_curcop, PL_debstash)) { AV * const ary = cx->blk_sub.argarray; - const int off = AvARRAY(ary) - AvALLOC(ary); + const SSize_t off = AvARRAY(ary) - AvALLOC(ary); Perl_init_dbargs(aTHX); @@ -1998,8 +1998,12 @@ PP(pp_dbstate) PUSHSUB_DB(cx); cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; + if (CvDEPTH(cv) >= 2) { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(CvPADLIST(cv), CvDEPTH(cv)); + } SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); RETURNOP(CvSTART(cv)); } } @@ -2007,8 +2011,13 @@ PP(pp_dbstate) return NORMAL; } +/* SVs on the stack that have any of the flags passed in are left as is. + Other SVs are protected via the mortals stack if lvalue is true, and + copied otherwise. */ + STATIC SV ** -S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) +S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, + U32 flags, bool lvalue) { bool padtmp = 0; PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; @@ -2020,7 +2029,10 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla if (gimme == G_SCALAR) { if (MARK < SP) *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP))) - ? *SP : sv_mortalcopy(*SP); + ? *SP + : lvalue + ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) + : sv_mortalcopy(*SP); else { /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ MARK = newsp; @@ -2035,7 +2047,9 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK))) *++newsp = *MARK; else { - *++newsp = sv_mortalcopy(*MARK); + *++newsp = lvalue + ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)) + : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } } @@ -2078,7 +2092,8 @@ PP(pp_leave) gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, + PL_op->op_private & OPpLVALUE); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("block"); @@ -2240,7 +2255,8 @@ PP(pp_leaveloop) newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0); + SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0, + PL_op->op_private & OPpLVALUE); PUTBACK; POPLOOP(cx); /* Stack values are safe: release loop vars ... */ @@ -2433,8 +2449,8 @@ PP(pp_return) } break; case CXt_FORMAT: - POPFORMAT(cx); retop = cx->blk_sub.retop; + POPFORMAT(cx); break; default: DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); @@ -2523,8 +2539,8 @@ PP(pp_leavesublv) S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm); LEAVE; - cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ + cxstack_ix--; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); @@ -2581,14 +2597,12 @@ PP(pp_last) OP *nextop = NULL; SV **newsp; PMOP *newpm; - SV **mark; SV *sv = NULL; S_unwind_loop(aTHX_ "last"); POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ - mark = newsp; switch (CxTYPE(cx)) { case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: @@ -2615,8 +2629,7 @@ PP(pp_last) } TAINT_NOT; - PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme, - pop2 == CXt_SUB ? SVs_TEMP : 0); + PL_stack_sp = newsp; LEAVE; cxstack_ix--; @@ -2655,6 +2668,7 @@ PP(pp_next) if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; + PERL_ASYNC_CHECK(); return (cx)->blk_loop.my_op->op_nextop; } @@ -2678,6 +2692,7 @@ PP(pp_redo) LEAVE_SCOPE(oldsave); FREETMPS; PL_curcop = cx->blk_oldcop; + PERL_ASYNC_CHECK(); return redo_op; } @@ -2686,12 +2701,12 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac { dVAR; OP **ops = opstack; - static const char too_deep[] = "Target of goto is too deeply nested"; + static const char* const too_deep = "Target of goto is too deeply nested"; PERL_ARGS_ASSERT_DOFINDLABEL; if (ops >= oplimit) - Perl_croak(aTHX_ too_deep); + Perl_croak(aTHX_ "%s", too_deep); if (o->op_type == OP_LEAVE || o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || @@ -2700,7 +2715,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac { *ops++ = cUNOPo->op_first; if (ops >= oplimit) - Perl_croak(aTHX_ too_deep); + Perl_croak(aTHX_ "%s", too_deep); } *ops = 0; if (o->op_flags & OPf_KIDS) { @@ -2746,7 +2761,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac return 0; } -PP(pp_goto) +PP(pp_goto) /* also pp_dump */ { dVAR; dSP; OP *retop = NULL; @@ -2758,20 +2773,21 @@ PP(pp_goto) STRLEN label_len = 0; U32 label_flags = 0; const bool do_dump = (PL_op->op_type == OP_DUMP); - static const char must_have_label[] = "goto must have label"; + static const char* const must_have_label = "goto must have label"; if (PL_op->op_flags & OPf_STACKED) { + /* goto EXPR or goto &foo */ + SV * const sv = POPs; + SvGETMAGIC(sv); /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; PERL_CONTEXT *cx; CV *cv = MUTABLE_CV(SvRV(sv)); - SV** mark; - I32 items = 0; + AV *arg = GvAV(PL_defgv); I32 oldsave; - bool reified = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2798,14 +2814,18 @@ PP(pp_goto) SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't goto subroutine outside a subroutine"); - if (cxix < cxstack_ix) + if (cxix < cxstack_ix) { + if (cxix < 0) { + SvREFCNT_dec(cv); + DIE(aTHX_ "Can't goto subroutine outside a subroutine"); + } dounwind(cxix); + } TOPBLOCK(cx); SPAGAIN; /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ if (CxTYPE(cx) == CXt_EVAL) { + SvREFCNT_dec(cv); if (CxREALEVAL(cx)) /* diag_listed_as: Can't goto subroutine from an eval-%s */ DIE(aTHX_ "Can't goto subroutine from an eval-string"); @@ -2814,35 +2834,25 @@ PP(pp_goto) DIE(aTHX_ "Can't goto subroutine from an eval-block"); } else if (CxMULTICALL(cx)) + { + SvREFCNT_dec(cv); DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); + } if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { - /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; - items = AvFILLp(av) + 1; - EXTEND(SP, items+1); /* @_ could have been extended. */ - Copy(AvARRAY(av), SP + 1, items, SV*); - SvREFCNT_dec(GvAV(PL_defgv)); - GvAV(PL_defgv) = cx->blk_sub.savearray; - CLEAR_ARGARRAY(av); - /* abandon @_ if it got reified */ - if (AvREAL(av)) { - reified = 1; + /* abandon the original @_ if it got reified or if it is + the same as the current @_ */ + if (AvREAL(av) || av == arg) { SvREFCNT_dec(av); av = newAV(); - av_extend(av, items-1); AvREIFY_only(av); PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); } + else CLEAR_ARGARRAY(av); } - else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ - AV* const av = GvAV(PL_defgv); - items = AvFILLp(av) + 1; - EXTEND(SP, items+1); /* @_ could have been extended. */ - Copy(AvARRAY(av), SP + 1, items, SV*); - } - mark = SP; - SP += items; + /* We donate this refcount later to the callee’s pad. */ + SvREFCNT_inc_simple_void(arg); if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); @@ -2853,6 +2863,7 @@ PP(pp_goto) * our precious cv. See bug #99850. */ if (!CvROOT(cv) && !CvXSUB(cv)) { const GV * const gv = CvGV(cv); + SvREFCNT_dec(arg); if (gv) { SV * const tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); @@ -2867,12 +2878,43 @@ PP(pp_goto) SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { OP* const retop = cx->blk_sub.retop; - SV **newsp PERL_UNUSED_DECL; - I32 gimme PERL_UNUSED_DECL; - if (reified) { - I32 index; + SV **newsp; + I32 gimme; + const SSize_t items = arg ? AvFILL(arg) + 1 : 0; + const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0; + SV** mark; + + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + + /* put GvAV(defgv) back onto stack */ + if (items) { + EXTEND(SP, items+1); /* @_ could have been extended. */ + } + mark = SP; + if (items) { + SSize_t index; + bool r = cBOOL(AvREAL(arg)); for (index=0; indexblk_sub.savearray; + SvREFCNT_dec(arg); } /* XS subs don't have a CxSUB, so pop it */ @@ -2882,15 +2924,11 @@ PP(pp_goto) PUTBACK; (void)(*CvXSUB(cv))(aTHX_ cv); LEAVE; + PERL_ASYNC_CHECK(); return retop; } else { PADLIST * const padlist = CvPADLIST(cv); - if (CxTYPE(cx) == CXt_EVAL) { - PL_in_eval = CxOLD_IN_EVAL(cx); - PL_eval_root = cx->blk_eval.old_eval_root; - cx->cx_type = CXt_SUB; - } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); @@ -2907,41 +2945,28 @@ PP(pp_goto) PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) { - AV *const av = MUTABLE_AV(PAD_SVl(0)); - - cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); - cx->blk_sub.argarray = av; - if (items >= AvMAX(av) + 1) { - SV **ary = AvALLOC(av); - if (AvARRAY(av) != ary) { - AvMAX(av) += AvARRAY(av) - AvALLOC(av); - AvARRAY(av) = ary; - } - if (items >= AvMAX(av) + 1) { - AvMAX(av) = items - 1; - Renew(ary,items+1,SV*); - AvALLOC(av) = ary; - AvARRAY(av) = ary; - } - } - ++mark; - Copy(mark,AvARRAY(av),items,SV*); - AvFILLp(av) = items - 1; - assert(!AvREAL(av)); - if (reified) { - /* transfer 'ownership' of refcnts to new @_ */ - AvREAL_on(av); - AvREIFY_off(av); + /* cx->blk_sub.argarray has no reference count, so we + need something to hang on to our argument array so + that cx->blk_sub.argarray does not end up pointing + to freed memory as the result of undef *_. So put + it in the callee’s pad, donating our refer- + ence count. */ + if (arg) { + SvREFCNT_dec(PAD_SVl(0)); + PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg); } - while (items--) { - if (*mark) - SvTEMP_off(*mark); - mark++; + + /* GvAV(PL_defgv) might have been modified on scope + exit, so restore it. */ + if (arg != GvAV(PL_defgv)) { + AV * const av = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg); + SvREFCNT_dec(av); } } + else SvREFCNT_dec(arg); if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ Perl_get_db_sub(aTHX_ NULL, cv); if (PERLDB_GOTO) { @@ -2953,20 +2978,23 @@ PP(pp_goto) } } } + PERL_ASYNC_CHECK(); RETURNOP(CvSTART(cv)); } } else { - label = SvPV_const(sv, label_len); + /* goto EXPR */ + label = SvPV_nomg_const(sv, label_len); label_flags = SvUTF8(sv); } } else if (!(PL_op->op_flags & OPf_SPECIAL)) { + /* goto LABEL or dump LABEL */ label = cPVOP->op_pv; label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; label_len = strlen(label); } - if (!(do_dump || label_len)) DIE(aTHX_ must_have_label); + if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label); PERL_ASYNC_CHECK(); @@ -3015,7 +3043,7 @@ PP(pp_goto) gotoprobe = CvROOT(cx->blk_sub.cv); break; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case CXt_FORMAT: case CXt_NULL: DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); @@ -3044,9 +3072,8 @@ PP(pp_goto) PL_lastgotoprobe = gotoprobe; } if (!retop) - DIE(aTHX_ "Can't find label %"SVf, - SVfARG(newSVpvn_flags(label, label_len, - SVs_TEMP | label_flags))); + DIE(aTHX_ "Can't find label %"UTF8f, + UTF8fARG(label_flags, label_len, label)); /* if we're leaving an eval, check before we pop any frames that we're not going to punt, otherwise the error @@ -3071,7 +3098,7 @@ PP(pp_goto) I32 oldsave; if (ix < 0) - ix = 0; + DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); dounwind(ix); TOPBLOCK(cx); oldsave = PL_scopestack[PL_scopestack_ix]; @@ -3108,6 +3135,7 @@ PP(pp_goto) PL_do_undump = FALSE; } + PERL_ASYNC_CHECK(); RETURNOP(retop); } @@ -3125,9 +3153,11 @@ PP(pp_exit) else { anum = SvIVx(POPs); #ifdef VMS - if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) + if (anum == 1 + && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0))) anum = 0; - VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); + VMSISH_HUSHED = + VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH); #endif } PL_exit_flags |= PERL_EXIT_EXPECTED; @@ -3213,7 +3243,7 @@ S_docatch(pTHX_ OP *o) PL_restartop = 0; goto redo_body; } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: JMPENV_POP; PL_op = oldop; @@ -3232,8 +3262,8 @@ S_docatch(pTHX_ OP *o) Locate the CV corresponding to the currently executing sub or eval. If db_seqp is non_null, skip CVs that are in the DB package and populate *db_seqp with the cop sequence number at the point that the DB:: code was -entered. (allows debuggers to eval in the scope of the breakpoint rather -than in the scope of the debugger itself). +entered. (This allows debuggers to eval in the scope of the breakpoint +rather than in the scope of the debugger itself.) =cut */ @@ -3253,7 +3283,11 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) int level = 0; if (db_seqp) - *db_seqp = PL_curcop->cop_seq; + *db_seqp = + PL_curcop == &PL_compiling + ? PL_cop_seqmax + : PL_curcop->cop_seq; + for (si = PL_curstackinfo; si; si = si->si_prev) { I32 ix; for (ix = si->si_cxix; ix >= 0; ix--) { @@ -3266,6 +3300,8 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) *db_seqp = cx->blk_oldcop->cop_seq; continue; } + if (cx->cx_type & CXp_SUB_RE) + continue; } else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) cv = cx->blk_eval.cv; @@ -3273,7 +3309,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) switch (cond) { case FIND_RUNCV_padid_eq: if (!CvPADLIST(cv) - || PadlistNAMES(CvPADLIST(cv)) != (PADNAMELIST *)arg) + || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg)) continue; return cv; case FIND_RUNCV_level_eq: @@ -3345,7 +3381,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PL_in_eval = (in_require ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) - : EVAL_INEVAL); + : (EVAL_INEVAL | + ((PL_op->op_private & OPpEVAL_RE_REPARSING) + ? EVAL_RE_REPARSING : 0))); PUSHMARK(SP); @@ -3371,7 +3409,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) if (CopSTASH_ne(PL_curcop, PL_curstash)) { SAVEGENERICSV(PL_curstash); - PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop)); + PL_curstash = (HV *)CopSTASH(PL_curcop); + if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; + else SvREFCNT_inc_simple_void(PL_curstash); } /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); @@ -3407,6 +3447,15 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) else { PL_hints = saveop->op_private & OPpEVAL_COPHH ? oldcurcop->cop_hints : saveop->op_targ; + + /* making 'use re eval' not be in scope when compiling the + * qr/mabye_has_runtime_code_block/ ensures that we don't get + * infinite recursion when S_has_runtime_code() gives a false + * positive: the second time round, HINT_RE_EVAL isn't set so we + * don't bother calling S_has_runtime_code() */ + if (PL_in_eval & EVAL_RE_REPARSING) + PL_hints &= ~HINT_RE_EVAL; + if (hh) { /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ SvREFCNT_dec(GvHV(PL_hintgv)); @@ -3451,6 +3500,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PERL_CONTEXT *cx; I32 optype; /* Used by POPEVAL. */ SV *namesv; + SV *errsv = NULL; cx = NULL; namesv = NULL; @@ -3473,6 +3523,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ } + errsv = ERRSV; if (in_require) { if (!cx) { /* If cx is still NULL, it means that we didn't go in the @@ -3486,13 +3537,13 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), &PL_sv_undef, 0); Perl_croak(aTHX_ "%"SVf"Compilation failed in require", - SVfARG(ERRSV - ? ERRSV + SVfARG(errsv + ? errsv : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } else { - if (!*(SvPVx_nolen_const(ERRSV))) { - sv_setpvs(ERRSV, "Compilation error"); + if (!*(SvPV_nolen_const(errsv))) { + sv_setpvs(errsv, "Compilation error"); } } if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); @@ -3541,16 +3592,33 @@ STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) { Stat_t st; - const char *p = SvPV_nolen_const(name); - const int st_rc = PerlLIO_stat(p, &st); + STRLEN len; + const char *p = SvPV_const(name, len); + int st_rc; PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; + /* checking here captures a reasonable error message when + * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the + * user gets a confusing message about looking for the .pmc file + * rather than for the .pm file. + * This check prevents a \0 in @INC causing problems. + */ + if (!IS_SAFE_PATHNAME(p, len, "require")) + return NULL; + + /* we use the value of errno later to see how stat() or open() failed. + * We don't want it set if the stat succeeded but we still failed, + * such as if the name exists, but is a directory */ + errno = 0; + + st_rc = PerlLIO_stat(p, &st); + if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } -#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) +#if !defined(PERLIO_IS_STDIO) return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); #else return PerlIO_open(p, PERL_SCRIPT_MODE); @@ -3566,6 +3634,13 @@ S_doopen_pm(pTHX_ SV *name) PERL_ARGS_ASSERT_DOOPEN_PM; + /* check the name before trying for the .pmc name to avoid the + * warning referring to the .pmc which the user probably doesn't + * know or care about + */ + if (!IS_SAFE_PATHNAME(p, namelen, "require")) + return NULL; + if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { SV *const pmcsv = sv_newmortal(); Stat_t pmcstat; @@ -3582,6 +3657,32 @@ S_doopen_pm(pTHX_ SV *name) # define doopen_pm(name) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ +/* require doesn't search for absolute names, or when the name is + explicity relative the current directory */ +PERL_STATIC_INLINE bool +S_path_is_searchable(const char *name) +{ + PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE; + + if (PERL_FILE_IS_ABSOLUTE(name) +#ifdef WIN32 + || (*name == '.' && ((name[1] == '/' || + (name[1] == '.' && name[2] == '/')) + || (name[1] == '\\' || + ( name[1] == '.' && name[2] == '\\'))) + ) +#else + || (*name == '.' && (name[1] == '/' || + (name[1] == '.' && name[2] == '/'))) +#endif + ) + { + return FALSE; + } + else + return TRUE; +} + PP(pp_require) { dVAR; dSP; @@ -3593,9 +3694,7 @@ PP(pp_require) STRLEN unixlen; #ifdef VMS int vms_unixname = 0; - char *unixnamebuf; char *unixdir; - char *unixdirbuf; #endif const char *tryname = NULL; SV *namesv = NULL; @@ -3609,11 +3708,12 @@ PP(pp_require) SV *encoding; OP *op; int saved_errno; + bool path_searchable; sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { sv = sv_2mortal(new_version(sv)); - if (!sv_derived_from(PL_patchlevel, "version")) + if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) upg_version(PL_patchlevel, TRUE); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) @@ -3635,7 +3735,7 @@ PP(pp_require) first = SvIV(*av_fetch(lav,0,0)); if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ - || av_len(lav) > 1 /* FP with > 3 digits */ + || av_tindex(lav) > 1 /* FP with > 3 digits */ || strstr(SvPVX(pv),".0") /* FP with leading 0 */ ) { DIE(aTHX_ "Perl %"SVf" required--this is only " @@ -3648,7 +3748,7 @@ PP(pp_require) SV *hintsv; I32 second = 0; - if (av_len(lav)>=1) + if (av_tindex(lav)>=1) second = SvIV(*av_fetch(lav,1,0)); second /= second >= 600 ? 100 : 10; @@ -3671,8 +3771,15 @@ PP(pp_require) name = SvPV_const(sv, len); if (!(name && len > 0 && *name)) DIE(aTHX_ "Null filename used"); + if (!IS_SAFE_PATHNAME(name, len, "require")) { + DIE(aTHX_ "Can't locate %s: %s", + pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv), + SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), + Strerror(ENOENT)); + } TAINT_PROPER("require"); + path_searchable = path_is_searchable(name); #ifdef VMS /* The key in the %ENV hash is in the syntax of file passed as the argument @@ -3682,8 +3789,9 @@ PP(pp_require) * name can be translated to UNIX. */ - if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) - && (unixname = tounixspec(name, unixnamebuf)) != NULL) { + if ((unixname = + tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) + != NULL) { unixlen = strlen(unixname); vms_unixname = 1; } @@ -3712,33 +3820,34 @@ PP(pp_require) /* prepare to compile file */ - if (path_is_absolute(name)) { + if (!path_searchable) { /* At this point, name is SvPVX(sv) */ tryname = name; tryrsfp = doopen_pm(sv); } - if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) { + if (!tryrsfp && !(errno == EACCES && !path_searchable)) { AV * const ar = GvAVn(PL_incgv); - I32 i; + SSize_t i; #ifdef VMS if (vms_unixname) #endif { + SV *nsv = sv; namesv = newSV_type(SVt_PV); for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); - if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) - mg_get(dirsv); + SvGETMAGIC(dirsv); if (SvROK(dirsv)) { int count; SV **svp; SV *loader = dirsv; if (SvTYPE(SvRV(loader)) == SVt_PVAV - && !sv_isobject(loader)) + && !SvOBJECT(SvRV(loader))) { loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); + SvGETMAGIC(loader); } Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", @@ -3746,14 +3855,24 @@ PP(pp_require) tryname = SvPVX_const(namesv); tryrsfp = NULL; + if (SvPADTMP(nsv)) { + nsv = sv_newmortal(); + SvSetSV_nosteal(nsv,sv); + } + ENTER_with_name("call_INC"); SAVETMPS; EXTEND(SP, 2); PUSHMARK(SP); PUSHs(dirsv); - PUSHs(sv); + PUSHs(nsv); PUTBACK; + if (SvGMAGICAL(loader)) { + SV *l = sv_newmortal(); + sv_setsv_nomg(l, loader); + loader = l; + } if (sv_isobject(loader)) count = call_method("INC", G_ARRAY); else @@ -3770,7 +3889,6 @@ PP(pp_require) if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) && !isGV_with_GP(SvRV(arg))) { filter_cache = SvRV(arg); - SvREFCNT_inc_simple_void_NN(filter_cache); if (i < count) { arg = SP[i++]; @@ -3817,10 +3935,16 @@ PP(pp_require) SP--; } + /* FREETMPS may free our filter_cache */ + SvREFCNT_inc_simple_void(filter_cache); + PUTBACK; FREETMPS; LEAVE_with_name("call_INC"); + /* Now re-mortalize it. */ + sv_2mortal(filter_cache); + /* Adjust file name if the hook has set an %INC entry. This needs to happen after the FREETMPS above. */ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); @@ -3833,10 +3957,7 @@ PP(pp_require) } filter_has_file = 0; - if (filter_cache) { - SvREFCNT_dec(filter_cache); - filter_cache = NULL; - } + filter_cache = NULL; if (filter_state) { SvREFCNT_dec(filter_state); filter_state = NULL; @@ -3847,21 +3968,23 @@ PP(pp_require) } } else { - if (!path_is_absolute(name) - ) { + if (path_searchable) { const char *dir; STRLEN dirlen; if (SvOK(dirsv)) { - dir = SvPV_const(dirsv, dirlen); + dir = SvPV_nomg_const(dirsv, dirlen); } else { dir = ""; dirlen = 0; } + if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require")) + continue; #ifdef VMS - if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL) - || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL)) + if ((unixdir = + tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) + == NULL) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); @@ -3889,7 +4012,15 @@ PP(pp_require) memcpy(tmp, dir, dirlen); tmp +=dirlen; - *tmp++ = '/'; + + /* Avoid '//' */ + if (!dirlen || *(tmp-1) != '/') { + *tmp++ = '/'; + } else { + /* So SvCUR_set reports the correct length below */ + dirlen--; + } + /* name came from an SV, so it will have a '\0' at the end that we can copy as part of this memcpy(). */ memcpy(tmp, name, len + 1); @@ -3905,7 +4036,7 @@ PP(pp_require) if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') { ++tryname; - while (*++tryname == '/'); + while (*++tryname == '/') {} } break; } @@ -3932,8 +4063,8 @@ PP(pp_require) } else { if (namesv) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); - I32 i; - SV *const msg = newSVpv("", 0); + SSize_t i; + SV *const msg = newSVpvs_flags("", SVs_TEMP); SV *const inc = newSVpvs_flags("", SVs_TEMP); for (i = 0; i <= AvFILL(ar); i++) { sv_catpvs(inc, " "); @@ -3998,7 +4129,10 @@ PP(pp_require) than hanging another SV from it. In turn, filter_add() optionally takes the SV to use as the filter (or creates a new SV if passed NULL), so simply pass in whatever value filter_cache has. */ - SV * const datasv = filter_add(S_run_user_filter, filter_cache); + SV * const fc = filter_cache ? newSV(0) : NULL; + SV *datasv; + if (fc) sv_copypv(fc, filter_cache); + datasv = filter_add(S_run_user_filter, fc); IoLINES(datasv) = filter_has_file; IoTOP_GV(datasv) = MUTABLE_GV(filter_state); IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); @@ -4194,7 +4328,7 @@ PP(pp_leaveeval) TAINT_NOT; SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, - gimme, SVs_TEMP); + gimme, SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ #ifdef DEBUGGING @@ -4292,7 +4426,8 @@ PP(pp_leavetry) PERL_UNUSED_VAR(optype); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("eval_scope"); @@ -4338,7 +4473,8 @@ PP(pp_leavegiven) assert(CxTYPE(cx) == CXt_GIVEN); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("given"); @@ -4496,10 +4632,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { /* Test sub truth for each element */ - I32 i; + SSize_t i; bool andedresults = TRUE; AV *av = (AV*) SvRV(d); - const I32 len = av_len(av); + const I32 len = av_tindex(av); DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); if (len == -1) RETPUSHYES; @@ -4558,28 +4694,28 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) /* Check that the key-sets are identical */ HE *he; HV *other_hv = MUTABLE_HV(SvRV(d)); - bool tied = FALSE; - bool other_tied = FALSE; + bool tied; + bool other_tied; U32 this_key_count = 0, other_key_count = 0; HV *hv = MUTABLE_HV(SvRV(e)); DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); /* Tied hashes don't know how many keys they have. */ - if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { - tied = TRUE; - } - else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { - HV * const temp = other_hv; - other_hv = hv; - hv = temp; - tied = TRUE; + tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied)); + other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)); + if (!tied ) { + if(other_tied) { + /* swap HV sides */ + HV * const temp = other_hv; + other_hv = hv; + hv = temp; + tied = TRUE; + other_tied = FALSE; + } + else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) + RETPUSHNO; } - if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) - other_tied = TRUE; - - if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) - RETPUSHNO; /* The hashes have the same number of keys, so it suffices to check that one is a subset of the other. */ @@ -4611,8 +4747,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { AV * const other_av = MUTABLE_AV(SvRV(d)); - const I32 other_len = av_len(other_av) + 1; - I32 i; + const SSize_t other_len = av_tindex(other_av) + 1; + SSize_t i; HV *hv = MUTABLE_HV(SvRV(e)); DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); @@ -4663,8 +4799,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { AV * const other_av = MUTABLE_AV(SvRV(e)); - const I32 other_len = av_len(other_av) + 1; - I32 i; + const SSize_t other_len = av_tindex(other_av) + 1; + SSize_t i; DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); for (i = 0; i < other_len; ++i) { @@ -4681,11 +4817,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { AV *other_av = MUTABLE_AV(SvRV(d)); DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); - if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) + if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av)) RETPUSHNO; else { - I32 i; - const I32 other_len = av_len(other_av); + SSize_t i; + const SSize_t other_len = av_tindex(other_av); if (NULL == seen_this) { seen_this = newHV(); @@ -4740,8 +4876,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) sm_regex_array: { PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); - const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); - I32 i; + const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); + SSize_t i; for(i = 0; i <= this_len; ++i) { SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); @@ -4757,8 +4893,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else if (!SvOK(d)) { /* undef ~~ array */ - const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); - I32 i; + const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); + SSize_t i; DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); for (i = 0; i <= this_len; ++i) { @@ -4772,8 +4908,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) else { sm_any_array: { - I32 i; - const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + SSize_t i; + const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); for (i = 0; i <= this_len; ++i) { @@ -4916,7 +5052,8 @@ PP(pp_leavewhen) assert(CxTYPE(cx) == CXt_WHEN); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* pop $1 et al */ LEAVE_with_name("when"); @@ -4935,10 +5072,13 @@ PP(pp_leavewhen) leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; + PERL_ASYNC_CHECK(); return cx->blk_loop.my_op->op_nextop; } - else + else { + PERL_ASYNC_CHECK(); RETURNOP(cx->blk_givwhen.leave_op); + } } PP(pp_continue) @@ -5083,7 +5223,7 @@ S_doparseform(pTHX_ SV *sv) s++; } noblank = TRUE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case ' ': case '\t': skipspaces++; continue; @@ -5370,11 +5510,14 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (count > 0) { SV *out = POPs; + SvGETMAGIC(out); if (SvOK(out)) { status = SvIV(out); } - else if (SvTRUE(ERRSV)) { - err = newSVsv(ERRSV); + else { + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) + err = newSVsv(errsv); } } @@ -5383,9 +5526,13 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) LEAVE_with_name("call_filter_sub"); } + if (SvGMAGICAL(upstream)) { + mg_get(upstream); + if (upstream == buf_sv) mg_free(buf_sv); + } if (SvIsCOW(upstream)) sv_force_normal(upstream); if(!err && SvOK(upstream)) { - got_p = SvPV(upstream, got_len); + got_p = SvPV_nomg(upstream, got_len); if (umaxlen) { if (got_len > umaxlen) { prune_from = got_p + umaxlen; @@ -5416,7 +5563,12 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (SvUTF8(upstream)) { SvUTF8_on(cache); } - SvCUR_set(upstream, got_len - cached_len); + if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); + else + /* Cannot just use sv_setpvn, as that could free the buffer + before we have a chance to assign it. */ + sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), + got_len - cached_len); *prune_from = 0; /* Can't yet be EOF */ if (status == 0) @@ -5428,9 +5580,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) concatenate it then we get a warning about use of uninitialised value. */ if (!err && upstream != buf_sv && - (SvOK(upstream) || SvGMAGICAL(upstream))) { - sv_catsv(buf_sv, upstream); + SvOK(upstream)) { + sv_catsv_nomg(buf_sv, upstream); } + else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv); if (status <= 0) { IoLINES(datasv) = 0; @@ -5457,32 +5610,6 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) return status; } -/* perhaps someone can come up with a better name for - this? it is not really "absolute", per se ... */ -static bool -S_path_is_absolute(const char *name) -{ - PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; - - if (PERL_FILE_IS_ABSOLUTE(name) -#ifdef WIN32 - || (*name == '.' && ((name[1] == '/' || - (name[1] == '.' && name[2] == '/')) - || (name[1] == '\\' || - ( name[1] == '.' && name[2] == '\\'))) - ) -#else - || (*name == '.' && (name[1] == '/' || - (name[1] == '.' && name[2] == '/'))) -#endif - ) - { - return TRUE; - } - else - return FALSE; -} - /* * Local variables: * c-indentation-style: bsd