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.
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;
}
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':
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;
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");
}
break;
#else
- /* Fall through! */
+ /* FALLTHROUGH */
#endif
case 'S':
while (len-- > 0) {
}
break;
#else
- /* Fall through! */
+ /* FALLTHROUGH */
#endif
case 's':
while (len-- > 0) {
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;