X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=078db3bfd1eeb28e465d067a7faa412088f03085;hb=c7cffa0b862541c21ec66e4efd2d80e4f0a2f142;hp=9cedc3fe47cccca88f1dd5e313601a666124a686;hpb=076a2a80a09d79b056f73d9ef04bd4d977712fce;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c old mode 100755 new mode 100644 index 9cedc3f..078db3b --- a/pp.c +++ b/pp.c @@ -576,9 +576,9 @@ PP(pp_bless) if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) Perl_croak(aTHX_ "Attempt to bless into a reference"); ptr = SvPV_const(ssv,len); - if (len == 0 && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Explicit blessing to '' (assuming package main)"); + if (len == 0) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, GV_ADD); } @@ -813,10 +813,10 @@ PP(pp_undef) hv_undef(MUTABLE_HV(sv)); break; case SVt_PVCV: - if (cv_const_sv((const CV *)sv) && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", - CvANON((const CV *)sv) ? "(anonymous)" - : GvENAME(CvGV((const CV *)sv))); + if (cv_const_sv((const CV *)sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", + CvANON((const CV *)sv) ? "(anonymous)" + : GvENAME(CvGV((const CV *)sv))); /* FALLTHROUGH */ case SVt_PVFM: { @@ -3148,8 +3148,7 @@ PP(pp_substr) if (fail < 0) { if (lvalue || repl) Perl_croak(aTHX_ "substr outside of string"); - if (ckWARN(WARN_SUBSTR)) - Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); RETPUSHUNDEF; } else { @@ -3198,9 +3197,8 @@ PP(pp_substr) if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force_nolen(sv); - if (ckWARN(WARN_SUBSTR)) - Perl_warner(aTHX_ packWARN(WARN_SUBSTR), - "Attempt to use reference as lvalue in substr"); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr"); } if (isGV_with_GP(sv)) SvPV_force_nolen(sv); @@ -4066,12 +4064,195 @@ PP(pp_each) RETURN; } -PP(pp_delete) +STATIC OP * +S_do_delete_local(pTHX) { dVAR; dSP; const I32 gimme = GIMME_V; - const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; + const MAGIC *mg; + HV *stash; + + if (PL_op->op_private & OPpSLICE) { + dMARK; dORIGMARK; + SV * const osv = POPs; + const bool tied = SvRMAGICAL(osv) + && mg_find((const SV *)osv, PERL_MAGIC_tied); + const bool can_preserve = SvCANEXISTDELETE(osv) + || mg_find((const SV *)osv, PERL_MAGIC_env); + const U32 type = SvTYPE(osv); + if (type == SVt_PVHV) { /* hash element */ + HV * const hv = MUTABLE_HV(osv); + while (++MARK <= SP) { + SV * const keysv = *MARK; + SV *sv = NULL; + bool preeminent = TRUE; + if (can_preserve) + preeminent = hv_exists_ent(hv, keysv, 0); + if (tied) { + HE *he = hv_fetch_ent(hv, keysv, 1, 0); + if (he) + sv = HeVAL(he); + else + preeminent = FALSE; + } + else { + sv = hv_delete_ent(hv, keysv, 0, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + *MARK = sv_mortalcopy(sv); + mg_clear(sv); + } else + *MARK = sv; + } + else { + SAVEHDELETE(hv, keysv); + *MARK = &PL_sv_undef; + } + } + } + else if (type == SVt_PVAV) { /* array element */ + if (PL_op->op_flags & OPf_SPECIAL) { + AV * const av = MUTABLE_AV(osv); + while (++MARK <= SP) { + I32 idx = SvIV(*MARK); + SV *sv = NULL; + bool preeminent = TRUE; + if (can_preserve) + preeminent = av_exists(av, idx); + if (tied) { + SV **svp = av_fetch(av, idx, 1); + if (svp) + sv = *svp; + else + preeminent = FALSE; + } + else { + sv = av_delete(av, idx, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + *MARK = sv_mortalcopy(sv); + mg_clear(sv); + } else + *MARK = sv; + } + else { + SAVEADELETE(av, idx); + *MARK = &PL_sv_undef; + } + } + } + } + else + DIE(aTHX_ "Not a HASH reference"); + if (gimme == G_VOID) + SP = ORIGMARK; + else if (gimme == G_SCALAR) { + MARK = ORIGMARK; + if (SP > MARK) + *++MARK = *SP; + else + *++MARK = &PL_sv_undef; + SP = MARK; + } + } + else { + SV * const keysv = POPs; + SV * const osv = POPs; + const bool tied = SvRMAGICAL(osv) + && mg_find((const SV *)osv, PERL_MAGIC_tied); + const bool can_preserve = SvCANEXISTDELETE(osv) + || mg_find((const SV *)osv, PERL_MAGIC_env); + const U32 type = SvTYPE(osv); + SV *sv = NULL; + if (type == SVt_PVHV) { + HV * const hv = MUTABLE_HV(osv); + bool preeminent = TRUE; + if (can_preserve) + preeminent = hv_exists_ent(hv, keysv, 0); + if (tied) { + HE *he = hv_fetch_ent(hv, keysv, 1, 0); + if (he) + sv = HeVAL(he); + else + preeminent = FALSE; + } + else { + sv = hv_delete_ent(hv, keysv, 0, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + SV *nsv = sv_mortalcopy(sv); + mg_clear(sv); + sv = nsv; + } + } + else + SAVEHDELETE(hv, keysv); + } + else if (type == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) { + AV * const av = MUTABLE_AV(osv); + I32 idx = SvIV(keysv); + bool preeminent = TRUE; + if (can_preserve) + preeminent = av_exists(av, idx); + if (tied) { + SV **svp = av_fetch(av, idx, 1); + if (svp) + sv = *svp; + else + preeminent = FALSE; + } + else { + sv = av_delete(av, idx, 0); + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + } + if (preeminent) { + save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); + if (tied) { + SV *nsv = sv_mortalcopy(sv); + mg_clear(sv); + sv = nsv; + } + } + else + SAVEADELETE(av, idx); + } + else + DIE(aTHX_ "panic: avhv_delete no longer supported"); + } + else + DIE(aTHX_ "Not a HASH reference"); + if (!sv) + sv = &PL_sv_undef; + if (gimme != G_VOID) + PUSHs(sv); + } + + RETURN; +} + +PP(pp_delete) +{ + dVAR; + dSP; + I32 gimme; + I32 discard; + + if (PL_op->op_private & OPpLVAL_INTRO) + return do_delete_local(); + + gimme = GIMME_V; + discard = (gimme == G_VOID) ? G_DISCARD : 0; if (PL_op->op_private & OPpSLICE) { dMARK; dORIGMARK; @@ -4201,17 +4382,11 @@ PP(pp_hslice) if (localizing) { if (HvNAME_get(hv) && isGV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); - else { - if (preeminent) - save_helem_flags(hv, keysv, svp, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); - else { - STRLEN keylen; - const char * const key = SvPV_const(keysv, keylen); - SAVEDELETE(hv, savepvn(key,keylen), - SvUTF8(keysv) ? -(I32)keylen : (I32)keylen); - } - } + else if (preeminent) + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); + else + SAVEHDELETE(hv, keysv); } } *MARK = svp ? *svp : &PL_sv_undef; @@ -4314,8 +4489,8 @@ PP(pp_anonhash) SV * const val = newSV(0); if (MARK < SP) sv_setsv(val, *++MARK); - else if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); + else + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -4375,8 +4550,7 @@ PP(pp_splice) length = AvMAX(ary) + 1; } if (offset > AvFILLp(ary) + 1) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); offset = AvFILLp(ary) + 1; } after = AvFILLp(ary) + 1 - (offset + length); @@ -4543,10 +4717,6 @@ PP(pp_push) call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; - SP = ORIGMARK; - if (GIMME_V != G_VOID) { - PUSHi( AvFILL(ary) + 1 ); - } } else { PL_delaymagic = DM_DELAY; @@ -4560,8 +4730,10 @@ PP(pp_push) mg_set(MUTABLE_SV(ary)); PL_delaymagic = 0; - SP = ORIGMARK; - PUSHi( AvFILLp(ary) + 1 ); + } + SP = ORIGMARK; + if (OP_GIMME(PL_op, 0) != G_VOID) { + PUSHi( AvFILL(ary) + 1 ); } RETURN; } @@ -4604,7 +4776,7 @@ PP(pp_unshift) } } SP = ORIGMARK; - if (GIMME_V != G_VOID) { + if (OP_GIMME(PL_op, 0) != G_VOID) { PUSHi( AvFILL(ary) + 1 ); } RETURN; @@ -4705,11 +4877,13 @@ PP(pp_split) I32 iters = 0; const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s); I32 maxiters = slen + 10; + I32 trailing_empty = 0; const char *orig; const I32 origlimit = limit; I32 realarray = 0; I32 base; const I32 gimme = GIMME_V; + const bool gimme_scalar = (GIMME_V == G_SCALAR); const I32 oldsave = PL_savestack_ix; U32 make_mortal = SVs_TEMP; bool multiline = 0; @@ -4738,8 +4912,6 @@ PP(pp_split) ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv); } #endif - else if (gimme != G_ARRAY) - ary = GvAVn(PL_defgv); else ary = NULL; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { @@ -4810,9 +4982,17 @@ PP(pp_split) if (m >= strend) break; - dstr = newSVpvn_flags(s, m-s, - (do_utf8 ? SVf_UTF8 : 0) | make_mortal); - XPUSHs(dstr); + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); + XPUSHs(dstr); + } /* skip the whitespace found last */ if (do_utf8) @@ -4840,9 +5020,18 @@ PP(pp_split) m++; if (m >= strend) break; - dstr = newSVpvn_flags(s, m-s, - (do_utf8 ? SVf_UTF8 : 0) | make_mortal); - XPUSHs(dstr); + + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); + XPUSHs(dstr); + } s = m; } } @@ -4855,34 +5044,49 @@ PP(pp_split) or split //, $str, $i; */ - const U32 items = limit - 1; - if (items < slen) - EXTEND(SP, items); - else - EXTEND(SP, slen); + if (!gimme_scalar) { + const U32 items = limit - 1; + if (items < slen) + EXTEND(SP, items); + else + EXTEND(SP, slen); + } if (do_utf8) { while (--limit) { /* keep track of how many bytes we skip over */ m = s; s += UTF8SKIP(s); - dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal); + if (gimme_scalar) { + iters++; + if (s-m == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal); - PUSHs(dstr); + PUSHs(dstr); + } if (s >= strend) break; } } else { while (--limit) { - dstr = newSVpvn(s, 1); + if (gimme_scalar) { + iters++; + } else { + dstr = newSVpvn(s, 1); - s++; - if (make_mortal) - sv_2mortal(dstr); + if (make_mortal) + sv_2mortal(dstr); - PUSHs(dstr); + PUSHs(dstr); + } + + s++; if (s >= strend) break; @@ -4904,9 +5108,17 @@ PP(pp_split) ; if (m >= strend) break; - dstr = newSVpvn_flags(s, m-s, - (do_utf8 ? SVf_UTF8 : 0) | make_mortal); - XPUSHs(dstr); + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + 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. */ if (do_utf8) @@ -4920,9 +5132,17 @@ PP(pp_split) (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, csv, multiline ? FBMrf_MULTILINE : 0)) ) { - dstr = newSVpvn_flags(s, m-s, - (do_utf8 ? SVf_UTF8 : 0) | make_mortal); - XPUSHs(dstr); + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + 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. */ if (do_utf8) @@ -4952,9 +5172,18 @@ PP(pp_split) strend = s + (strend - m); } m = RX_OFFS(rx)[0].start + orig; - dstr = newSVpvn_flags(s, m-s, - (do_utf8 ? SVf_UTF8 : 0) | make_mortal); - XPUSHs(dstr); + + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) | make_mortal); + XPUSHs(dstr); + } if (RX_NPARENS(rx)) { I32 i; for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { @@ -4964,37 +5193,54 @@ PP(pp_split) /* 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_flags(s, m-s, - (do_utf8 ? SVf_UTF8 : 0) - | make_mortal); + if (gimme_scalar) { + iters++; + if (m-s == 0) + trailing_empty++; + else + trailing_empty = 0; + } else { + if (m >= orig && s >= orig) { + dstr = newSVpvn_flags(s, m-s, + (do_utf8 ? SVf_UTF8 : 0) + | make_mortal); + } + else + dstr = &PL_sv_undef; /* undef, not "" */ + XPUSHs(dstr); } - else - dstr = &PL_sv_undef; /* undef, not "" */ - XPUSHs(dstr); + } } s = RX_OFFS(rx)[0].end + orig; } } - iters = (SP - PL_stack_base) - base; + if (!gimme_scalar) { + iters = (SP - PL_stack_base) - base; + } if (iters > maxiters) DIE(aTHX_ "Split loop"); /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { - const STRLEN l = strend - s; - dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal); - XPUSHs(dstr); + if (!gimme_scalar) { + const STRLEN l = strend - s; + dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal); + XPUSHs(dstr); + } iters++; } else if (!origlimit) { - while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { - if (TOPs && !make_mortal) - sv_2mortal(TOPs); - iters--; - *SP-- = &PL_sv_undef; + if (gimme_scalar) { + iters -= trailing_empty; + } else { + while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { + if (TOPs && !make_mortal) + sv_2mortal(TOPs); + *SP-- = &PL_sv_undef; + iters--; + } } } @@ -5079,6 +5325,24 @@ PP(unimplemented_op) PL_op->op_type); } +PP(pp_boolkeys) +{ + dVAR; + dSP; + HV * const hv = (HV*)POPs; + + if (SvRMAGICAL(hv)) { + MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied); + if (mg) { + XPUSHs(magic_scalarpack(hv, mg)); + RETURN; + } + } + + XPUSHs(boolSV(HvKEYS(hv) != 0)); + RETURN; +} + /* * Local variables: * c-indentation-style: bsd