const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
if (ptr >= end) break;
- utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags);
+ utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags);
}
if (from > end) from = end;
}
STATIC bool
next_uni_uu(pTHX_ const char **s, const char *end, I32 *out)
{
- dVAR;
STRLEN retlen;
const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY);
if (val >= 0x100 || !ISUUCHAR(val) ||
case e_star:
Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
_action( symptr ) );
- break;
+
default:
/* e_no_len and e_number */
len = symptr->length;
if (!len) /* Avoid division by 0 */
len = 1;
len = total % len; /* Assumed: the start is aligned. */
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'X':
size = -1;
if (total < len)
len = len - star;
else
len = 0;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'x':
case 'A':
case 'Z':
}
Perl_croak(aTHX_ "No group ending character '%c' found in template",
ender);
- return 0;
+ NOT_REACHED; /* NOTREACHED */
}
}
/*
+
+=head1 Pack and Unpack
+
=for apidoc unpackstring
The engine implementing the unpack() Perl function.
Using the template pat..patend, this function unpacks the string
s..strend into a number of mortal SVs, which it pushes onto the perl
argument (@_) stack (so you will need to issue a C<PUTBACK> before and
-C<SPAGAIN> after the call to this function). It returns the number of
+C<SPAGAIN> after the call to this function). It returns the number of
pushed elements.
The strend and patend pointers should point to the byte following the last
STATIC I32
S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
{
- dVAR; dSP;
+ dSP;
SV *sv = NULL;
const I32 start_sp_offset = SP - PL_stack_base;
howlen_t howlen;
cuv = 0;
cdouble = 0;
continue;
- break;
+
case '(':
{
tempsym_t savsym = *symptr;
break;
}
len = (s - strbeg) % len;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'X':
if (utf8) {
while (len > 0) {
if (ai32 == 0) break;
len -= ai32;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'x':
if (utf8) {
while (len>0) {
break;
case '/':
Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
- break;
+
case 'A':
case 'Z':
case 'a':
utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'c':
while (len-- > 0 && s < strend) {
int aint;
len = UTF8SKIP(result);
if (!uni_to_bytes(aTHX_ &ptr, strend,
(char *) &result[1], len-1, 'U')) break;
- auv = utf8n_to_uvuni(result, len, &retlen, UTF8_ALLOW_DEFAULT);
+ auv = utf8n_to_uvchr(result, len, &retlen, UTF8_ALLOW_DEFAULT);
s = ptr;
} else {
- auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT);
+ auv = utf8n_to_uvchr((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT);
if (retlen == (STRLEN) -1 || retlen == 0)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
}
break;
#else
- /* Fallthrough! */
+ /* FALLTHROUGH */
#endif
case 's':
while (len-- > 0) {
}
break;
#else
- /* Fallthrough! */
+ /* FALLTHROUGH */
#endif
case 'v':
case 'n':
}
break;
#else
- /* Fallthrough! */
+ /* FALLTHROUGH */
#endif
case 'l':
while (len-- > 0) {
}
break;
#else
- /* Fall through! */
+ /* FALLTHROUGH */
#endif
case 'V':
case 'N':
PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
}
break;
-#ifdef HAS_QUAD
+#if defined(HAS_QUAD) && IVSIZE >= 8
case 'q':
while (len-- > 0) {
Quad_t aquad;
SHIFT_VAR(utf8, s, strend, aquad, datumtype, needs_swap);
if (!checksum)
- mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
- newSViv((IV)aquad) : newSVnv((NV)aquad));
+ mPUSHs(newSViv((IV)aquad));
else if (checksum > bits_in_uv)
cdouble += (NV)aquad;
else
Uquad_t auquad;
SHIFT_VAR(utf8, s, strend, auquad, datumtype, needs_swap);
if (!checksum)
- mPUSHs(auquad <= UV_MAX ?
- newSVuv((UV)auquad) : newSVnv((NV)auquad));
+ mPUSHs(newSVuv((UV)auquad));
else if (checksum > bits_in_uv)
cdouble += (NV)auquad;
else
cuv += auquad;
}
break;
-#endif /* HAS_QUAD */
+#endif
/* float and double added gnb@melba.bby.oz.au 22/11/89 */
case 'f':
while (len-- > 0) {
ld_bytes aldouble;
SHIFT_BYTES(utf8, s, strend, aldouble.bytes,
sizeof(aldouble.bytes), datumtype, needs_swap);
+ /* The most common long double format, the x86 80-bit
+ * extended precision, has either 2 or 6 unused bytes,
+ * which may contain garbage, which may contain
+ * unintentional data. While we do zero the bytes of
+ * the long double data in pack(), here in unpack() we
+ * don't, because it's really hard to envision that
+ * reading the long double off aldouble would be
+ * affected by the unused bytes.
+ *
+ * Note that trying to unpack 'long doubles' of 'long
+ * doubles' packed in another system is in the general
+ * case doomed without having more detail. */
if (!checksum)
mPUSHn(aldouble.ld);
else
PP(pp_unpack)
{
- dVAR;
dSP;
dPOPPOPssrl;
I32 gimme = GIMME_V;
void
Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
{
- dVAR;
tempsym_t sym;
PERL_ARGS_ASSERT_PACKLIST;
from_start = SvPVX_const(sv);
from_end = from_start + SvCUR(sv);
for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
- if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
+ if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break;
if (from_ptr == from_end) {
/* Simple case: no character needs to be changed */
SvUTF8_on(sv);
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);
+ char* from;
PERL_ARGS_ASSERT_PACK_REC;
(int) TYPE_NO_MODIFIERS(datumtype));
case '%':
Perl_croak(aTHX_ "'%%' may not be used in pack");
- {
- char *from;
+
case '.' | TYPE_IS_SHRIEKING:
case '.':
if (howlen == e_star) from = start;
goto shrink;
}
break;
- }
+
case '(': {
tempsym_t savsym = *symptr;
U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
break;
}
len = (cur-start) % len;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'X':
if (utf8) {
if (len < 1) goto no_change;
if (ai32 == 0) goto no_change;
len -= ai32;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case 'x':
goto grow;
case 'A':
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
- aiv = SvIV(fromstr);
+ if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
+ /* 255 is a pretty arbitrary choice, but with
+ * inf/-inf/nan and 256 bytes there is not much room. */
+ aiv = 255;
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'c' format overflow in pack");
+ }
+ else
+ aiv = SvIV(fromstr);
if ((-128 > aiv || aiv > 127))
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Character in 'c' format wrapped in pack");
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
- aiv = SvIV(fromstr);
+ if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
+ /* See the 'c' case. */
+ aiv = 255;
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'C' format overflow in pack");
+ }
+ else
+ aiv = SvIV(fromstr);
if ((0 > aiv || aiv > 0xff))
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Character in 'C' format wrapped in pack");
GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
end = start+SvLEN(cat)-UTF8_MAXLEN;
}
- cur = (char *) uvuni_to_utf8_flags((U8 *) cur,
- NATIVE_TO_UNI(auv),
+ cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
+ auv,
warn_utf8 ?
0 : UNICODE_ALLOW_ANY);
} else {
auv = SvUV(fromstr);
if (utf8) {
U8 buffer[UTF8_MAXLEN], *endb;
- endb = uvuni_to_utf8_flags(buffer, auv,
+ endb = uvchr_to_utf8_flags(buffer, auv,
warn_utf8 ?
0 : UNICODE_ALLOW_ANY);
if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
end = start+SvLEN(cat)-UTF8_MAXLEN;
}
- cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv,
+ cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv,
warn_utf8 ?
0 : UNICODE_ALLOW_ANY);
}
}
break;
#else
- /* Fall through! */
+ /* FALLTHROUGH */
#endif
case 'S':
while (len-- > 0) {
}
break;
#else
- /* Fall through! */
+ /* FALLTHROUGH */
#endif
case 's':
while (len-- > 0) {
PUSH32(utf8, cur, &ai32, needs_swap);
}
break;
-#ifdef HAS_QUAD
+#if defined(HAS_QUAD) && IVSIZE >= 8
case 'Q':
while (len-- > 0) {
Uquad_t auquad;
PUSH_VAR(utf8, cur, aquad, needs_swap);
}
break;
-#endif /* HAS_QUAD */
+#endif
case 'P':
len = 1; /* assume SV is correct length */
GROWING(utf8, cat, start, cur, sizeof(char *));
- /* Fall through! */
+ /* FALLTHROUGH */
case 'p':
while (len-- > 0) {
const char *aptr;
PP(pp_pack)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SV *cat = TARG;
STRLEN fromlen;
SV *pat_sv = *++MARK;
https://perl5.git.perl.org / perl5.git / blobdiff