X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doop.c;h=cd9b3b4f1794555d7d110767e9ac2e389a8c1168;hb=89d1f0ef1b6c19fa0e51e21c93cfffe86aeb375c;hp=530fef2b9282c2d740c80a255390cde211133b2e;hpb=bbb8a7e0703e09f15457e855696dbeebcd270517;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doop.c b/doop.c index 530fef2..cd9b3b4 100644 --- a/doop.c +++ b/doop.c @@ -1,7 +1,7 @@ /* doop.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2004, 2005, 2006, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2004, 2005, 2006, 2007, 2008, 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. @@ -9,7 +9,9 @@ */ /* - * "'So that was the job I felt I had to do when I started,' thought Sam." + * 'So that was the job I felt I had to do when I started,' thought Sam. + * + * [p.934 of _The Lord of the Rings_, VI/iii: "Mount Doom"] */ /* This file contains some common functions needed to carry out certain @@ -33,8 +35,10 @@ S_do_trans_simple(pTHX_ SV * const sv) STRLEN len; U8 *s = (U8*)SvPV(sv,len); U8 * const send = s+len; - const short * const tbl = (short*)cPVOP->op_pv; + + PERL_ARGS_ASSERT_DO_TRANS_SIMPLE; + if (!tbl) Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__); @@ -100,8 +104,10 @@ S_do_trans_count(pTHX_ SV * const sv) const U8 *s = (const U8*)SvPV_const(sv, len); const U8 * const send = s + len; I32 matches = 0; - const short * const tbl = (short*)cPVOP->op_pv; + + PERL_ARGS_ASSERT_DO_TRANS_COUNT; + if (!tbl) Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__); @@ -136,8 +142,10 @@ S_do_trans_complex(pTHX_ SV * const sv) U8 *s = (U8*)SvPV(sv, len); U8 * const send = s+len; I32 matches = 0; - const short * const tbl = (short*)cPVOP->op_pv; + + PERL_ARGS_ASSERT_DO_TRANS_COMPLEX; + if (!tbl) Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__); @@ -306,15 +314,21 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv) I32 matches = 0; const I32 grows = PL_op->op_private & OPpTRANS_GROWS; STRLEN len; - - SV* const rv = (SV*)cSVOP->op_sv; - HV* const hv = (HV*)SvRV(rv); + SV* const rv = +#ifdef USE_ITHREADS + PAD_SVl(cPADOP->op_padix); +#else + MUTABLE_SV(cSVOP->op_sv); +#endif + HV* const hv = MUTABLE_HV(SvRV(rv)); SV* const * svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; const UV extra = none + 1; UV final = 0; U8 hibit = 0; + PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8; + s = (U8*)SvPV(sv, len); if (!SvUTF8(sv)) { const U8 *t = s; @@ -402,14 +416,20 @@ S_do_trans_count_utf8(pTHX_ SV * const sv) const U8 *send; I32 matches = 0; STRLEN len; - - SV* const rv = (SV*)cSVOP->op_sv; - HV* const hv = (HV*)SvRV(rv); + SV* const rv = +#ifdef USE_ITHREADS + PAD_SVl(cPADOP->op_padix); +#else + MUTABLE_SV(cSVOP->op_sv); +#endif + HV* const hv = MUTABLE_HV(SvRV(rv)); SV* const * const svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; const UV extra = none + 1; U8 hibit = 0; + PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8; + s = (const U8*)SvPV_const(sv, len); if (!SvUTF8(sv)) { const U8 *t = s; @@ -447,8 +467,13 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv) const I32 squash = PL_op->op_private & OPpTRANS_SQUASH; const I32 del = PL_op->op_private & OPpTRANS_DELETE; const I32 grows = PL_op->op_private & OPpTRANS_GROWS; - SV * const rv = (SV*)cSVOP->op_sv; - HV * const hv = (HV*)SvRV(rv); + SV* const rv = +#ifdef USE_ITHREADS + PAD_SVl(cPADOP->op_padix); +#else + MUTABLE_SV(cSVOP->op_sv); +#endif + HV * const hv = MUTABLE_HV(SvRV(rv)); SV * const *svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; const UV extra = none + 1; @@ -457,8 +482,10 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv) STRLEN len; U8 *dstart, *dend; U8 hibit = 0; - U8 *s = (U8*)SvPV(sv, len); + + PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8; + if (!SvUTF8(sv)) { const U8 *t = s; const U8 * const e = s + len; @@ -606,11 +633,13 @@ Perl_do_trans(pTHX_ SV *sv) const I32 hasutf = (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); - if (SvREADONLY(sv)) { + PERL_ARGS_ASSERT_DO_TRANS; + + if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); - if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) - Perl_croak(aTHX_ PL_no_modify); + if (SvREADONLY(sv)) + Perl_croak(aTHX_ "%s", PL_no_modify); } (void)SvPV_const(sv, len); if (!len) @@ -656,6 +685,8 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV * register STRLEN len; STRLEN delimlen; + PERL_ARGS_ASSERT_DO_JOIN; + (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */ /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */ @@ -678,7 +709,7 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV * ++mark; } - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); /* sv_setpv retains old UTF8ness [perl #24846] */ SvUTF8_off(sv); @@ -712,6 +743,8 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) const char * const pat = SvPV_const(*sarg, patlen); bool do_taint = FALSE; + PERL_ARGS_ASSERT_DO_SPRINTF; + SvUTF8_off(sv); if (DO_UTF8(*sarg)) SvUTF8_on(sv); @@ -730,8 +763,10 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen); UV retnum = 0; + PERL_ARGS_ASSERT_DO_VECGET; + if (offset < 0) - return retnum; + return 0; if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); @@ -880,6 +915,8 @@ Perl_do_vecset(pTHX_ SV *sv) STRLEN len; SV * const targ = LvTARG(sv); + PERL_ARGS_ASSERT_DO_VECSET; + if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); @@ -959,20 +996,22 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) STRLEN len; char *s; + PERL_ARGS_ASSERT_DO_CHOP; + if (SvTYPE(sv) == SVt_PVAV) { register I32 i; - AV* const av = (AV*)sv; + AV *const av = MUTABLE_AV(sv); const I32 max = AvFILL(av); for (i = 0; i <= max; i++) { - sv = (SV*)av_fetch(av, i, FALSE); + sv = MUTABLE_SV(av_fetch(av, i, FALSE)); if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) do_chop(astr, sv); } return; } else if (SvTYPE(sv) == SVt_PVHV) { - HV* const hv = (HV*)sv; + HV* const hv = MUTABLE_HV(sv); HE* entry; (void)hv_iterinit(hv); while ((entry = hv_iternext(hv))) @@ -985,7 +1024,7 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } if (PL_encoding && !SvUTF8(sv)) { @@ -996,7 +1035,7 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) s = SvPV(sv, len); if (len && !SvPOK(sv)) - s = SvPV_force(sv, len); + s = SvPV_force_nomg(sv, len); if (DO_UTF8(sv)) { if (s && len) { char * const send = s + len; @@ -1013,7 +1052,7 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) } } else - sv_setpvn(astr, "", 0); + sv_setpvs(astr, ""); } else if (s && len) { s += --len; @@ -1024,7 +1063,7 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) SvNIOK_off(sv); } else - sv_setpvn(astr, "", 0); + sv_setpvs(astr, ""); SvSETMAGIC(sv); } @@ -1038,6 +1077,8 @@ Perl_do_chomp(pTHX_ register SV *sv) char *temp_buffer = NULL; SV* svrecode = NULL; + PERL_ARGS_ASSERT_DO_CHOMP; + if (RsSNARF(PL_rs)) return 0; if (RsRECORD(PL_rs)) @@ -1045,18 +1086,18 @@ Perl_do_chomp(pTHX_ register SV *sv) count = 0; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; - AV* const av = (AV*)sv; + AV *const av = MUTABLE_AV(sv); const I32 max = AvFILL(av); for (i = 0; i <= max; i++) { - sv = (SV*)av_fetch(av, i, FALSE); + sv = MUTABLE_SV(av_fetch(av, i, FALSE)); if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) count += do_chomp(sv); } return count; } else if (SvTYPE(sv) == SVt_PVHV) { - HV* const hv = (HV*)sv; + HV* const hv = MUTABLE_HV(sv); HE* entry; (void)hv_iterinit(hv); while ((entry = hv_iternext(hv))) @@ -1069,7 +1110,7 @@ Perl_do_chomp(pTHX_ register SV *sv) sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } if (PL_encoding) { @@ -1186,9 +1227,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) bool right_utf; STRLEN needlen = 0; + PERL_ARGS_ASSERT_DO_VOP; if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) - sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */ + sv_setpvs(sv, ""); /* avoid undef warning on |= and ^= */ lsave = lc = SvPV_nomg_const(left, leftlen); rsave = rc = SvPV_nomg_const(right, rightlen); @@ -1202,13 +1244,13 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) /* Avoid triggering overloading again by using temporaries. Maybe there should be a variant of sv_utf8_upgrade that takes pvn */ - right = sv_2mortal(newSVpvn(rsave, rightlen)); + right = newSVpvn_flags(rsave, rightlen, SVs_TEMP); sv_utf8_upgrade(right); rsave = rc = SvPV_nomg_const(right, rightlen); right_utf = TRUE; } else if (!left_utf && right_utf) { - left = sv_2mortal(newSVpvn(lsave, leftlen)); + left = newSVpvn_flags(lsave, leftlen, SVs_TEMP); sv_utf8_upgrade(left); lsave = lc = SvPV_nomg_const(left, leftlen); left_utf = TRUE; @@ -1391,7 +1433,7 @@ Perl_do_kv(pTHX) { dVAR; dSP; - HV * const hv = (HV*)POPs; + HV * const hv = MUTABLE_HV(POPs); HV *keys; register HE *entry; const I32 gimme = GIMME_V; @@ -1425,7 +1467,7 @@ Perl_do_kv(pTHX) sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0); } LvTYPE(TARG) = 'k'; - if (LvTARG(TARG) != (SV*)keys) { + if (LvTARG(TARG) != (const SV *)keys) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc_simple(keys); @@ -1434,8 +1476,7 @@ Perl_do_kv(pTHX) RETURN; } - if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied) - && ! SvTIED_mg((SV*)keys, PERL_MAGIC_regdata_names)) + if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { i = HvKEYS(keys); }