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':
PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
}
break;
-#if IVSIZE >= 8
+#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
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;
bool needs_swap;
#define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
+#define PEEKFROM (lengthcode ? lengthcode : items > 0 ? *beglist : &PL_sv_no)
switch (howlen) {
case e_star:
needs_swap = NEEDS_SWAP(datumtype);
+ fromstr = PEEKFROM;
+ if (SvNOK(fromstr)) {
+ const NV nv = SvNV(fromstr);
+ const char c = TYPE_NO_MODIFIERS(datumtype);
+ if (Perl_isinfnan(nv) && !strchr("fdFD", c)) {
+ if (c == 'w')
+ Perl_croak(aTHX_ "Cannot compress %"NVgf, nv);
+ else
+ Perl_croak(aTHX_ "Cannot pack %"NVgf" with '%c'",
+ nv, (int) c);
+ }
+ }
+
/* Code inside the switch must take care to properly update
cat (CUR length and '\0' termination) if it updated *cur and
doesn't simply leave using break */
- switch(TYPE_NO_ENDIANNESS(datumtype)) {
+ switch (TYPE_NO_ENDIANNESS(datumtype)) {
default:
Perl_croak(aTHX_ "Invalid type '%c' in pack",
(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);
+ 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);
+ 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) {
PUSH32(utf8, cur, &ai32, needs_swap);
}
break;
-#if IVSIZE >= 8
+#if defined(HAS_QUAD) && IVSIZE >= 8
case 'Q':
while (len-- > 0) {
Uquad_t auquad;
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