X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=0cc80e67bb6ec40a12f84308e43db428c09f16f0;hb=9f44f717b5c2e526c60d74be999e0ad9ef069b1a;hp=f04b55d49f8c4adefe20f78cebaa41a42d731e3e;hpb=81714fb9c03d91d66b66cab6e899e81bf64a2ca7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index f04b55d..0cc80e6 100644 --- a/pp.c +++ b/pp.c @@ -1,7 +1,7 @@ /* pp.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -222,6 +222,50 @@ PP(pp_rv2gv) RETURN; } +/* Helper function for pp_rv2sv and pp_rv2av */ +GV * +Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const U32 type, + SV ***spp) +{ + dVAR; + GV *gv; + + if (PL_op->op_private & HINT_STRICT_REFS) { + if (SvOK(sv)) + Perl_die(aTHX_ PL_no_symref_sv, sv, what); + else + Perl_die(aTHX_ PL_no_usym, what); + } + if (!SvOK(sv)) { + if (PL_op->op_flags & OPf_REF) + Perl_die(aTHX_ PL_no_usym, what); + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + if (type != SVt_PV && GIMME_V == G_ARRAY) { + (*spp)--; + return NULL; + } + **spp = &PL_sv_undef; + return NULL; + } + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + gv = gv_fetchsv(sv, 0, type); + if (!gv + && (!is_gv_magical_sv(sv,0) + || !(gv = gv_fetchsv(sv, GV_ADD, type)))) + { + **spp = &PL_sv_undef; + return NULL; + } + } + else { + gv = gv_fetchsv(sv, GV_ADD, type); + } + return gv; +} + PP(pp_rv2sv) { dVAR; dSP; dTOPss; @@ -251,33 +295,9 @@ PP(pp_rv2sv) if (SvROK(sv)) goto wasref; } - if (PL_op->op_private & HINT_STRICT_REFS) { - if (SvOK(sv)) - DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); - else - DIE(aTHX_ PL_no_usym, "a SCALAR"); - } - if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF) - DIE(aTHX_ PL_no_usym, "a SCALAR"); - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - RETSETUNDEF; - } - if ((PL_op->op_flags & OPf_SPECIAL) && - !(PL_op->op_flags & OPf_MOD)) - { - gv = (GV*)gv_fetchsv(sv, 0, SVt_PV); - if (!gv - && (!is_gv_magical_sv(sv, 0) - || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV)))) - { - RETSETUNDEF; - } - } - else { - gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV); - } + gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp); + if (!gv) + RETURN; } sv = GvSVn(gv); } @@ -303,8 +323,7 @@ PP(pp_av2arylen) AV * const av = (AV*)TOPs; SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av); if (!*sv) { - *sv = newSV(0); - sv_upgrade(*sv, SVt_PVMG); + *sv = newSV_type(SVt_PVMG); sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0); } SETs(*sv); @@ -387,18 +406,25 @@ PP(pp_prototype) SV *ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { - const char * const s = SvPVX_const(TOPs); + const char * s = SvPVX_const(TOPs); if (strnEQ(s, "CORE::", 6)) { const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) - int i = 0, n = 0, seen_question = 0; + int i = 0, n = 0, seen_question = 0, defgv = 0; I32 oa; char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ if (code == -KEY_chop || code == -KEY_chomp || code == -KEY_exec || code == -KEY_system || code == -KEY_err) goto set; + if (code == -KEY_mkdir) { + ret = sv_2mortal(newSVpvs("_;$")); + goto set; + } + if (code == -KEY_readpipe) { + s = "CORE::backtick"; + } while (i < MAXO) { /* The slow way. */ if (strEQ(s + 6, PL_op_name[i]) || strEQ(s + 6, PL_op_desc[i])) @@ -409,9 +435,10 @@ PP(pp_prototype) } goto nonesuch; /* Should not happen... */ found: + defgv = PL_opargs[i] & OA_DEFGV; oa = PL_opargs[i] >> OASHIFT; while (oa) { - if (oa & OA_OPTIONAL && !seen_question) { + if (oa & OA_OPTIONAL && !seen_question && !defgv) { seen_question = 1; str[n++] = ';'; } @@ -425,6 +452,8 @@ PP(pp_prototype) str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; oa = oa >> 4; } + if (defgv && str[n - 1] == '$') + str[n - 1] = '_'; str[n++] = '\0'; ret = sv_2mortal(newSVpvn(str, n - 1)); } @@ -548,7 +577,7 @@ PP(pp_bless) if (len == 0 && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); - stash = gv_stashpvn(ptr, len, TRUE); + stash = gv_stashpvn(ptr, len, GV_ADD); } (void)sv_bless(TOPs, stash); @@ -3300,6 +3329,8 @@ PP(pp_index) PP(pp_sprintf) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; + if (SvTAINTED(MARK[1])) + TAINT_PROPER("sprintf"); do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; @@ -4023,7 +4054,7 @@ PP(pp_hslice) if (lval) { if (!svp || *svp == &PL_sv_undef) { - DIE(aTHX_ PL_no_helem_sv, keysv); + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } if (localizing) { if (HvNAME_get(hv) && isGV(*svp)) @@ -4266,7 +4297,7 @@ PP(pp_splice) *dst-- = *src--; } dst = AvARRAY(ary); - SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */ + AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */ AvMAX(ary) += diff; } else { @@ -4302,7 +4333,7 @@ PP(pp_splice) dst = src - diff; Move(src, dst, offset, SV*); } - SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */ + AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */ AvMAX(ary) += diff; AvFILLp(ary) += diff; } @@ -4578,7 +4609,11 @@ PP(pp_split) base = SP - PL_stack_base; orig = s; if (pm->op_pmflags & PMf_SKIPWHITE) { - if (pm->op_pmflags & PMf_LOCALE) { + if (do_utf8) { + while (*s == ' ' || is_utf8_space((U8*)s)) + s += UTF8SKIP(s); + } + else if (pm->op_pmflags & PMf_LOCALE) { while (isSPACE_LC(*s)) s++; } @@ -4596,10 +4631,23 @@ PP(pp_split) if (pm->op_pmflags & PMf_WHITE) { while (--limit) { m = s; - while (m < strend && - !((pm->op_pmflags & PMf_LOCALE) - ? isSPACE_LC(*m) : isSPACE(*m))) - ++m; + /* this one uses 'm' and is a negative test */ + if (do_utf8) { + while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) { + const int t = UTF8SKIP(m); + /* is_utf8_space returns FALSE for malform utf8 */ + if (strend - m < t) + m = strend; + else + m += t; + } + } else if (pm->op_pmflags & PMf_LOCALE) { + while (m < strend && !isSPACE_LC(*m)) + ++m; + } else { + while (m < strend && !isSPACE(*m)) + ++m; + } if (m >= strend) break; @@ -4610,14 +4658,26 @@ PP(pp_split) (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + 1; - while (s < strend && - ((pm->op_pmflags & PMf_LOCALE) - ? isSPACE_LC(*s) : isSPACE(*s))) - ++s; + /* skip the whitespace found last */ + if (do_utf8) + s = m + UTF8SKIP(m); + else + s = m + 1; + + /* this one uses 's' and is a positive test */ + if (do_utf8) { + while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) )) + s += UTF8SKIP(s); + } else if (pm->op_pmflags & PMf_LOCALE) { + while (s < strend && isSPACE_LC(*s)) + ++s; + } else { + while (s < strend && isSPACE(*s)) + ++s; + } } } - else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') { + else if (rx->extflags & RXf_START_ONLY) { while (--limit) { for (m = s; m < strend && *m != '\n'; m++) ; @@ -4633,15 +4693,15 @@ PP(pp_split) s = m; } } - else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) && - (rx->reganch & RE_USE_INTUIT) && !rx->nparens - && (rx->reganch & ROPT_CHECK_ALL) - && !(rx->reganch & ROPT_ANCH)) { - const int tail = (rx->reganch & RE_INTUIT_TAIL); + 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); SV * const csv = CALLREG_INTUIT_STRING(rx); - len = rx->minlen; - if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { + len = rx->minlenret; + if (len == 1 && !(rx->extflags & RXf_UTF8) && !tail) { const char c = *SvPV_nolen_const(csv); while (--limit) { for (m = s; m < strend && *m != c; m++)