X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doop.c;h=1ad8bfab9ad774a5d2c7531136088633b073df88;hb=4af147f6b0134a663b2bfe1fed9228e3449b7553;hp=c6270e44f4fb21152a745c587d56dd85853ece1e;hpb=4757a2438b123364ad98fc0cb4698e56331f713b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doop.c b/doop.c index c6270e4..1ad8bfa 100644 --- a/doop.c +++ b/doop.c @@ -1,6 +1,6 @@ /* doop.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -12,14 +12,15 @@ */ #include "EXTERN.h" +#define PERL_IN_DOOP_C #include "perl.h" #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif -static I32 -do_trans_CC_simple(SV *sv) +STATIC I32 +S_do_trans_CC_simple(pTHX_ SV *sv) { dTHR; U8 *s; @@ -31,7 +32,7 @@ do_trans_CC_simple(SV *sv) tbl = (short*)cPVOP->op_pv; if (!tbl) - croak("panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans"); s = (U8*)SvPV(sv, len); send = s + len; @@ -48,8 +49,8 @@ do_trans_CC_simple(SV *sv) return matches; } -static I32 -do_trans_CC_count(SV *sv) +STATIC I32 +S_do_trans_CC_count(pTHX_ SV *sv) { dTHR; U8 *s; @@ -60,7 +61,7 @@ do_trans_CC_count(SV *sv) tbl = (short*)cPVOP->op_pv; if (!tbl) - croak("panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans"); s = (U8*)SvPV(sv, len); send = s + len; @@ -74,8 +75,8 @@ do_trans_CC_count(SV *sv) return matches; } -static I32 -do_trans_CC_complex(SV *sv) +STATIC I32 +S_do_trans_CC_complex(pTHX_ SV *sv) { dTHR; U8 *s; @@ -88,7 +89,7 @@ do_trans_CC_complex(SV *sv) tbl = (short*)cPVOP->op_pv; if (!tbl) - croak("panic: do_trans"); + Perl_croak(aTHX_ "panic: do_trans"); s = (U8*)SvPV(sv, len); send = s + len; @@ -131,8 +132,8 @@ do_trans_CC_complex(SV *sv) return matches; } -static I32 -do_trans_UU_simple(SV *sv) +STATIC I32 +S_do_trans_UU_simple(pTHX_ SV *sv) { dTHR; U8 *s; @@ -183,8 +184,8 @@ do_trans_UU_simple(SV *sv) return matches; } -static I32 -do_trans_UU_count(SV *sv) +STATIC I32 +S_do_trans_UU_count(pTHX_ SV *sv) { dTHR; U8 *s; @@ -202,17 +203,16 @@ do_trans_UU_count(SV *sv) send = s + len; while (s < send) { - if ((uv = swash_fetch(rv, s)) < none) { - s += UTF8SKIP(s); + if ((uv = swash_fetch(rv, s)) < none) matches++; - } + s += UTF8SKIP(s); } return matches; } -static I32 -do_trans_UC_simple(SV *sv) +STATIC I32 +S_do_trans_UC_simple(pTHX_ SV *sv) { dTHR; U8 *s; @@ -264,8 +264,8 @@ do_trans_UC_simple(SV *sv) return matches; } -static I32 -do_trans_CU_simple(SV *sv) +STATIC I32 +S_do_trans_CU_simple(pTHX_ SV *sv) { dTHR; U8 *s; @@ -327,8 +327,8 @@ do_trans_CU_simple(SV *sv) /* utf-8 to latin-1 */ -static I32 -do_trans_UC_trivial(SV *sv) +STATIC I32 +S_do_trans_UC_trivial(pTHX_ SV *sv) { dTHR; U8 *s; @@ -359,8 +359,8 @@ do_trans_UC_trivial(SV *sv) /* latin-1 to utf-8 */ -static I32 -do_trans_CU_trivial(SV *sv) +STATIC I32 +S_do_trans_CU_trivial(pTHX_ SV *sv) { dTHR; U8 *s; @@ -393,8 +393,8 @@ do_trans_CU_trivial(SV *sv) return matches; } -static I32 -do_trans_UU_complex(SV *sv) +STATIC I32 +S_do_trans_UU_complex(pTHX_ SV *sv) { dTHR; U8 *s; @@ -579,12 +579,13 @@ do_trans_UU_complex(SV *sv) } I32 -do_trans(SV *sv) +Perl_do_trans(pTHX_ SV *sv) { + dTHR; STRLEN len; if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) - croak(no_modify); + Perl_croak(aTHX_ PL_no_modify); (void)SvPV(sv, len); if (!len) @@ -593,7 +594,7 @@ do_trans(SV *sv) (void)SvPV_force(sv, len); (void)SvPOK_only(sv); - DEBUG_t( deb("2.TBL\n")); + DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); switch (PL_op->op_private & 63) { case 0: @@ -629,7 +630,7 @@ do_trans(SV *sv) } void -do_join(register SV *sv, SV *del, register SV **mark, register SV **sp) +Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp) { SV **oldmark = mark; register I32 items = sp - mark; @@ -640,8 +641,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp) mark++; len = (items > 0 ? (delimlen * (items - 1) ) : 0); - if (SvTYPE(sv) < SVt_PV) - sv_upgrade(sv, SVt_PV); + (void)SvUPGRADE(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) { @@ -653,7 +653,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp) SvGROW(sv, len + 1); /* so try to pre-extend */ mark = oldmark; - items = sp - mark;; + items = sp - mark; ++mark; } @@ -685,7 +685,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp) } void -do_sprintf(SV *sv, I32 len, SV **sarg) +Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) { STRLEN patlen; char *pat = SvPV(*sarg, patlen); @@ -697,14 +697,146 @@ do_sprintf(SV *sv, I32 len, SV **sarg) SvTAINTED_on(sv); } +UV +Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) +{ + STRLEN srclen, len; + unsigned char *s = (unsigned char *) SvPV(sv, srclen); + UV retnum = 0; + + if (offset < 0) + return retnum; + 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 (len > srclen) { + if (size <= 8) + retnum = 0; + else { + offset >>= 3; /* turn into byte offset */ + if (size == 16) { + if (offset >= srclen) + retnum = 0; + else + retnum = (UV) s[offset] << 8; + } + else if (size == 32) { + if (offset >= srclen) + retnum = 0; + else if (offset + 1 >= srclen) + retnum = + ((UV) s[offset ] << 24); + else if (offset + 2 >= srclen) + retnum = + ((UV) s[offset ] << 24) + + ((UV) s[offset + 1] << 16); + else + retnum = + ((UV) s[offset ] << 24) + + ((UV) s[offset + 1] << 16) + + ( s[offset + 2] << 8); + } +#ifdef UV_IS_QUAD + else if (size == 64) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Bit vector size > 32 non-portable"); + if (offset >= srclen) + retnum = 0; + else if (offset + 1 >= srclen) + retnum = + (UV) s[offset ] << 56; + else if (offset + 2 >= srclen) + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48); + else if (offset + 3 >= srclen) + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48) + + ((UV) s[offset + 2] << 40); + else if (offset + 4 >= srclen) + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48) + + ((UV) s[offset + 2] << 40) + + ((UV) s[offset + 3] << 32); + else if (offset + 5 >= srclen) + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48) + + ((UV) s[offset + 2] << 40) + + ((UV) s[offset + 3] << 32) + + ( s[offset + 4] << 24); + else if (offset + 6 >= srclen) + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48) + + ((UV) s[offset + 2] << 40) + + ((UV) s[offset + 3] << 32) + + ((UV) s[offset + 4] << 24) + + ((UV) s[offset + 5] << 16); + else + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48) + + ((UV) s[offset + 2] << 40) + + ((UV) s[offset + 3] << 32) + + ((UV) s[offset + 4] << 24) + + ((UV) s[offset + 5] << 16) + + ( s[offset + 6] << 8); + } +#endif + } + } + else if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; /* turn into byte offset */ + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = + ((UV) s[offset] << 8) + + s[offset + 1]; + else if (size == 32) + retnum = + ((UV) s[offset ] << 24) + + ((UV) s[offset + 1] << 16) + + ( s[offset + 2] << 8) + + s[offset + 3]; +#ifdef UV_IS_QUAD + else if (size == 64) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Bit vector size > 32 non-portable"); + retnum = + ((UV) s[offset ] << 56) + + ((UV) s[offset + 1] << 48) + + ((UV) s[offset + 2] << 40) + + ((UV) s[offset + 3] << 32) + + ((UV) s[offset + 4] << 24) + + ((UV) s[offset + 5] << 16) + + ( s[offset + 6] << 8) + + s[offset + 7]; + } +#endif + } + + return retnum; +} + void -do_vecset(SV *sv) +Perl_do_vecset(pTHX_ SV *sv) { SV *targ = LvTARG(sv); register I32 offset; register I32 size; register unsigned char *s; - register unsigned long lval; + register UV lval; I32 mask; STRLEN targlen; STRLEN len; @@ -712,11 +844,14 @@ do_vecset(SV *sv) if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); - lval = U_L(SvNV(sv)); + lval = SvUV(sv); offset = LvTARGOFF(sv); size = LvTARGLEN(sv); + if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ + Perl_croak(aTHX_ "Illegal number of bits in vec"); - len = (offset + size + 7) / 8; + offset *= size; /* turn into bit offset */ + len = (offset + size + 7) / 8; /* required number of bytes */ if (len > targlen) { s = (unsigned char*)SvGROW(targ, len + 1); (void)memzero(s + targlen, len - targlen + 1); @@ -727,29 +862,46 @@ do_vecset(SV *sv) mask = (1 << size) - 1; size = offset & 7; lval &= mask; - offset >>= 3; + offset >>= 3; /* turn into byte offset */ s[offset] &= ~(mask << size); s[offset] |= lval << size; } else { - offset >>= 3; + offset >>= 3; /* turn into byte offset */ if (size == 8) - s[offset] = lval & 255; + s[offset ] = lval & 0xff; else if (size == 16) { - s[offset] = (lval >> 8) & 255; - s[offset+1] = lval & 255; + s[offset ] = (lval >> 8) & 0xff; + s[offset+1] = lval & 0xff; } else if (size == 32) { - s[offset] = (lval >> 24) & 255; - s[offset+1] = (lval >> 16) & 255; - s[offset+2] = (lval >> 8) & 255; - s[offset+3] = lval & 255; + s[offset ] = (lval >> 24) & 0xff; + s[offset+1] = (lval >> 16) & 0xff; + s[offset+2] = (lval >> 8) & 0xff; + s[offset+3] = lval & 0xff; + } +#ifdef UV_IS_QUAD + else if (size == 64) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Bit vector size > 32 non-portable"); + s[offset ] = (lval >> 56) & 0xff; + s[offset+1] = (lval >> 48) & 0xff; + s[offset+2] = (lval >> 40) & 0xff; + s[offset+3] = (lval >> 32) & 0xff; + s[offset+4] = (lval >> 24) & 0xff; + s[offset+5] = (lval >> 16) & 0xff; + s[offset+6] = (lval >> 8) & 0xff; + s[offset+7] = lval & 0xff; } +#endif } + SvSETMAGIC(targ); } void -do_chop(register SV *astr, register SV *sv) +Perl_do_chop(pTHX_ register SV *astr, register SV *sv) { STRLEN len; char *s; @@ -767,7 +919,7 @@ do_chop(register SV *astr, register SV *sv) } return; } - if (SvTYPE(sv) == SVt_PVHV) { + else if (SvTYPE(sv) == SVt_PVHV) { HV* hv = (HV*)sv; HE* entry; (void)hv_iterinit(hv); @@ -776,6 +928,8 @@ do_chop(register SV *astr, register SV *sv) do_chop(astr,hv_iterval(hv,entry)); return; } + else if (SvREADONLY(sv)) + Perl_croak(aTHX_ PL_no_modify); s = SvPV(sv, len); if (len && !SvPOK(sv)) s = SvPV_force(sv, len); @@ -786,8 +940,8 @@ do_chop(register SV *astr, register SV *sv) s = send - 1; while ((*s & 0xc0) == 0x80) --s; - if (UTF8SKIP(s) != send - s) - warn("Malformed UTF-8 character"); + if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); sv_setpvn(astr, s, send - s); *s = '\0'; SvCUR_set(sv, s - start); @@ -810,7 +964,7 @@ do_chop(register SV *astr, register SV *sv) } I32 -do_chomp(register SV *sv) +Perl_do_chomp(pTHX_ register SV *sv) { dTHR; register I32 count; @@ -819,6 +973,8 @@ do_chomp(register SV *sv) if (RsSNARF(PL_rs)) return 0; + if (RsRECORD(PL_rs)) + return 0; count = 0; if (SvTYPE(sv) == SVt_PVAV) { register I32 i; @@ -832,7 +988,7 @@ do_chomp(register SV *sv) } return count; } - if (SvTYPE(sv) == SVt_PVHV) { + else if (SvTYPE(sv) == SVt_PVHV) { HV* hv = (HV*)sv; HE* entry; (void)hv_iterinit(hv); @@ -841,6 +997,8 @@ do_chomp(register SV *sv) count += do_chomp(hv_iterval(hv,entry)); return count; } + else if (SvREADONLY(sv)) + Perl_croak(aTHX_ PL_no_modify); s = SvPV(sv, len); if (len && !SvPOKp(sv)) s = SvPV_force(sv, len); @@ -884,7 +1042,7 @@ do_chomp(register SV *sv) } void -do_vop(I32 optype, SV *sv, SV *left, SV *right) +Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) { dTHR; /* just for taint */ #ifdef LIBERAL @@ -909,7 +1067,8 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right) len = leftlen < rightlen ? leftlen : rightlen; lensave = len; if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { - dc = SvPV_force(sv, PL_na); + STRLEN n_a; + dc = SvPV_force(sv, n_a); if (SvCUR(sv) < len) { dc = SvGROW(sv, len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); @@ -998,7 +1157,7 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right) } OP * -do_kv(ARGSproto) +Perl_do_kv(pTHX) { djSP; HV *hv = (HV*)POPs; @@ -1048,7 +1207,7 @@ do_kv(ARGSproto) RETURN; } - if (!SvRMAGICAL(keys) || !mg_find((SV*)keys,'P')) + if (! SvTIED_mg((SV*)keys, 'P')) i = HvKEYS(keys); else { i = 0; @@ -1067,11 +1226,10 @@ do_kv(ARGSproto) if (dokeys) XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (dovalues) { - tmpstr = sv_newmortal(); PUTBACK; - sv_setsv(tmpstr,realhv ? - hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry)); - DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu", + tmpstr = realhv ? + hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry); + DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu", (unsigned long)HeHASH(entry), HvMAX(keys)+1, (unsigned long)(HeHASH(entry) & HvMAX(keys))));