/* doop.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2004, 2005, 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. * */ /* * "'So that was the job I felt I had to do when I started,' thought Sam." */ /* This file contains some common functions needed to carry out certain * ops. For example both pp_schomp() and pp_chomp() - scalar and array * chomp operations - call the function do_chomp() found in this file. */ #include "EXTERN.h" #define PERL_IN_DOOP_C #include "perl.h" #ifndef PERL_MICRO #include #endif STATIC I32 S_do_trans_simple(pTHX_ SV *sv) 29541 { 29541 U8 *s; 29541 U8 *d; 29541 const U8 *send; 29541 U8 *dstart; 29541 I32 matches = 0; 29541 const I32 grows = PL_op->op_private & OPpTRANS_GROWS; 29541 STRLEN len; 29541 const short *tbl = (short*)cPVOP->op_pv; 29541 if (!tbl) ###### Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__); 29541 s = (U8*)SvPV(sv, len); 29541 send = s + len; /* First, take care of non-UTF-8 input strings, because they're easy */ 29541 if (!SvUTF8(sv)) { 497445 while (s < send) { 467915 const I32 ch = tbl[*s]; 467915 if (ch >= 0) { 406909 matches++; 406909 *s++ = (U8)ch; } else 61006 s++; } 29530 SvSETMAGIC(sv); 29530 return matches; } /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */ 11 if (grows) ###### New(0, d, len*2+1, U8); else 11 d = s; 11 dstart = d; 61 while (s < send) { 50 STRLEN ulen; 50 I32 ch; /* Need to check this, otherwise 128..255 won't match */ 50 const UV c = utf8n_to_uvchr(s, send - s, &ulen, 0); 50 if (c < 0x100 && (ch = tbl[c]) >= 0) { 11 matches++; 11 d = uvchr_to_utf8(d, ch); 11 s += ulen; } else { /* No match -> copy */ 39 Move(s, d, ulen, U8); 39 d += ulen; 39 s += ulen; } } 11 if (grows) { ###### sv_setpvn(sv, (char*)dstart, d - dstart); ###### Safefree(dstart); } else { 11 *d = '\0'; 11 SvCUR_set(sv, d - dstart); } 11 SvUTF8_on(sv); 11 SvSETMAGIC(sv); 11 return matches; } STATIC I32 S_do_trans_count(pTHX_ SV *sv) 11608 { 11608 const U8 *s; 11608 const U8 *send; 11608 I32 matches = 0; 11608 STRLEN len; 11608 const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT; 11608 const short * const tbl = (short*)cPVOP->op_pv; 11608 if (!tbl) ###### Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__); 11608 s = (const U8*)SvPV_const(sv, len); 11608 send = s + len; 11608 if (!SvUTF8(sv)) 506907 while (s < send) { 495327 if (tbl[*s++] >= 0) 54025 matches++; } else 132 while (s < send) { 104 STRLEN ulen; 104 const UV c = utf8n_to_uvchr(s, send - s, &ulen, 0); 104 if (c < 0x100) { 52 if (tbl[c] >= 0) 2 matches++; 52 } else if (complement) 46 matches++; 104 s += ulen; } 11608 return matches; } STATIC I32 S_do_trans_complex(pTHX_ SV *sv) 29746 { 29746 U8 *s; 29746 U8 *send; 29746 U8 *d; 29746 U8 *dstart; 29746 I32 isutf8; 29746 I32 matches = 0; 29746 const I32 grows = PL_op->op_private & OPpTRANS_GROWS; 29746 const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT; 29746 const I32 del = PL_op->op_private & OPpTRANS_DELETE; 29746 STRLEN len, rlen = 0; 29746 const short * const tbl = (short*)cPVOP->op_pv; 29746 if (!tbl) ###### Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__); 29746 s = (U8*)SvPV(sv, len); 29746 isutf8 = SvUTF8(sv); 29746 send = s + len; 29746 if (!isutf8) { 29740 dstart = d = s; 29740 if (PL_op->op_private & OPpTRANS_SQUASH) { 915 const U8* p = send; 11047 while (s < send) { 10132 const I32 ch = tbl[*s]; 10132 if (ch >= 0) { 957 *d = (U8)ch; 957 matches++; 957 if (p != d - 1 || *p != *d) 609 p = d++; } 9175 else if (ch == -1) /* -1 is unmapped character */ 9175 *d++ = *s; ###### else if (ch == -2) /* -2 is delete character */ ###### matches++; 10132 s++; } } else { 912889 while (s < send) { 884064 const I32 ch = tbl[*s]; 884064 if (ch >= 0) { ###### matches++; ###### *d++ = (U8)ch; } 884064 else if (ch == -1) /* -1 is unmapped character */ 855953 *d++ = *s; 28111 else if (ch == -2) /* -2 is delete character */ 28111 matches++; 884064 s++; } } 29740 *d = '\0'; 29740 SvCUR_set(sv, d - dstart); } else { /* isutf8 */ 6 if (grows) ###### New(0, d, len*2+1, U8); else 6 d = s; 6 dstart = d; 6 if (complement && !del) 4 rlen = tbl[0x100]; #ifdef MACOS_TRADITIONAL #define comp CoMP /* "comp" is a keyword in some compilers ... */ #endif 6 if (PL_op->op_private & OPpTRANS_SQUASH) { 2 UV pch = 0xfeedface; 10 while (s < send) { 8 STRLEN len; 8 const UV comp = utf8_to_uvchr(s, &len); 8 I32 ch; 8 if (comp > 0xff) { 3 if (!complement) { 2 Copy(s, d, len, U8); 2 d += len; } else { 1 matches++; 1 if (!del) { 1 ch = (rlen == 0) ? comp : (comp - 0x100 < rlen) ? tbl[comp+1] : tbl[0x100+rlen]; 1 if ((UV)ch != pch) { 1 d = uvchr_to_utf8(d, ch); 1 pch = (UV)ch; } 1 s += len; 1 continue; } } } 5 else if ((ch = tbl[comp]) >= 0) { 3 matches++; 3 if ((UV)ch != pch) { 2 d = uvchr_to_utf8(d, ch); 2 pch = (UV)ch; } 3 s += len; 3 continue; } 2 else if (ch == -1) { /* -1 is unmapped character */ 2 Copy(s, d, len, U8); 2 d += len; } ###### else if (ch == -2) /* -2 is delete character */ ###### matches++; 4 s += len; 4 pch = 0xfeedface; } } else { 15 while (s < send) { 11 STRLEN len; 11 const UV comp = utf8_to_uvchr(s, &len); 11 I32 ch; 11 if (comp > 0xff) { 7 if (!complement) { 2 Move(s, d, len, U8); 2 d += len; } else { 5 matches++; 5 if (!del) { 5 if (comp - 0x100 < rlen) 5 d = uvchr_to_utf8(d, tbl[comp+1]); else ###### d = uvchr_to_utf8(d, tbl[0x100+rlen]); } } } 4 else if ((ch = tbl[comp]) >= 0) { ###### d = uvchr_to_utf8(d, ch); ###### matches++; } 4 else if (ch == -1) { /* -1 is unmapped character */ 2 Copy(s, d, len, U8); 2 d += len; } 2 else if (ch == -2) /* -2 is delete character */ 2 matches++; 11 s += len; } } 6 if (grows) { ###### sv_setpvn(sv, (char*)dstart, d - dstart); ###### Safefree(dstart); } else { 6 *d = '\0'; 6 SvCUR_set(sv, d - dstart); } 6 SvUTF8_on(sv); } 29746 SvSETMAGIC(sv); 29746 return matches; } STATIC I32 S_do_trans_simple_utf8(pTHX_ SV *sv) 35 { 35 U8 *s; 35 U8 *send; 35 U8 *d; 35 U8 *start; 35 U8 *dstart, *dend; 35 I32 matches = 0; 35 const I32 grows = PL_op->op_private & OPpTRANS_GROWS; 35 STRLEN len; 35 SV* const rv = (SV*)cSVOP->op_sv; 35 HV* const hv = (HV*)SvRV(rv); 35 SV** svp = hv_fetch(hv, "NONE", 4, FALSE); 35 const UV none = svp ? SvUV(*svp) : 0x7fffffff; 35 const UV extra = none + 1; 35 UV final = 0; 35 UV uv; 35 I32 isutf8; 35 U8 hibit = 0; 35 s = (U8*)SvPV(sv, len); 35 isutf8 = SvUTF8(sv); 35 if (!isutf8) { 2 const U8 *t = s, *e = s + len; 5 while (t < e) { 4 const U8 ch = *t++; 4 if ((hibit = !NATIVE_IS_INVARIANT(ch))) 2 break; } 2 if (hibit) 1 s = bytes_to_utf8(s, &len); } 35 send = s + len; 35 start = s; 35 svp = hv_fetch(hv, "FINAL", 5, FALSE); 35 if (svp) 1 final = SvUV(*svp); 35 if (grows) { /* d needs to be bigger than s, in case e.g. upgrading is required */ 3 New(0, d, len * 3 + UTF8_MAXBYTES, U8); 3 dend = d + len * 3; 3 dstart = d; } else { 32 dstart = d = s; 32 dend = d + len; } 1519 while (s < send) { 1484 if ((uv = swash_fetch(rv, s, TRUE)) < none) { 1423 s += UTF8SKIP(s); 1423 matches++; 1423 d = uvuni_to_utf8(d, uv); } 61 else if (uv == none) { 60 const int i = UTF8SKIP(s); 60 Move(s, d, i, U8); 60 d += i; 60 s += i; } 1 else if (uv == extra) { 1 s += UTF8SKIP(s); 1 matches++; 1 d = uvuni_to_utf8(d, final); } else ###### s += UTF8SKIP(s); 1484 if (d > dend) { ###### const STRLEN clen = d - dstart; ###### const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES; ###### if (!grows) ###### Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__); ###### Renew(dstart, nlen + UTF8_MAXBYTES, U8); ###### d = dstart + clen; ###### dend = dstart + nlen; } } 35 if (grows || hibit) { 4 sv_setpvn(sv, (char*)dstart, d - dstart); 4 Safefree(dstart); 4 if (grows && hibit) ###### Safefree(start); } else { 31 *d = '\0'; 31 SvCUR_set(sv, d - dstart); } 35 SvSETMAGIC(sv); 35 SvUTF8_on(sv); 35 return matches; } STATIC I32 S_do_trans_count_utf8(pTHX_ SV *sv) 4 { 4 const U8 *s; 4 const U8 *start = 0, *send; 4 I32 matches = 0; 4 STRLEN len; 4 SV* const rv = (SV*)cSVOP->op_sv; 4 HV* const hv = (HV*)SvRV(rv); 4 SV** const svp = hv_fetch(hv, "NONE", 4, FALSE); 4 const UV none = svp ? SvUV(*svp) : 0x7fffffff; 4 const UV extra = none + 1; 4 U8 hibit = 0; 4 s = (const U8*)SvPV_const(sv, len); 4 if (!SvUTF8(sv)) { ###### const U8 *t = s; ###### const U8 *e = s + len; ###### while (t < e) { ###### const U8 ch = *t++; ###### if ((hibit = !NATIVE_IS_INVARIANT(ch))) ###### break; } ###### if (hibit) ###### start = s = bytes_to_utf8(s, &len); } 4 send = s + len; 16 while (s < send) { 12 UV uv; 12 if ((uv = swash_fetch(rv, s, TRUE)) < none || uv == extra) 4 matches++; 12 s += UTF8SKIP(s); } 4 if (hibit) ###### Safefree(start); 4 return matches; } STATIC I32 S_do_trans_complex_utf8(pTHX_ SV *sv) 10 { 10 U8 *start, *send; 10 U8 *d; 10 I32 matches = 0; 10 const I32 squash = PL_op->op_private & OPpTRANS_SQUASH; 10 const I32 del = PL_op->op_private & OPpTRANS_DELETE; 10 const I32 grows = PL_op->op_private & OPpTRANS_GROWS; 10 SV * const rv = (SV*)cSVOP->op_sv; 10 HV * const hv = (HV*)SvRV(rv); 10 SV** svp = hv_fetch(hv, "NONE", 4, FALSE); 10 const UV none = svp ? SvUV(*svp) : 0x7fffffff; 10 const UV extra = none + 1; 10 UV final = 0; 10 bool havefinal = FALSE; 10 STRLEN len; 10 U8 *dstart, *dend; 10 U8 hibit = 0; 10 U8 *s = (U8*)SvPV(sv, len); 10 const I32 isutf8 = SvUTF8(sv); 10 if (!isutf8) { ###### const U8 *t = s; ###### const U8 * const e = s + len; ###### while (t < e) { ###### const U8 ch = *t++; ###### if ((hibit = !NATIVE_IS_INVARIANT(ch))) ###### break; } ###### if (hibit) ###### s = bytes_to_utf8(s, &len); } 10 send = s + len; 10 start = s; 10 svp = hv_fetch(hv, "FINAL", 5, FALSE); 10 if (svp) { 6 final = SvUV(*svp); 6 havefinal = TRUE; } 10 if (grows) { /* d needs to be bigger than s, in case e.g. upgrading is required */ 2 New(0, d, len * 3 + UTF8_MAXBYTES, U8); 2 dend = d + len * 3; 2 dstart = d; } else { 8 dstart = d = s; 8 dend = d + len; } 10 if (squash) { 3 UV puv = 0xfeedface; 13 while (s < send) { 10 UV uv = swash_fetch(rv, s, TRUE); 10 if (d > dend) { ###### const STRLEN clen = d - dstart; ###### const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES; ###### if (!grows) ###### Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__); ###### Renew(dstart, nlen + UTF8_MAXBYTES, U8); ###### d = dstart + clen; ###### dend = dstart + nlen; } 10 if (uv < none) { 2 matches++; 2 s += UTF8SKIP(s); 2 if (uv != puv) { 1 d = uvuni_to_utf8(d, uv); 1 puv = uv; } 1 continue; } 8 else if (uv == none) { /* "none" is unmapped character */ 5 const int i = UTF8SKIP(s); 5 Move(s, d, i, U8); 5 d += i; 5 s += i; 5 puv = 0xfeedface; 5 continue; } 3 else if (uv == extra && !del) { 3 matches++; 3 if (havefinal) { 1 s += UTF8SKIP(s); 1 if (puv != final) { 1 d = uvuni_to_utf8(d, final); 1 puv = final; } } else { 2 STRLEN len; 2 uv = utf8_to_uvuni(s, &len); 2 if (uv != puv) { 1 Move(s, d, len, U8); 1 d += len; 1 puv = uv; } 2 s += len; } 2 continue; } ###### matches++; /* "none+1" is delete character */ ###### s += UTF8SKIP(s); } } else { 31 while (s < send) { 24 const UV uv = swash_fetch(rv, s, TRUE); 24 if (d > dend) { ###### const STRLEN clen = d - dstart; ###### const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES; ###### if (!grows) ###### Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__); ###### Renew(dstart, nlen + UTF8_MAXBYTES, U8); ###### d = dstart + clen; ###### dend = dstart + nlen; } 24 if (uv < none) { 2 matches++; 2 s += UTF8SKIP(s); 2 d = uvuni_to_utf8(d, uv); 2 continue; } 22 else if (uv == none) { /* "none" is unmapped character */ 11 const int i = UTF8SKIP(s); 11 Move(s, d, i, U8); 11 d += i; 11 s += i; 11 continue; } 11 else if (uv == extra && !del) { 9 matches++; 9 s += UTF8SKIP(s); 9 d = uvuni_to_utf8(d, final); 9 continue; } 2 matches++; /* "none+1" is delete character */ 2 s += UTF8SKIP(s); } } 10 if (grows || hibit) { 2 sv_setpvn(sv, (char*)dstart, d - dstart); 2 Safefree(dstart); 2 if (grows && hibit) ###### Safefree(start); } else { 8 *d = '\0'; 8 SvCUR_set(sv, d - dstart); } 10 SvUTF8_on(sv); 10 SvSETMAGIC(sv); 10 return matches; } I32 Perl_do_trans(pTHX_ SV *sv) 71445 { 71445 STRLEN len; 71445 const I32 hasutf = (PL_op->op_private & 71445 (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); 71445 if (SvREADONLY(sv)) { 1065 if (SvIsCOW(sv)) 1055 sv_force_normal_flags(sv, 0); 1065 if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) 1 Perl_croak(aTHX_ PL_no_modify); } 71444 (void)SvPV_const(sv, len); 71444 if (!len) 500 return 0; 70944 if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) { 59332 if (!SvPOKp(sv)) ###### (void)SvPV_force(sv, len); 59332 (void)SvPOK_only_UTF8(sv); } 70944 DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); switch (PL_op->op_private & ~hasutf & ( OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL| 70944 OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) { case 0: 29576 if (hasutf) 35 return do_trans_simple_utf8(sv); else 29541 return do_trans_simple(sv); case OPpTRANS_IDENTICAL: case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT: 11612 if (hasutf) 4 return do_trans_count_utf8(sv); else 11608 return do_trans_count(sv); default: 29756 if (hasutf) 10 return do_trans_complex_utf8(sv); else 29746 return do_trans_complex(sv); } } void Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp) 790449 { 790449 SV ** const oldmark = mark; 790449 register I32 items = sp - mark; 790449 register STRLEN len; 790449 STRLEN delimlen; 790449 (void) SvPV_const(del, delimlen); /* stringify and get the delimlen */ /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */ 790449 mark++; 790449 len = (items > 0 ? (delimlen * (items - 1) ) : 0); 790449 SvUPGRADE(sv, SVt_PV); 790449 if (SvLEN(sv) < len + items) { /* current length is way too short */ 1600297 while (items-- > 0) { 1590638 if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) { 1589620 STRLEN tmplen; 1589620 SvPV_const(*mark, tmplen); 1589620 len += tmplen; } 1590638 mark++; } 9659 SvGROW(sv, len + 1); /* so try to pre-extend */ 9659 mark = oldmark; 9659 items = sp - mark; 9659 ++mark; } 790449 sv_setpvn(sv, "", 0); /* sv_setpv retains old UTF8ness [perl #24846] */ 790449 SvUTF8_off(sv); 790449 if (PL_tainting && SvMAGICAL(sv)) 6197 SvTAINTED_off(sv); 790449 if (items-- > 0) { 758886 if (*mark) 758886 sv_catsv(sv, *mark); 758886 mark++; } 790449 if (delimlen) { 2937785 for (; items > 0; items--,mark++) { 1395397 sv_catsv(sv,del); 1395397 sv_catsv(sv,*mark); } } else { 3365838 for (; items > 0; items--,mark++) 1361190 sv_catsv(sv,*mark); } 790449 SvSETMAGIC(sv); } void Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) 582878 { 582878 STRLEN patlen; 582878 const char * const pat = SvPV_const(*sarg, patlen); 582878 bool do_taint = FALSE; 582878 SvUTF8_off(sv); 582878 if (DO_UTF8(*sarg)) 12 SvUTF8_on(sv); 582878 sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint); 582878 SvSETMAGIC(sv); 582878 if (do_taint) ###### SvTAINTED_on(sv); } /* currently converts input to bytes if possible, but doesn't sweat failure */ UV Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) 2310689 { 2310689 STRLEN srclen, len; 2310689 const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen); 2310689 UV retnum = 0; 2310689 if (offset < 0) 1 return retnum; 2310688 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ 5 Perl_croak(aTHX_ "Illegal number of bits in vec"); 2310683 if (SvUTF8(sv)) 4 (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE); 2310683 offset *= size; /* turn into bit offset */ 2310683 len = (offset + size + 7) / 8; /* required number of bytes */ 2310683 if (len > srclen) { 100509 if (size <= 8) 90404 retnum = 0; else { 10105 offset >>= 3; /* turn into byte offset */ 10105 if (size == 16) { 9838 if ((STRLEN)offset >= srclen) 9838 retnum = 0; else ###### retnum = (UV) s[offset] << 8; } 267 else if (size == 32) { 267 if ((STRLEN)offset >= srclen) 267 retnum = 0; ###### else if ((STRLEN)(offset + 1) >= srclen) ###### retnum = ((UV) s[offset ] << 24); ###### else if ((STRLEN)(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) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(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 } } 2210174 else if (size < 8) 1291377 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); else { 918797 offset >>= 3; /* turn into byte offset */ 918797 if (size == 8) 116064 retnum = s[offset]; 802733 else if (size == 16) 787142 retnum = ((UV) s[offset] << 8) + s[offset + 1]; 15591 else if (size == 32) 15591 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) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(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 } 2310683 return retnum; } /* currently converts input to bytes if possible but doesn't sweat failures, * although it does ensure that the string it clobbers is not marked as * utf8-valid any more */ void Perl_do_vecset(pTHX_ SV *sv) 1937936 { 1937936 SV *targ = LvTARG(sv); 1937936 register I32 offset; 1937936 register I32 size; 1937936 register unsigned char *s; 1937936 register UV lval; 1937936 I32 mask; 1937936 STRLEN targlen; 1937936 STRLEN len; 1937936 if (!targ) ###### return; 1937936 s = (unsigned char*)SvPV_force(targ, targlen); 1937936 if (SvUTF8(targ)) { /* This is handled by the SvPOK_only below... if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE)) SvUTF8_off(targ); */ 1 (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE); } 1937936 (void)SvPOK_only(targ); 1937936 lval = SvUV(sv); 1937936 offset = LvTARGOFF(sv); 1937936 if (offset < 0) 1 Perl_croak(aTHX_ "Negative offset to vec in lvalue context"); 1937935 size = LvTARGLEN(sv); 1937935 if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ ###### Perl_croak(aTHX_ "Illegal number of bits in vec"); 1937935 offset *= size; /* turn into bit offset */ 1937935 len = (offset + size + 7) / 8; /* required number of bytes */ 1937935 if (len > targlen) { 100501 s = (unsigned char*)SvGROW(targ, len + 1); 100501 (void)memzero((char *)(s + targlen), len - targlen + 1); 100501 SvCUR_set(targ, len); } 1937935 if (size < 8) { 1371724 mask = (1 << size) - 1; 1371724 size = offset & 7; 1371724 lval &= mask; 1371724 offset >>= 3; /* turn into byte offset */ 1371724 s[offset] &= ~(mask << size); 1371724 s[offset] |= lval << size; } else { 566211 offset >>= 3; /* turn into byte offset */ 566211 if (size == 8) 69279 s[offset ] = (U8)( lval & 0xff); 496932 else if (size == 16) { 484403 s[offset ] = (U8)((lval >> 8) & 0xff); 484403 s[offset+1] = (U8)( lval & 0xff); } 12529 else if (size == 32) { 12529 s[offset ] = (U8)((lval >> 24) & 0xff); 12529 s[offset+1] = (U8)((lval >> 16) & 0xff); 12529 s[offset+2] = (U8)((lval >> 8) & 0xff); 12529 s[offset+3] = (U8)( lval & 0xff); } #ifdef UV_IS_QUAD else if (size == 64) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "Bit vector size > 32 non-portable"); s[offset ] = (U8)((lval >> 56) & 0xff); s[offset+1] = (U8)((lval >> 48) & 0xff); s[offset+2] = (U8)((lval >> 40) & 0xff); s[offset+3] = (U8)((lval >> 32) & 0xff); s[offset+4] = (U8)((lval >> 24) & 0xff); s[offset+5] = (U8)((lval >> 16) & 0xff); s[offset+6] = (U8)((lval >> 8) & 0xff); s[offset+7] = (U8)( lval & 0xff); } #endif } 1937935 SvSETMAGIC(targ); } void Perl_do_chop(pTHX_ register SV *astr, register SV *sv) 52380 { 52380 STRLEN len; 52380 char *s; 52380 if (SvTYPE(sv) == SVt_PVAV) { 5 register I32 i; 5 AV* av = (AV*)sv; 5 const I32 max = AvFILL(av); 19 for (i = 0; i <= max; i++) { 14 sv = (SV*)av_fetch(av, i, FALSE); 14 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) 14 do_chop(astr, sv); } 52375 return; } 52375 else if (SvTYPE(sv) == SVt_PVHV) { ###### HV* hv = (HV*)sv; ###### HE* entry; ###### (void)hv_iterinit(hv); ###### while ((entry = hv_iternext(hv))) ###### do_chop(astr,hv_iterval(hv,entry)); 52375 return; } 52375 else if (SvREADONLY(sv)) { 4 if (SvFAKE(sv)) { /* SV is copy-on-write */ 3 sv_force_normal_flags(sv, 0); } 4 if (SvREADONLY(sv)) 1 Perl_croak(aTHX_ PL_no_modify); } 52374 s = SvPV(sv, len); 52356 if (len && !SvPOK(sv)) 504 s = SvPV_force(sv, len); 52356 if (DO_UTF8(sv)) { 257 if (s && len) { 257 char *send = s + len; 257 char *start = s; 257 s = send - 1; 515 while (s > start && UTF8_IS_CONTINUATION(*s)) 258 s--; 257 if (utf8_to_uvchr((U8*)s, 0)) { 257 sv_setpvn(astr, s, send - s); 257 *s = '\0'; 257 SvCUR_set(sv, s - start); 257 SvNIOK_off(sv); 257 SvUTF8_on(astr); } } else ###### sv_setpvn(astr, "", 0); } 52099 else if (s && len) { 51979 s += --len; 51979 sv_setpvn(astr, s, 1); 51979 *s = '\0'; 51979 SvCUR_set(sv, len); 51979 SvUTF8_off(sv); 51979 SvNIOK_off(sv); } else 120 sv_setpvn(astr, "", 0); 52356 SvSETMAGIC(sv); } I32 Perl_do_chomp(pTHX_ register SV *sv) 250958 { 250958 register I32 count; 250958 STRLEN len; 250958 char *s; 250958 char *temp_buffer = NULL; 250958 SV* svrecode = Nullsv; 250958 if (RsSNARF(PL_rs)) 1 return 0; 250957 if (RsRECORD(PL_rs)) 1 return 0; 250956 count = 0; 250956 if (SvTYPE(sv) == SVt_PVAV) { 1129 register I32 i; 1129 AV* av = (AV*)sv; 1129 const I32 max = AvFILL(av); 7934 for (i = 0; i <= max; i++) { 6805 sv = (SV*)av_fetch(av, i, FALSE); 6805 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) 6805 count += do_chomp(sv); } 1129 return count; } 249827 else if (SvTYPE(sv) == SVt_PVHV) { ###### HV* hv = (HV*)sv; ###### HE* entry; ###### (void)hv_iterinit(hv); ###### while ((entry = hv_iternext(hv))) ###### count += do_chomp(hv_iterval(hv,entry)); ###### return count; } 249827 else if (SvREADONLY(sv)) { 3 if (SvFAKE(sv)) { /* SV is copy-on-write */ 3 sv_force_normal_flags(sv, 0); } 3 if (SvREADONLY(sv)) ###### Perl_croak(aTHX_ PL_no_modify); } 249827 if (PL_encoding) { 421 if (!SvUTF8(sv)) { /* XXX, here sv is utf8-ized as a side-effect! If encoding.pm is used properly, almost string-generating operations, including literal strings, chr(), input data, etc. should have been utf8-ized already, right? */ 105 sv_recode_to_utf8(sv, PL_encoding); } } 249827 s = SvPV(sv, len); 249826 if (s && len) { 239658 s += --len; 239658 if (RsPARA(PL_rs)) { 4 if (*s != '\n') 1 goto nope; 3 ++count; 8 while (len && s[-1] == '\n') { 5 --len; 5 --s; 5 ++count; } } else { 239654 STRLEN rslen, rs_charlen; 239654 const char *rsptr = SvPV_const(PL_rs, rslen); 239654 rs_charlen = SvUTF8(PL_rs) ? sv_len_utf8(PL_rs) : rslen; 239654 if (SvUTF8(PL_rs) != SvUTF8(sv)) { /* Assumption is that rs is shorter than the scalar. */ 680 if (SvUTF8(PL_rs)) { /* RS is utf8, scalar is 8 bit. */ 374 bool is_utf8 = TRUE; 374 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr, &rslen, &is_utf8); 374 if (is_utf8) { /* Cannot downgrade, therefore cannot possibly match */ 7 assert (temp_buffer == rsptr); 7 temp_buffer = NULL; 7 goto nope; } 367 rsptr = temp_buffer; } 306 else if (PL_encoding) { /* RS is 8 bit, encoding.pm is used. * Do not recode PL_rs as a side-effect. */ 290 svrecode = newSVpvn(rsptr, rslen); 290 sv_recode_to_utf8(svrecode, PL_encoding); 290 rsptr = SvPV_const(svrecode, rslen); 290 rs_charlen = sv_len_utf8(svrecode); } else { /* RS is 8 bit, scalar is utf8. */ 16 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen); 16 rsptr = temp_buffer; } } 239647 if (rslen == 1) { 239410 if (*s != *rsptr) 141716 goto nope; 97694 ++count; } else { 237 if (len < rslen - 1) 12 goto nope; 225 len -= rslen - 1; 225 s -= rslen - 1; 225 if (memNE(s, rsptr, rslen)) 99 goto nope; 126 count += rs_charlen; } } 97823 s = SvPV_force_nolen(sv); 97823 SvCUR_set(sv, len); 97823 *SvEND(sv) = '\0'; 97823 SvNIOK_off(sv); 97823 SvSETMAGIC(sv); } nope: 249826 if (svrecode) 290 SvREFCNT_dec(svrecode); 249826 Safefree(temp_buffer); 249826 return count; } void Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) 34510 { #ifdef LIBERAL 34510 register long *dl; 34510 register long *ll; 34510 register long *rl; #endif 34510 register char *dc; 34510 STRLEN leftlen; 34510 STRLEN rightlen; 34510 register const char *lc; 34510 register const char *rc; 34510 register I32 len; 34510 I32 lensave; 34510 const char *lsave; 34510 const char *rsave; 34510 const bool left_utf = DO_UTF8(left); 34510 const bool right_utf = DO_UTF8(right); 34510 I32 needlen = 0; 34510 if (left_utf && !right_utf) ###### sv_utf8_upgrade(right); 34510 else if (!left_utf && right_utf) 1 sv_utf8_upgrade(left); 34510 if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) 7594 sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */ 34510 lsave = lc = SvPV_nomg_const(left, leftlen); 34510 rsave = rc = SvPV_nomg_const(right, rightlen); 34510 len = leftlen < rightlen ? leftlen : rightlen; 34510 lensave = len; 34510 if ((left_utf || right_utf) && (sv == left || sv == right)) { 3 needlen = optype == OP_BIT_AND ? len : leftlen + rightlen; 3 Newz(801, dc, needlen + 1, char); } 34507 else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { 34503 STRLEN n_a; 34503 dc = SvPV_force_nomg(sv, n_a); 34503 if (SvCUR(sv) < (STRLEN)len) { 7583 dc = SvGROW(sv, (STRLEN)(len + 1)); 7583 (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } 34503 if (optype != OP_BIT_AND && (left_utf || right_utf)) 2184 dc = SvGROW(sv, leftlen + rightlen + 1); } else { 4 needlen = ((optype == OP_BIT_AND) ? len : (leftlen > rightlen ? leftlen : rightlen)); 4 Newz(801, dc, needlen + 1, char); 4 (void)sv_usepvn(sv, dc, needlen); 4 dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ } 34510 SvCUR_set(sv, len); 34510 (void)SvPOK_only(sv); 34510 if (left_utf || right_utf) { 4368 UV duc, luc, ruc; 4368 char *dcsave = dc; 4368 STRLEN lulen = leftlen; 4368 STRLEN rulen = rightlen; 4368 STRLEN ulen; 4368 switch (optype) { case OP_BIT_AND: 4366 while (lulen && rulen) { 2184 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); 2184 lc += ulen; 2184 lulen -= ulen; 2184 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); 2184 rc += ulen; 2184 rulen -= ulen; 2184 duc = luc & ruc; 2184 dc = (char*)uvchr_to_utf8((U8*)dc, duc); } 2182 if (sv == left || sv == right) 1 (void)sv_usepvn(sv, dcsave, needlen); 2182 SvCUR_set(sv, dc - dcsave); 2182 break; case OP_BIT_XOR: 11 while (lulen && rulen) { 7 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); 7 lc += ulen; 7 lulen -= ulen; 7 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); 7 rc += ulen; 7 rulen -= ulen; 7 duc = luc ^ ruc; 7 dc = (char*)uvchr_to_utf8((U8*)dc, duc); } 2182 goto mop_up_utf; case OP_BIT_OR: 4367 while (lulen && rulen) { 2185 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); 2185 lc += ulen; 2185 lulen -= ulen; 2185 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); 2185 rc += ulen; 2185 rulen -= ulen; 2185 duc = luc | ruc; 2185 dc = (char*)uvchr_to_utf8((U8*)dc, duc); } mop_up_utf: 2186 if (sv == left || sv == right) 2 (void)sv_usepvn(sv, dcsave, needlen); 2186 SvCUR_set(sv, dc - dcsave); 2186 if (rulen) 1 sv_catpvn(sv, rc, rulen); 2185 else if (lulen) 1 sv_catpvn(sv, lc, lulen); else 2184 *SvEND(sv) = '\0'; break; } 4368 SvUTF8_on(sv); 4368 goto finish; } else #ifdef LIBERAL 30142 if (len >= sizeof(long)*4 && !((long)dc % sizeof(long)) && !((long)lc % sizeof(long)) && !((long)rc % sizeof(long))) /* It's almost always aligned... */ { 1185 const I32 remainder = len % (sizeof(long)*4); 1185 len /= (sizeof(long)*4); 1185 dl = (long*)dc; 1185 ll = (long*)lc; 1185 rl = (long*)rc; 1185 switch (optype) { case OP_BIT_AND: 33 while (len--) { 19 *dl++ = *ll++ & *rl++; 19 *dl++ = *ll++ & *rl++; 19 *dl++ = *ll++ & *rl++; 19 *dl++ = *ll++ & *rl++; } 2 break; case OP_BIT_XOR: 8 while (len--) { 6 *dl++ = *ll++ ^ *rl++; 6 *dl++ = *ll++ ^ *rl++; 6 *dl++ = *ll++ ^ *rl++; 6 *dl++ = *ll++ ^ *rl++; } 1169 break; case OP_BIT_OR: 2345 while (len--) { 1176 *dl++ = *ll++ | *rl++; 1176 *dl++ = *ll++ | *rl++; 1176 *dl++ = *ll++ | *rl++; 1176 *dl++ = *ll++ | *rl++; } } 1185 dc = (char*)dl; 1185 lc = (char*)ll; 1185 rc = (char*)rl; 1185 len = remainder; } #endif { 30142 switch (optype) { case OP_BIT_AND: 20377 while (len--) 18623 *dc++ = *lc++ & *rc++; 59 break; case OP_BIT_XOR: 168 while (len--) 109 *dc++ = *lc++ ^ *rc++; 28329 goto mop_up; case OP_BIT_OR: 258124 while (len--) 229795 *dc++ = *lc++ | *rc++; mop_up: 28388 len = lensave; 28388 if (rightlen > (STRLEN)len) 298 sv_catpvn(sv, rsave + len, rightlen - len); 28090 else if (leftlen > (STRLEN)len) 1626 sv_catpvn(sv, lsave + len, leftlen - len); else 26464 *SvEND(sv) = '\0'; break; } } finish: 34510 SvTAINT(sv); } OP * Perl_do_kv(pTHX) 162614 { 162614 dSP; 162614 HV *hv = (HV*)POPs; 162614 HV *keys; 162614 register HE *entry; 162614 const I32 gimme = GIMME_V; 162614 const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV); 162614 const I32 dokeys = dokv || (PL_op->op_type == OP_KEYS); 162614 const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES); 162614 if (!hv) { ###### if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ ###### dTARGET; /* make sure to clear its target here */ ###### if (SvTYPE(TARG) == SVt_PVLV) ###### LvTARG(TARG) = Nullsv; ###### PUSHs(TARG); } ###### RETURN; } 162614 keys = hv; 162614 (void)hv_iterinit(keys); /* always reset iterator regardless */ 162614 if (gimme == G_VOID) 1215 RETURN; 161399 if (gimme == G_SCALAR) { 2513 IV i; 2513 dTARGET; 2513 if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ 16 if (SvTYPE(TARG) < SVt_PVLV) { 16 sv_upgrade(TARG, SVt_PVLV); 16 sv_magic(TARG, Nullsv, PERL_MAGIC_nkeys, Nullch, 0); } 16 LvTYPE(TARG) = 'k'; 16 if (LvTARG(TARG) != (SV*)keys) { 16 if (LvTARG(TARG)) ###### SvREFCNT_dec(LvTARG(TARG)); 16 LvTARG(TARG) = SvREFCNT_inc(keys); } 16 PUSHs(TARG); 16 RETURN; } 2497 if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied)) 2484 i = HvKEYS(keys); else { 13 i = 0; 1068 while (hv_iternext(keys)) i++; } 2497 PUSHi( i ); 2497 RETURN; } 158886 EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues)); 158886 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */ 2442128 while ((entry = hv_iternext(keys))) { 2283242 SPAGAIN; 2283242 if (dokeys) { 2250978 SV* sv = hv_iterkeysv(entry); 2250978 XPUSHs(sv); /* won't clobber stack_sp */ } 2283242 if (dovalues) { 273576 SV *tmpstr; 273576 PUTBACK; 273576 tmpstr = hv_iterval(hv,entry); DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu", (unsigned long)HeHASH(entry), (int)HvMAX(keys)+1, 273576 (unsigned long)(HeHASH(entry) & HvMAX(keys)))); 273576 SPAGAIN; 273576 XPUSHs(tmpstr); } 2283242 PUTBACK; } 158886 return NORMAL; } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */