X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_pack.c;h=72f8c0e714fe2e095234839879c08627871d7801;hb=b6c2855378a705b6278bd4e260febb2b484b9fcd;hp=2bcb731f68accb80e5fb3662606a7606582ad8b3;hpb=a02a5408b2f199007c4dcb74559cc79066307ada;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_pack.c b/pp_pack.c index 2bcb731..72f8c0e 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. @@ -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; @@ -697,7 +705,7 @@ next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) STATIC void bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char **dest) { U8 buffer[UTF8_MAXLEN]; - const U8 *end = start + len; + const U8 * const end = start + len; char *d = *dest; while (start < end) { const int length = @@ -733,7 +741,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 +754,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); \ @@ -939,7 +947,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; @@ -1024,8 +1032,7 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s", *patptr, _action( symptr ) ); - if (ckWARN(WARN_UNPACK)) { - if (code & modifier) + if ((code & modifier) && ckWARN(WARN_UNPACK)) { Perl_warner(aTHX_ packWARN(WARN_UNPACK), "Duplicate modifier '%c' after '%c' in %s", *patptr, (int) TYPE_NO_MODIFIERS(code), @@ -1117,7 +1124,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) { @@ -2033,7 +2039,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); @@ -2125,9 +2131,9 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c * (and just as fast as doing character arithmetic) */ if (PL_uudmap['M'] == 0) { - int i; + 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, @@ -2269,6 +2275,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; @@ -2392,8 +2399,8 @@ S_div128(pTHX_ SV *pnum, bool *done) 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 */ - +=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) @@ -2413,12 +2420,13 @@ Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV ** 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 ) { + dVAR; STRLEN no_len; tempsym_t sym; @@ -2427,7 +2435,8 @@ Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV ** /* 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; + if (DO_UTF8(cat)) + sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; (void)pack_rec( cat, &sym, beglist, endlist ); } @@ -2501,7 +2510,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; @@ -2514,10 +2523,12 @@ 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); bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; + bool warn_utf8 = ckWARN(WARN_UTF8); if (symptr->level == 0 && found && symptr->code == 'U') { marked_upgrade(aTHX_ cat, symptr); @@ -2843,7 +2854,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) end = str + fromlen; if (DO_UTF8(fromstr)) { utf8_source = TRUE; - utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; + utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; } else { utf8_source = FALSE; utf8_flags = 0; /* Unused, but keep compilers happy */ @@ -2912,7 +2923,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) end = str + fromlen; if (DO_UTF8(fromstr)) { utf8_source = TRUE; - utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; + utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; } else { utf8_source = FALSE; utf8_flags = 0; /* Unused, but keep compilers happy */ @@ -2983,7 +2994,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,7 +3011,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"); - *cur++ = aiv & 0xff; + *cur++ = (char)(aiv & 0xff); } break; case 'W': { @@ -3025,7 +3036,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) } cur = (char *) uvuni_to_utf8_flags((U8 *) cur, NATIVE_TO_UNI(auv), - ckWARN(WARN_UTF8) ? + warn_utf8 ? 0 : UNICODE_ALLOW_ANY); } else { if (auv >= 0x100) { @@ -3079,7 +3090,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (utf8) { U8 buffer[UTF8_MAXLEN], *endb; endb = uvuni_to_utf8_flags(buffer, auv, - ckWARN(WARN_UTF8) ? + warn_utf8 ? 0 : UNICODE_ALLOW_ANY); if (cur+(endb-buffer)*UTF8_EXPAND >= end) { *cur = '\0'; @@ -3097,7 +3108,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) end = start+SvLEN(cat)-UTF8_MAXLEN; } cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv, - ckWARN(WARN_UTF8) ? + warn_utf8 ? 0 : UNICODE_ALLOW_ANY); } } @@ -3518,22 +3529,20 @@ 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 * gone. */ - if (ckWARN(WARN_PACK) && - (SvTEMP(fromstr) || (SvPADTMP(fromstr) && - !SvREADONLY(fromstr)))) { + if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) && + !SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) { Perl_warner(aTHX_ packWARN(WARN_PACK), "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); @@ -3547,7 +3556,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; } @@ -3598,7 +3608,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;