X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/041457d90dbb6fb79a72c7a8462f01423f2daa09..c0e08cf6f1fc66c8b78e47112b803770d4cc7e4a:/pp_pack.c diff --git a/pp_pack.c b/pp_pack.c index 63a60f1..51b42d9 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -1,7 +1,7 @@ /* pp_pack.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -62,7 +62,7 @@ typedef struct tempsym { (symptr)->grpend = NULL; \ (symptr)->code = 0; \ (symptr)->length = 0; \ - (symptr)->howlen = 0; \ + (symptr)->howlen = e_no_len; \ (symptr)->level = 0; \ (symptr)->flags = (f); \ (symptr)->strbeg = 0; \ @@ -179,7 +179,7 @@ S_mul128(pTHX_ SV *sv, U8 m) char *t; if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ - SV *tmpNew = newSVpvn("0000000000", 10); + SV * const tmpNew = newSVpvs("0000000000"); sv_catsv(tmpNew, sv); SvREFCNT_dec(sv); /* free old sv */ @@ -240,6 +240,8 @@ S_mul128(pTHX_ SV *sv, U8 m) # define DO_BO_PACK_N(var, type) # define DO_BO_UNPACK_P(var) # define DO_BO_PACK_P(var) +# define DO_BO_UNPACK_PC(var) +# define DO_BO_PACK_PC(var) #else /* PERL_PACK_CAN_BYTEORDER */ @@ -320,9 +322,16 @@ S_mul128(pTHX_ SV *sv, U8 m) # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void) # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char) # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char) +# elif PTRSIZE == IVSIZE +# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, IV, void) +# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, IV, void) +# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, IV, char) +# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, IV, char) # else # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer) # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer) +# define DO_BO_UNPACK_PC(var) BO_CANT_DOIT(unpack, pointer) +# define DO_BO_PACK_PC(var) BO_CANT_DOIT(pack, pointer) # endif # if defined(my_htolen) && defined(my_letohn) && \ @@ -365,7 +374,7 @@ S_mul128(pTHX_ SV *sv, U8 m) typedef U8 packprops_t; #if 'J'-'I' == 1 /* ASCII */ -const packprops_t packprops[512] = { +STATIC const packprops_t packprops[512] = { /* normal */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -486,7 +495,7 @@ const packprops_t packprops[512] = { }; #else /* EBCDIC (or bust) */ -const packprops_t packprops[512] = { +STATIC const packprops_t packprops[512] = { /* normal */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -608,9 +617,8 @@ const packprops_t packprops[512] = { STATIC U8 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) { - UV val; STRLEN retlen; - val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, + UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); /* We try to process malformed UTF-8 as much as possible (preferrably with warnings), but these two mean we make no progress in the string and @@ -681,9 +689,9 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len STATIC bool next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) { - UV val; + dVAR; STRLEN retlen; - val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); + const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); if (val >= 0x100 || !ISUUCHAR(val) || retlen == (STRLEN) -1 || retlen == 0) { *out = 0; @@ -694,34 +702,27 @@ next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) return TRUE; } -STATIC void -bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char **dest) { - U8 buffer[UTF8_MAXLEN]; - const U8 *end = start + len; - char *d = *dest; +STATIC char * +S_bytes_to_uni(const U8 *start, STRLEN len, char *dest) { + const U8 * const end = start + len; + while (start < end) { - const int length = - uvuni_to_utf8_flags(buffer, NATIVE_TO_UNI(*start), 0) - buffer; - switch(length) { - case 1: - *d++ = buffer[0]; - break; - case 2: - *d++ = buffer[0]; - *d++ = buffer[1]; - break; - default: - Perl_croak(aTHX_ "Perl bug: value %d UTF-8 expands to %d bytes", - *start, length); + const UV uv = NATIVE_TO_ASCII(*start); + if (UNI_IS_INVARIANT(uv)) + *dest++ = (char)(U8)UTF_TO_NATIVE(uv); + else { + *dest++ = (char)(U8)UTF8_EIGHT_BIT_HI(uv); + *dest++ = (char)(U8)UTF8_EIGHT_BIT_LO(uv); } start++; } - *dest = d; + return dest; } #define PUSH_BYTES(utf8, cur, buf, len) \ STMT_START { \ - if (utf8) bytes_to_uni(aTHX_ (U8 *) buf, len, &(cur)); \ + if (utf8) \ + (cur) = bytes_to_uni((U8 *) buf, len, (cur)); \ else { \ Copy(buf, cur, len, char); \ (cur) += (len); \ @@ -733,7 +734,7 @@ STMT_START { \ STRLEN glen = (in_len); \ if (utf8) glen *= UTF8_EXPAND; \ if ((cur) + glen >= (start) + SvLEN(cat)) { \ - (start) = sv_exp_grow(aTHX_ cat, glen); \ + (start) = sv_exp_grow(cat, glen); \ (cur) = (start) + SvCUR(cat); \ } \ } STMT_END @@ -746,7 +747,7 @@ STMT_START { \ if ((cur) + gl >= (start) + SvLEN(cat)) { \ *cur = '\0'; \ SvCUR_set((cat), (cur) - (start)); \ - (start) = sv_exp_grow(aTHX_ cat, gl); \ + (start) = sv_exp_grow(cat, gl); \ (cur) = (start) + SvCUR(cat); \ } \ PUSH_BYTES(utf8, cur, buf, glen); \ @@ -756,7 +757,7 @@ STMT_START { \ STMT_START { \ if (utf8) { \ const U8 au8 = (byte); \ - bytes_to_uni(aTHX_ &au8, 1, &(s)); \ + (s) = bytes_to_uni(&au8, 1, (s)); \ } else *(U8 *)(s)++ = (byte); \ } STMT_END @@ -775,7 +776,7 @@ STMT_START { \ static const char *_action( const tempsym_t* symptr ) { - return ( symptr->flags & FLAG_PACK ) ? "pack" : "unpack"; + return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack"); } /* Returns the sizeof() struct described by pat */ @@ -939,7 +940,7 @@ STATIC bool S_next_symbol(pTHX_ tempsym_t* symptr ) { const char* patptr = symptr->patptr; - const char* patend = symptr->patend; + const char* const patend = symptr->patend; symptr->flags &= ~FLAG_SLASH; @@ -1116,7 +1117,6 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) version of the string. Users are advised to upgrade their pack string themselves if they need to do a lot of unpacks like this on it */ -/* XXX These can be const */ STATIC bool need_utf8(const char *pat, const char *patend) { @@ -1147,41 +1147,6 @@ first_symbol(const char *pat, const char *patend) { } /* -=for apidoc unpack_str - -The engine implementing unpack() Perl function. Note: parameters strbeg, new_s -and ocnt are not used. This call should not be used, use unpackstring instead. - -=cut */ - -I32 -Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags) -{ - tempsym_t sym; - PERL_UNUSED_ARG(strbeg); - PERL_UNUSED_ARG(new_s); - PERL_UNUSED_ARG(ocnt); - - if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; - else if (need_utf8(pat, patend)) { - /* We probably should try to avoid this in case a scalar context call - wouldn't get to the "U0" */ - STRLEN len = strend - s; - s = (char *) bytes_to_utf8((U8 *) s, &len); - SAVEFREEPV(s); - strend = s + len; - flags |= FLAG_DO_UTF8; - } - - if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) - flags |= FLAG_PARSE_UTF8; - - TEMPSYM_INIT(&sym, pat, patend, flags); - - return unpack_rec(&sym, s, s, strend, NULL ); -} - -/* =for apidoc unpackstring The engine implementing unpack() Perl function. C puts the @@ -1530,7 +1495,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; } - sv = sv_2mortal(NEWSV(35, len ? len : 1)); + sv = sv_2mortal(newSV(len ? len : 1)); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'b') { @@ -1567,7 +1532,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c /* Preliminary length estimate, acceptable for utf8 too */ if (howlen == e_star || len > (strend - s) * 2) len = (strend - s) * 2; - sv = sv_2mortal(NEWSV(35, len ? len : 1)); + sv = sv_2mortal(newSV(len ? len : 1)); SvPOK_on(sv); str = SvPVX(sv); if (datumtype == 'h') { @@ -2006,7 +1971,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (++bytes >= sizeof(UV)) { /* promote to string */ const char *t; - sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv); while (s < strend) { ch = SHIFT_BYTE(utf8, s, strend, datumtype); sv = mul128(sv, (U8)(ch & 0x7f)); @@ -2032,7 +1997,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (symptr->howlen == e_star) Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); EXTEND(SP, 1); - if (sizeof(char*) <= strend - s) { + if (s + sizeof(char*) <= strend) { char *aptr; SHIFT_VAR(utf8, s, strend, aptr, datumtype); DO_BO_UNPACK_PC(aptr); @@ -2123,20 +2088,20 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c * algorithm, the code will be character-set independent * (and just as fast as doing character arithmetic) */ - if (PL_uudmap['M'] == 0) { - int i; + if (PL_uudmap[(U8)'M'] == 0) { + size_t i; - for (i = 0; i < sizeof(PL_uuemap); i += 1) + for (i = 0; i < sizeof(PL_uuemap); ++i) PL_uudmap[(U8)PL_uuemap[i]] = i; /* * Because ' ' and '`' map to the same value, * we need to decode them both the same. */ - PL_uudmap[' '] = 0; + PL_uudmap[(U8)' '] = 0; } { const STRLEN l = (STRLEN) (strend - s) * 3 / 4; - sv = sv_2mortal(NEWSV(42, l)); + sv = sv_2mortal(newSV(l)); if (l) SvPOK_on(sv); } if (utf8) { @@ -2268,6 +2233,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c PP(pp_unpack) { + dVAR; dSP; dPOPPOPssrl; I32 gimme = GIMME_V; @@ -2386,47 +2352,26 @@ S_div128(pTHX_ SV *pnum, bool *done) } /* -=for apidoc pack_cat - -The engine implementing pack() Perl function. Note: parameters next_in_list and -flags are not used. This call should not be used; use packlist instead. - -=cut */ - - -void -Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) -{ - tempsym_t sym; - PERL_UNUSED_ARG(next_in_list); - PERL_UNUSED_ARG(flags); - - TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); - - (void)pack_rec( cat, &sym, beglist, endlist ); -} - - -/* =for apidoc packlist The engine implementing pack() Perl function. -=cut */ - +=cut +*/ void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist ) { - STRLEN no_len; + dVAR; tempsym_t sym; TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); /* We're going to do changes through SvPVX(cat). Make sure it's valid. Also make sure any UTF8 flag is loaded */ - SvPV_force(cat, no_len); - if (DO_UTF8(cat)) sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; + SvPV_force_nolen(cat); + if (DO_UTF8(cat)) + sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; (void)pack_rec( cat, &sym, beglist, endlist ); } @@ -2500,7 +2445,7 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { Only grows the string if there is an actual lack of space */ STATIC char * -sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { +S_sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { const STRLEN cur = SvCUR(sv); const STRLEN len = SvLEN(sv); STRLEN extend; @@ -2513,6 +2458,7 @@ STATIC SV ** S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) { + dVAR; tempsym_t lookahead; I32 items = endlist - beglist; bool found = next_symbol(symptr); @@ -2530,7 +2476,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) SV *fromstr; STRLEN fromlen; I32 len; - SV *lengthcode = Nullsv; + SV *lengthcode = NULL; I32 datumtype = symptr->code; howlen_t howlen = symptr->howlen; char *start = SvPVX(cat); @@ -2568,9 +2514,20 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (strchr("aAZ", lookahead.code)) { if (lookahead.howlen == e_number) count = lookahead.length; else { - if (items > 0) + if (items > 0) { + if (SvGAMAGIC(*beglist)) { + /* Avoid reading the active data more than once + by copying it to a temporary. */ + STRLEN len; + const char *const pv = SvPV_const(*beglist, len); + SV *const temp = sv_2mortal(newSVpvn(pv, len)); + if (SvUTF8(*beglist)) + SvUTF8_on(temp); + *beglist = temp; + } count = DO_UTF8(*beglist) ? sv_len_utf8(*beglist) : sv_len(*beglist); + } else count = 0; if (lookahead.code == 'Z') count++; } @@ -2673,6 +2630,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (savsym.howlen == e_star && beglist == endlist) break; /* No way to continue */ } + items = endlist - beglist; lookahead.flags = symptr->flags & ~group_modifiers; goto no_change; } @@ -2857,7 +2815,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (datumtype == 'B') while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); bits |= val & 1; } else bits |= *str++ & 1; @@ -2871,7 +2829,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) /* datumtype == 'b' */ while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); if (val & 1) bits |= 0x80; } else if (*str++ & 1) @@ -2926,7 +2884,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (datumtype == 'H') while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); if (val < 256 && isALPHA(val)) bits |= (val + 9) & 0xf; @@ -2945,7 +2903,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) else while (l++ < len) { if (utf8_source) { - UV val; + UV val = 0; NEXT_UNI_VAL(val, cur, str, end, utf8_flags); if (val < 256 && isALPHA(val)) bits |= ((val + 9) & 0xf) << 4; @@ -2983,7 +2941,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) ckWARN(WARN_PACK)) Perl_warner(aTHX_ packWARN(WARN_PACK), "Character in 'c' format wrapped in pack"); - PUSH_BYTE(utf8, cur, aiv & 0xff); + PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); } break; case 'C': @@ -3000,12 +2958,12 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) ckWARN(WARN_PACK)) Perl_warner(aTHX_ packWARN(WARN_PACK), "Character in 'C' format wrapped in pack"); - *cur++ = aiv & 0xff; + *cur++ = (char)(aiv & 0xff); } break; case 'W': { char *end; - U8 in_bytes = IN_BYTES; + U8 in_bytes = (U8)IN_BYTES; end = start+SvLEN(cat)-1; if (utf8) end -= UTF8_MAXLEN-1; @@ -3088,7 +3046,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) len+(endb-buffer)*UTF8_EXPAND); end = start+SvLEN(cat); } - bytes_to_uni(aTHX_ buffer, endb-buffer, &cur); + cur = bytes_to_uni(buffer, endb-buffer, cur); } else { if (cur >= end) { *cur = '\0'; @@ -3518,7 +3476,6 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) SvGETMAGIC(fromstr); if (!SvOK(fromstr)) aptr = NULL; else { - STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are @@ -3530,9 +3487,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) "Attempt to pack pointer to temporary value"); } if (SvPOK(fromstr) || SvNIOK(fromstr)) - aptr = SvPV_nomg_const(fromstr, n_a); + aptr = SvPV_nomg_const_nolen(fromstr); else - aptr = SvPV_force_flags(fromstr, n_a, 0); + aptr = SvPV_force_flags_nolen(fromstr, 0); } DO_BO_PACK_PC(aptr); PUSH_VAR(utf8, cur, aptr); @@ -3546,7 +3503,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (len <= 2) len = 45; else len = len / 3 * 3; if (len >= 64) { - Perl_warner(aTHX_ packWARN(WARN_PACK), + if (ckWARN(WARN_PACK)) + Perl_warner(aTHX_ packWARN(WARN_PACK), "Field too wide in 'u' format in pack"); len = 63; } @@ -3597,7 +3555,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) PP(pp_pack) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; STRLEN fromlen; SV *pat_sv = *++MARK;