X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=d940d104c135e8c5654fbf7428111c34aac18a48;hb=20e8a3a35e61c7fcc6a4173969d7b685e762aef7;hp=cd04198351bc9c547be90b86bf6a666185adb4f8;hpb=800401ee2a8a5a67ef478227b68426cf701d0116;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index cd04198..d940d10 100644 --- a/pp.c +++ b/pp.c @@ -172,13 +172,7 @@ PP(pp_rv2gv) const char * const name = CopSTASHPV(PL_curcop); gv = newGVgen(name); } - if (SvTYPE(sv) < SVt_RV) - sv_upgrade(sv, SVt_RV); - else if (SvPVX_const(sv)) { - SvPV_free(sv); - SvLEN_set(sv, 0); - SvCUR_set(sv, 0); - } + prepare_SV_for_RV(sv); SvRV_set(sv, (SV*)gv); SvROK_on(sv); SvSETMAGIC(sv); @@ -224,12 +218,14 @@ PP(pp_rv2gv) /* Helper function for pp_rv2sv and pp_rv2av */ GV * -Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type, - SV ***spp) +Perl_softref2xv(pTHX_ SV *const sv, const char *const what, + const svtype type, SV ***spp) { dVAR; GV *gv; + PERL_ARGS_ASSERT_SOFTREF2XV; + if (PL_op->op_private & HINT_STRICT_REFS) { if (SvOK(sv)) Perl_die(aTHX_ PL_no_symref_sv, sv, what); @@ -419,7 +415,7 @@ PP(pp_prototype) || code == -KEY_exec || code == -KEY_system) goto set; if (code == -KEY_mkdir) { - ret = sv_2mortal(newSVpvs("_;$")); + ret = newSVpvs_flags("_;$", SVs_TEMP); goto set; } if (code == -KEY_readpipe) { @@ -455,7 +451,7 @@ PP(pp_prototype) if (defgv && str[n - 1] == '$') str[n - 1] = '_'; str[n++] = '\0'; - ret = sv_2mortal(newSVpvn(str, n - 1)); + ret = newSVpvn_flags(str, n - 1, SVs_TEMP); } else if (code) /* Non-Overridable */ goto set; @@ -467,7 +463,7 @@ PP(pp_prototype) } cv = sv_2cv(TOPs, &stash, &gv, 0); if (cv && SvPOK(cv)) - ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv))); + ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP); set: SETs(ret); RETURN; @@ -515,6 +511,8 @@ S_refto(pTHX_ SV *sv) dVAR; SV* rv; + PERL_ARGS_ASSERT_REFTO; + if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { if (LvTARGLEN(sv)) vivify_defelem(sv); @@ -536,7 +534,7 @@ S_refto(pTHX_ SV *sv) SvREFCNT_inc_void_NN(sv); } rv = sv_newmortal(); - sv_upgrade(rv, SVt_RV); + sv_upgrade(rv, SVt_IV); SvRV_set(rv, sv); SvROK_on(rv); return rv; @@ -630,7 +628,7 @@ PP(pp_gelem) break; case 'N': if (strEQ(second_letter, "AME")) - sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); + sv = newSVhek(GvNAME_HEK(gv)); break; case 'P': if (strEQ(second_letter, "ACKAGE")) { @@ -1040,7 +1038,9 @@ PP(pp_pow) float_it: #endif { - dPOPTOPnnrl; + NV right = SvNV(svr); + NV left = SvNV(svl); + (void)POPs; #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG) /* @@ -1206,7 +1206,9 @@ PP(pp_multiply) } /* SvIOK(svr) */ #endif { - dPOPTOPnnrl; + NV right = SvNV(svr); + NV left = SvNV(svl); + (void)POPs; SETn( left * right ); RETURN; } @@ -1322,7 +1324,9 @@ PP(pp_divide) } /* right wasn't SvIOK */ #endif /* PERL_TRY_UV_DIVIDE */ { - dPOPPOPnnrl; + NV right = SvNV(svr); + NV left = SvNV(svl); + (void)POPs;(void)POPs; #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) if (! Perl_isnan(right) && right == 0.0) #else @@ -1362,10 +1366,9 @@ PP(pp_modulo) right = -biv; } } - sp--; } else { - dright = POPn; + dright = SvNV(svr); right_neg = dright < 0; if (right_neg) dright = -dright; @@ -1376,6 +1379,7 @@ PP(pp_modulo) use_double = TRUE; } } + sp--; /* At this point use_double is only true if right is out of range for a UV. In range NV has been rounded down to nearest UV and @@ -1396,11 +1400,10 @@ PP(pp_modulo) left = -aiv; } } - sp--; } } else { - dleft = POPn; + dleft = SvNV(svl); left_neg = dleft < 0; if (left_neg) dleft = -dleft; @@ -1428,6 +1431,7 @@ PP(pp_modulo) } } } + sp--; if (use_double) { NV dans; @@ -1699,13 +1703,15 @@ PP(pp_subtract) } #endif { - dPOPnv; + NV value = SvNV(svr); + (void)POPs; + if (!useleft) { /* left operand is undef, treat as zero - value */ SETn(-value); RETURN; } - SETn( TOPn - value ); + SETn( SvNV(svl) - value ); RETURN; } } @@ -2623,7 +2629,7 @@ PP(pp_i_modulo_1) /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ - dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -3016,25 +3022,33 @@ PP(pp_length) dVAR; dSP; dTARGET; SV * const sv = TOPs; - if (SvAMAGIC(sv)) { - /* For an overloaded scalar, we can't know in advance if it's going to - be UTF-8 or not. Also, we can't call sv_len_utf8 as it likes to - cache the length. Maybe that should be a documented feature of it. + if (SvGAMAGIC(sv)) { + /* For an overloaded or magic scalar, we can't know in advance if + it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as + it likes to cache the length. Maybe that should be a documented + feature of it. */ STRLEN len; - const char *const p = SvPV_const(sv, len); + const char *const p + = sv_2pv_flags(sv, &len, + SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC); - if (DO_UTF8(sv)) { + if (!p) + SETs(&PL_sv_undef); + else if (DO_UTF8(sv)) { SETi(utf8_length((U8*)p, (U8*)p + len)); } else SETi(len); - + } else if (SvOK(sv)) { + /* Neither magic nor overloaded. */ + if (DO_UTF8(sv)) + SETi(sv_len_utf8(sv)); + else + SETi(sv_len(sv)); + } else { + SETs(&PL_sv_undef); } - else if (DO_UTF8(sv)) - SETi(sv_len_utf8(sv)); - else - SETi(sv_len(sv)); RETURN; } @@ -3164,7 +3178,9 @@ PP(pp_substr) repl = SvPV_const(repl_sv_copy, repl_len); repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); } - sv_insert(sv, pos, rem, repl, repl_len); + if (!SvOK(sv)) + sv_setpvs(sv, ""); + sv_insert_flags(sv, pos, rem, repl, repl_len, 0); if (repl_is_utf8) SvUTF8_on(sv); if (repl_sv_copy) @@ -3183,7 +3199,7 @@ PP(pp_substr) else if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only_UTF8(sv); else - sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ + sv_setpvs(sv, ""); /* avoid lexical reincarnation */ } if (SvTYPE(TARG) < SVt_PVLV) { @@ -3310,9 +3326,8 @@ PP(pp_index) Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) will trigger magic and overloading again, as will fbm_instr() */ - big = sv_2mortal(newSVpvn(big_p, biglen)); - if (big_utf8) - SvUTF8_on(big); + big = newSVpvn_flags(big_p, biglen, + SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); big_p = SvPVX(big); } if (SvGAMAGIC(little) || (is_index && !SvOK(little))) { @@ -3324,9 +3339,8 @@ PP(pp_index) This is all getting to messy. The API isn't quite clean enough, because data access has side effects. */ - little = sv_2mortal(newSVpvn(little_p, llen)); - if (little_utf8) - SvUTF8_on(little); + little = newSVpvn_flags(little_p, llen, + SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); little_p = SvPVX(little); } @@ -3520,6 +3534,8 @@ PP(pp_ucfirst) if (SvOK(source)) { s = (const U8*)SvPV_nomg_const(source, slen); } else { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(source); s = (const U8*)""; slen = 0; } @@ -3644,6 +3660,8 @@ PP(pp_uc) if (SvOK(source)) { s = (const U8*)SvPV_nomg_const(source, len); } else { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(source); s = (const U8*)""; len = 0; } @@ -3744,6 +3762,8 @@ PP(pp_lc) if (SvOK(source)) { s = (const U8*)SvPV_nomg_const(source, len); } else { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(source); s = (const U8*)""; len = 0; } @@ -3921,6 +3941,67 @@ PP(pp_aslice) RETURN; } +PP(pp_aeach) +{ + dVAR; + dSP; + AV *array = (AV*)POPs; + const I32 gimme = GIMME_V; + IV *iterp = Perl_av_iter_p(aTHX_ array); + const IV current = (*iterp)++; + + if (current > av_len(array)) { + *iterp = 0; + if (gimme == G_SCALAR) + RETPUSHUNDEF; + else + RETURN; + } + + EXTEND(SP, 2); + mPUSHi(CopARYBASE_get(PL_curcop) + current); + if (gimme == G_ARRAY) { + SV **const element = av_fetch(array, current, 0); + PUSHs(element ? *element : &PL_sv_undef); + } + RETURN; +} + +PP(pp_akeys) +{ + dVAR; + dSP; + AV *array = (AV*)POPs; + const I32 gimme = GIMME_V; + + *Perl_av_iter_p(aTHX_ array) = 0; + + if (gimme == G_SCALAR) { + dTARGET; + PUSHi(av_len(array) + 1); + } + else if (gimme == G_ARRAY) { + IV n = Perl_av_len(aTHX_ array); + IV i = CopARYBASE_get(PL_curcop); + + EXTEND(SP, n + 1); + + if (PL_op->op_type == OP_AKEYS) { + n += i; + for (; i <= n; i++) { + mPUSHi(i); + } + } + else { + for (i = 0; i <= n; i++) { + SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); + PUSHs(elem ? *elem : &PL_sv_undef); + } + } + } + RETURN; +} + /* Associative arrays. */ PP(pp_each) @@ -4190,8 +4271,8 @@ PP(pp_anonlist) const I32 items = SP - MARK; SV * const av = (SV *) av_make(items, MARK+1); SP = ORIGMARK; /* av_make() might realloc stack_sp */ - XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL) - ? newRV_noinc(av) : av)); + mXPUSHs((PL_op->op_flags & OPf_SPECIAL) + ? newRV_noinc(av) : av); RETURN; } @@ -4210,8 +4291,8 @@ PP(pp_anonhash) (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; - XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL) - ? newRV_noinc((SV*) hv) : (SV*)hv)); + mXPUSHs((PL_op->op_flags & OPf_SPECIAL) + ? newRV_noinc((SV*) hv) : (SV*) hv); RETURN; } @@ -4593,7 +4674,7 @@ PP(pp_split) I32 base; const I32 gimme = GIMME_V; const I32 oldsave = PL_savestack_ix; - I32 make_mortal = 1; + U32 make_mortal = SVs_TEMP; bool multiline = 0; MAGIC *mg = NULL; @@ -4606,8 +4687,8 @@ PP(pp_split) DIE(aTHX_ "panic: pp_split"); rx = PM_GETRE(pm); - TAINT_IF((rx->extflags & RXf_PMf_LOCALE) && - (rx->extflags & (RXf_WHITE | RXf_SKIPWHITE))); + TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) && + (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE))); RX_MATCH_UTF8_set(rx, do_utf8); @@ -4649,12 +4730,12 @@ PP(pp_split) } base = SP - PL_stack_base; orig = s; - if (rx->extflags & RXf_SKIPWHITE) { + if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) { if (do_utf8) { while (*s == ' ' || is_utf8_space((U8*)s)) s += UTF8SKIP(s); } - else if (rx->extflags & RXf_PMf_LOCALE) { + else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) { while (isSPACE_LC(*s)) s++; } @@ -4663,13 +4744,13 @@ PP(pp_split) s++; } } - if (rx->extflags & PMf_MULTILINE) { + if (RX_EXTFLAGS(rx) & PMf_MULTILINE) { multiline = 1; } if (!limit) limit = maxiters + 2; - if (rx->extflags & RXf_WHITE) { + if (RX_EXTFLAGS(rx) & RXf_WHITE) { while (--limit) { m = s; /* this one uses 'm' and is a negative test */ @@ -4682,7 +4763,7 @@ PP(pp_split) else m += t; } - } else if (rx->extflags & RXf_PMf_LOCALE) { + } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) { while (m < strend && !isSPACE_LC(*m)) ++m; } else { @@ -4692,11 +4773,8 @@ PP(pp_split) if (m >= strend) break; - dstr = newSVpvn(s, m-s); - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); XPUSHs(dstr); /* skip the whitespace found last */ @@ -4709,7 +4787,7 @@ PP(pp_split) if (do_utf8) { while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) )) s += UTF8SKIP(s); - } else if (rx->extflags & RXf_PMf_LOCALE) { + } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) { while (s < strend && isSPACE_LC(*s)) ++s; } else { @@ -4718,23 +4796,20 @@ PP(pp_split) } } } - else if (rx->extflags & RXf_START_ONLY) { + else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) { while (--limit) { for (m = s; m < strend && *m != '\n'; m++) ; m++; if (m >= strend) break; - dstr = newSVpvn(s, m-s); - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); XPUSHs(dstr); s = m; } } - else if (rx->extflags & RXf_NULL && !(s >= strend)) { + else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) { /* Pre-extend the stack, either the number of bytes or characters in the string or a limited amount, triggered by: @@ -4754,12 +4829,8 @@ PP(pp_split) /* keep track of how many bytes we skip over */ m = s; s += UTF8SKIP(s); - dstr = newSVpvn(m, s-m); - - if (make_mortal) - sv_2mortal(dstr); + dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal); - (void)SvUTF8_on(dstr); PUSHs(dstr); if (s >= strend) @@ -4781,26 +4852,23 @@ PP(pp_split) } } } - else if (do_utf8 == ((rx->extflags & RXf_UTF8) != 0) && - (rx->extflags & RXf_USE_INTUIT) && !rx->nparens - && (rx->extflags & RXf_CHECK_ALL) - && !(rx->extflags & RXf_ANCH)) { - const int tail = (rx->extflags & RXf_INTUIT_TAIL); + else if (do_utf8 == (RX_UTF8(rx) != 0) && + (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) + && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) + && !(RX_EXTFLAGS(rx) & RXf_ANCH)) { + const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); SV * const csv = CALLREG_INTUIT_STRING(rx); - len = rx->minlenret; - if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) { + len = RX_MINLENRET(rx); + if (len == 1 && !RX_UTF8(rx) && !tail) { const char c = *SvPV_nolen_const(csv); while (--limit) { for (m = s; m < strend && *m != c; m++) ; if (m >= strend) break; - dstr = newSVpvn(s, m-s); - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); XPUSHs(dstr); /* The rx->minlen is in characters but we want to step * s ahead by bytes. */ @@ -4815,11 +4883,8 @@ PP(pp_split) (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, csv, multiline ? FBMrf_MULTILINE : 0)) ) { - dstr = newSVpvn(s, m-s); - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); XPUSHs(dstr); /* The rx->minlen is in characters but we want to step * s ahead by bytes. */ @@ -4831,7 +4896,7 @@ PP(pp_split) } } else { - maxiters += slen * rx->nparens; + maxiters += slen * RX_NPARENS(rx); while (s < strend && --limit) { I32 rex_return; @@ -4842,42 +4907,37 @@ PP(pp_split) if (rex_return == 0) break; TAINT_IF(RX_MATCH_TAINTED(rx)); - if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { + if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; - orig = rx->subbeg; + orig = RX_SUBBEG(rx); s = orig + (m - s); strend = s + (strend - m); } - m = rx->offs[0].start + orig; - dstr = newSVpvn(s, m-s); - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); + m = RX_OFFS(rx)[0].start + orig; + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); XPUSHs(dstr); - if (rx->nparens) { + if (RX_NPARENS(rx)) { I32 i; - for (i = 1; i <= (I32)rx->nparens; i++) { - s = rx->offs[i].start + orig; - m = rx->offs[i].end + orig; + for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { + s = RX_OFFS(rx)[i].start + orig; + m = RX_OFFS(rx)[i].end + orig; /* japhy (07/27/01) -- the (m && s) test doesn't catch parens that didn't match -- they should be set to undef, not the empty string */ if (m >= orig && s >= orig) { - dstr = newSVpvn(s, m-s); + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) + | make_mortal); } else dstr = &PL_sv_undef; /* undef, not "" */ - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); XPUSHs(dstr); } } - s = rx->offs[0].end + orig; + s = RX_OFFS(rx)[0].end + orig; } } @@ -4888,11 +4948,7 @@ PP(pp_split) /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { const STRLEN l = strend - s; - dstr = newSVpvn(s, l); - if (make_mortal) - sv_2mortal(dstr); - if (do_utf8) - (void)SvUTF8_on(dstr); + dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal); XPUSHs(dstr); iters++; }