X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doop.c;h=8bff60aa0a1a3ebdcb9507e9ec25de65d4ebba35;hb=5bca5c48fc14b9266d0bbef49a265ce0d735b118;hp=16204653b07026d5baefa31e3b697cdf27bb28ad;hpb=81714fb9c03d91d66b66cab6e899e81bf64a2ca7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doop.c b/doop.c index 1620465..8bff60a 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 + * 2000, 2001, 2002, 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. @@ -33,8 +33,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 +102,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 +140,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,8 +312,12 @@ 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; + SV* const rv = +#ifdef USE_ITHREADS + PAD_SVl(cPADOP->op_padix); +#else + (SV*)cSVOP->op_sv; +#endif HV* const hv = (HV*)SvRV(rv); SV* const * svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; @@ -315,6 +325,8 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv) 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 +414,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; + SV* const rv = +#ifdef USE_ITHREADS + PAD_SVl(cPADOP->op_padix); +#else + (SV*)cSVOP->op_sv; +#endif HV* const hv = (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,7 +465,12 @@ 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; + SV* const rv = +#ifdef USE_ITHREADS + PAD_SVl(cPADOP->op_padix); +#else + (SV*)cSVOP->op_sv; +#endif HV * const hv = (HV*)SvRV(rv); SV * const *svp = hv_fetchs(hv, "NONE", FALSE); const UV none = svp ? SvUV(*svp) : 0x7fffffff; @@ -457,8 +480,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,10 +631,12 @@ 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)) + if (SvREADONLY(sv)) Perl_croak(aTHX_ PL_no_modify); } (void)SvPV_const(sv, len); @@ -656,6 +683,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. */ @@ -712,6 +741,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); @@ -726,25 +757,34 @@ UV Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) { dVAR; - STRLEN srclen, len, uoffset; + STRLEN srclen, len, uoffset, bitoffs = 0; 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"); if (SvUTF8(sv)) (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); - uoffset = offset*size; /* turn into bit offset */ - len = (uoffset + size + 7) / 8; /* required number of bytes */ + if (size < 8) { + bitoffs = ((offset%8)*size)%8; + uoffset = offset/(8/size); + } + else if (size > 8) + uoffset = offset*(size/8); + else + uoffset = offset; + + len = uoffset + (bitoffs + size + 7)/8; /* required number of bytes */ if (len > srclen) { if (size <= 8) retnum = 0; else { - uoffset >>= 3; /* turn into byte offset */ if (size == 16) { if (uoffset >= srclen) retnum = 0; @@ -821,9 +861,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) } } else if (size < 8) - retnum = (s[uoffset >> 3] >> (uoffset & 7)) & ((1 << size) - 1); + retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1); else { - uoffset >>= 3; /* turn into byte offset */ if (size == 8) retnum = s[uoffset]; else if (size == 16) @@ -865,7 +904,7 @@ void Perl_do_vecset(pTHX_ SV *sv) { dVAR; - register I32 offset; + register I32 offset, bitoffs = 0; register I32 size; register unsigned char *s; register UV lval; @@ -874,6 +913,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); @@ -894,8 +935,14 @@ Perl_do_vecset(pTHX_ SV *sv) if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ Perl_croak(aTHX_ "Illegal number of bits in vec"); - offset *= size; /* turn into bit offset */ - len = (offset + size + 7) / 8; /* required number of bytes */ + if (size < 8) { + bitoffs = ((offset%8)*size)%8; + offset /= 8/size; + } + else if (size > 8) + offset *= size/8; + + len = offset + (bitoffs + size + 7)/8; /* required number of bytes */ if (len > targlen) { s = (unsigned char*)SvGROW(targ, len + 1); (void)memzero((char *)(s + targlen), len - targlen + 1); @@ -904,14 +951,11 @@ Perl_do_vecset(pTHX_ SV *sv) if (size < 8) { mask = (1 << size) - 1; - size = offset & 7; lval &= mask; - offset >>= 3; /* turn into byte offset */ - s[offset] &= ~(mask << size); - s[offset] |= lval << size; + s[offset] &= ~(mask << bitoffs); + s[offset] |= lval << bitoffs; } else { - offset >>= 3; /* turn into byte offset */ if (size == 8) s[offset ] = (U8)( lval & 0xff); else if (size == 16) { @@ -950,6 +994,8 @@ 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; @@ -987,7 +1033,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; @@ -1029,6 +1075,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)) @@ -1177,6 +1225,7 @@ 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 ^= */ @@ -1193,13 +1242,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; @@ -1425,8 +1474,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((SV*)keys, PERL_MAGIC_tied) ) { i = HvKEYS(keys); }