X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/97cb92d6c0700e9454bd4ae6d4ab867918bf7861..91e83b736b8e78a0acc723337e6e9a57ac548ef5:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 74a5450..0260a87 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -153,7 +153,7 @@ PP(pp_regcomp) modified by get-magic), to avoid incorrectly setting the RXf_TAINTED flag with RX_TAINT_on further down. */ TAINT_set(was_tainted); -#if NO_TAINT_SUPPORT +#ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(was_tainted); #endif } @@ -696,6 +696,7 @@ PP(pp_formline) case FF_LINESNGL: /* process ^* */ chopspace = 0; + /* FALLTHROUGH */ case FF_LINEGLOB: /* process @* */ { @@ -836,13 +837,13 @@ 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); GCC_DIAG_RESTORE; - RESTORE_NUMERIC_STANDARD(); + RESTORE_LC_NUMERIC(); } t += fieldsize; break; @@ -938,7 +939,8 @@ PP(pp_grepstart) SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; - if (SvPADTMP(src) && !IS_PADGV(src)) { + if (SvPADTMP(src)) { + assert(!IS_PADGV(src)); src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); PL_tmps_floor++; } @@ -1090,7 +1092,10 @@ PP(pp_mapwhile) /* set $_ to the new source item */ src = PL_stack_base[PL_markstack_ptr[-1]]; - if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src); + 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; @@ -1180,25 +1185,33 @@ PP(pp_flop) SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { - IV i, j; - 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; - if (j > SSize_t_MAX) - Perl_croak(aTHX_ "Out of memory during list extend"); - 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); } @@ -1396,6 +1409,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) * 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)); @@ -1699,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 @@ -1843,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 */ @@ -2932,8 +2953,10 @@ PP(pp_goto) /* also pp_dump */ to freed memory as the result of undef *_. So put it in the callee’s pad, donating our refer- ence count. */ - SvREFCNT_dec(PAD_SVl(0)); - PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg); + if (arg) { + SvREFCNT_dec(PAD_SVl(0)); + PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg); + } /* GvAV(PL_defgv) might have been modified on scope exit, so restore it. */ @@ -3020,7 +3043,7 @@ PP(pp_goto) /* also pp_dump */ 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"); @@ -3075,7 +3098,7 @@ PP(pp_goto) /* also pp_dump */ 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]; @@ -3220,7 +3243,7 @@ S_docatch(pTHX_ OP *o) PL_restartop = 0; goto redo_body; } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: JMPENV_POP; PL_op = oldop; @@ -3239,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 */ @@ -3671,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; @@ -3714,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 " @@ -3727,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; @@ -3768,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; } @@ -3815,17 +3837,17 @@ PP(pp_require) 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", @@ -3833,18 +3855,24 @@ PP(pp_require) tryname = SvPVX_const(namesv); tryrsfp = NULL; - ENTER_with_name("call_INC"); - SAVETMPS; if (SvPADTMP(nsv)) { nsv = sv_newmortal(); SvSetSV_nosteal(nsv,sv); } + + ENTER_with_name("call_INC"); + SAVETMPS; EXTEND(SP, 2); PUSHMARK(SP); PUSHs(dirsv); 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 @@ -3945,7 +3973,7 @@ PP(pp_require) STRLEN dirlen; if (SvOK(dirsv)) { - dir = SvPV_const(dirsv, dirlen); + dir = SvPV_nomg_const(dirsv, dirlen); } else { dir = ""; dirlen = 0; @@ -3954,8 +3982,9 @@ PP(pp_require) 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); @@ -3987,6 +4016,9 @@ PP(pp_require) /* 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 @@ -4603,7 +4635,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) 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; @@ -4662,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. */ @@ -4715,7 +4747,7 @@ 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 SSize_t other_len = av_len(other_av) + 1; + const SSize_t other_len = av_tindex(other_av) + 1; SSize_t i; HV *hv = MUTABLE_HV(SvRV(e)); @@ -4767,7 +4799,7 @@ 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 SSize_t other_len = av_len(other_av) + 1; + const SSize_t other_len = av_tindex(other_av) + 1; SSize_t i; DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); @@ -4785,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 { SSize_t i; - const SSize_t other_len = av_len(other_av); + const SSize_t other_len = av_tindex(other_av); if (NULL == seen_this) { seen_this = newHV(); @@ -4844,7 +4876,7 @@ 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 SSize_t this_len = av_len(MUTABLE_AV(SvRV(e))); + const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); SSize_t i; for(i = 0; i <= this_len; ++i) { @@ -4861,7 +4893,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else if (!SvOK(d)) { /* undef ~~ array */ - const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e))); + const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); SSize_t i; DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); @@ -4877,7 +4909,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) sm_any_array: { SSize_t i; - const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e))); + 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) { @@ -5191,7 +5223,7 @@ S_doparseform(pTHX_ SV *sv) s++; } noblank = TRUE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case ' ': case '\t': skipspaces++; continue;