X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_pack.c;h=92d0a36a55a627da4f934d697c9e1bf40b6a2127;hb=c067b4bea65bd7b97b0ae4f7b058dd94b44a4c48;hp=11a1ed64b012e33bbaa7e6bba06834041a44371e;hpb=8b6e33c7886a0f01211e87223fa130b968e1d3a2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_pack.c b/pp_pack.c index 11a1ed6..92d0a36 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -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 */ @@ -323,6 +325,8 @@ S_mul128(pTHX_ SV *sv, U8 m) # 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) && \ @@ -1024,8 +1028,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 +1120,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) { @@ -1159,9 +1161,9 @@ 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; - (void)strbeg; - (void)new_s; - (void)ocnt; + 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)) { @@ -1492,7 +1494,7 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (checksum) { if (!PL_bitcount) { int bits; - Newz(601, PL_bitcount, 256, char); + Newxz(PL_bitcount, 256, char); for (bits = 1; bits < 256; bits++) { if (bits & 1) PL_bitcount[bits]++; if (bits & 2) PL_bitcount[bits]++; @@ -2392,15 +2394,15 @@ 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) { tempsym_t sym; - (void)next_in_list; - (void)flags; + PERL_UNUSED_ARG(next_in_list); + PERL_UNUSED_ARG(flags); TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); @@ -2413,8 +2415,8 @@ 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 ) @@ -2427,7 +2429,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 ); } @@ -2453,11 +2456,11 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { } len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1; - New('U', to_start, len, char); + Newx(to_start, len, char); Copy(from_start, to_start, from_ptr-from_start, char); to_ptr = to_start + (from_ptr-from_start); - New('U', marks, sym_ptr->level+2, const char *); + Newx(marks, sym_ptr->level+2, const char *); for (group=sym_ptr; group; group = group->previous) marks[group->level] = from_start + group->strbeg; marks[sym_ptr->level+1] = from_end+1; @@ -2518,6 +2521,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 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); @@ -2832,18 +2836,18 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) } case 'B': case 'b': { - char *str, *end; + const char *str, *end; I32 l, field_len; U8 bits; bool utf8_source; U32 utf8_flags; fromstr = NEXTFROM; - str = SvPV(fromstr, fromlen); + str = SvPV_const(fromstr, fromlen); 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 +2916,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 */ @@ -3025,7 +3029,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 +3083,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 +3101,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); } } @@ -3388,11 +3392,11 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) w_string: /* Copy string and check for compliance */ - from = SvPV(fromstr, len); + from = SvPV_const(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); - New('w', result, len, char); + Newx(result, len, char); in = result + len; done = FALSE; while (!done) *--in = div128(norm, &done) | 0x80; @@ -3518,22 +3522,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); @@ -3601,7 +3603,8 @@ PP(pp_pack) dSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; STRLEN fromlen; - register const char *pat = SvPVx_const(*++MARK, fromlen); + SV *pat_sv = *++MARK; + register const char *pat = SvPV_const(pat_sv, fromlen); register const char *patend = pat + fromlen; MARK++;