return SvGROW(sv, len+extend+1);
}
+static void
+S_sv_check_infnan(pTHX_ SV *sv, I32 datumtype)
+{
+ SvGETMAGIC(sv);
+ if (UNLIKELY(isinfnansv(sv))) {
+ const I32 c = TYPE_NO_MODIFIERS(datumtype);
+ const NV nv = SvNV_nomg(sv);
+ if (c == 'w')
+ Perl_croak(aTHX_ "Cannot compress %"NVgf" in pack", nv);
+ else
+ Perl_croak(aTHX_ "Cannot pack %"NVgf" with '%c'", nv, (int) c);
+ }
+}
+
+#define SvIV_no_inf(sv,d) (S_sv_check_infnan(aTHX_ sv,d), SvIV_nomg(sv))
+#define SvUV_no_inf(sv,d) (S_sv_check_infnan(aTHX_ sv,d), SvUV_nomg(sv))
+
STATIC
SV **
S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
needs_swap = NEEDS_SWAP(datumtype);
- fromstr = PEEKFROM;
- if (SvNOK(fromstr)) {
- const NV nv = SvNV(fromstr);
- if (UNLIKELY(Perl_isinfnan(nv))) {
- const I32 c = TYPE_NO_MODIFIERS(datumtype);
- if (!strchr("fdFD", (char)c)) { /* floats are okay */
- if (c == 'w')
- Perl_croak(aTHX_
- "Cannot compress %"NVgf" in pack", 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 */
from = group ? start + group->strbeg : start;
}
fromstr = NEXTFROM;
- len = SvIV(fromstr);
+ len = SvIV_no_inf(fromstr, datumtype);
goto resize;
case '@' | TYPE_IS_SHRIEKING:
case '@':
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
- aiv = SvIV(fromstr);
+ aiv = SvIV_no_inf(fromstr, datumtype);
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_no_inf(fromstr, datumtype);
if ((0 > aiv || aiv > 0xff))
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Character in 'C' format wrapped in pack");
while (len-- > 0) {
UV auv;
fromstr = NEXTFROM;
- auv = SvUV(fromstr);
+ auv = SvUV_no_inf(fromstr, datumtype);
if (in_bytes) auv = auv % 0x100;
if (utf8) {
W_utf8:
while (len-- > 0) {
UV auv;
fromstr = NEXTFROM;
- auv = SvUV(fromstr);
+ auv = SvUV_no_inf(fromstr, datumtype);
if (utf8) {
U8 buffer[UTF8_MAXLEN], *endb;
endb = uvchr_to_utf8_flags(buffer, auv,
while (len-- > 0) {
I16 ai16;
fromstr = NEXTFROM;
- ai16 = (I16)SvIV(fromstr);
+ ai16 = (I16)SvIV_no_inf(fromstr, datumtype);
ai16 = PerlSock_htons(ai16);
PUSH16(utf8, cur, &ai16, FALSE);
}
while (len-- > 0) {
I16 ai16;
fromstr = NEXTFROM;
- ai16 = (I16)SvIV(fromstr);
+ ai16 = (I16)SvIV_no_inf(fromstr, datumtype);
ai16 = htovs(ai16);
PUSH16(utf8, cur, &ai16, FALSE);
}
while (len-- > 0) {
unsigned short aushort;
fromstr = NEXTFROM;
- aushort = SvUV(fromstr);
+ aushort = SvUV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, aushort, needs_swap);
}
break;
while (len-- > 0) {
U16 au16;
fromstr = NEXTFROM;
- au16 = (U16)SvUV(fromstr);
+ au16 = (U16)SvUV_no_inf(fromstr, datumtype);
PUSH16(utf8, cur, &au16, needs_swap);
}
break;
while (len-- > 0) {
short ashort;
fromstr = NEXTFROM;
- ashort = SvIV(fromstr);
+ ashort = SvIV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, ashort, needs_swap);
}
break;
while (len-- > 0) {
I16 ai16;
fromstr = NEXTFROM;
- ai16 = (I16)SvIV(fromstr);
+ ai16 = (I16)SvIV_no_inf(fromstr, datumtype);
PUSH16(utf8, cur, &ai16, needs_swap);
}
break;
while (len-- > 0) {
unsigned int auint;
fromstr = NEXTFROM;
- auint = SvUV(fromstr);
+ auint = SvUV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, auint, needs_swap);
}
break;
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
- aiv = SvIV(fromstr);
+ aiv = SvIV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, aiv, needs_swap);
}
break;
while (len-- > 0) {
UV auv;
fromstr = NEXTFROM;
- auv = SvUV(fromstr);
+ auv = SvUV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, auv, needs_swap);
}
break;
while (len-- > 0) {
NV anv;
fromstr = NEXTFROM;
- anv = SvNV(fromstr);
+ S_sv_check_infnan(aTHX_ fromstr, datumtype);
+ anv = SvNV_nomg(fromstr);
if (anv < 0) {
*cur = '\0';
if (SvIOK(fromstr) || anv < UV_MAX_P1) {
char buf[(sizeof(UV)*CHAR_BIT)/7+1];
char *in = buf + sizeof(buf);
- UV auv = SvUV(fromstr);
+ UV auv = SvUV_nomg(fromstr);
do {
*--in = (char)((auv & 0x7f) | 0x80);
w_string:
/* Copy string and check for compliance */
- from = SvPV_const(fromstr, len);
+ from = SvPV_nomg_const(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
while (len-- > 0) {
int aint;
fromstr = NEXTFROM;
- aint = SvIV(fromstr);
+ aint = SvIV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, aint, needs_swap);
}
break;
while (len-- > 0) {
U32 au32;
fromstr = NEXTFROM;
- au32 = SvUV(fromstr);
+ au32 = SvUV_no_inf(fromstr, datumtype);
au32 = PerlSock_htonl(au32);
PUSH32(utf8, cur, &au32, FALSE);
}
while (len-- > 0) {
U32 au32;
fromstr = NEXTFROM;
- au32 = SvUV(fromstr);
+ au32 = SvUV_no_inf(fromstr, datumtype);
au32 = htovl(au32);
PUSH32(utf8, cur, &au32, FALSE);
}
while (len-- > 0) {
unsigned long aulong;
fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
+ aulong = SvUV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, aulong, needs_swap);
}
break;
while (len-- > 0) {
U32 au32;
fromstr = NEXTFROM;
- au32 = SvUV(fromstr);
+ au32 = SvUV_no_inf(fromstr, datumtype);
PUSH32(utf8, cur, &au32, needs_swap);
}
break;
while (len-- > 0) {
long along;
fromstr = NEXTFROM;
- along = SvIV(fromstr);
+ along = SvIV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, along, needs_swap);
}
break;
while (len-- > 0) {
I32 ai32;
fromstr = NEXTFROM;
- ai32 = SvIV(fromstr);
+ ai32 = SvIV_no_inf(fromstr, datumtype);
PUSH32(utf8, cur, &ai32, needs_swap);
}
break;
while (len-- > 0) {
Uquad_t auquad;
fromstr = NEXTFROM;
- auquad = (Uquad_t) SvUV(fromstr);
+ auquad = (Uquad_t) SvUV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, auquad, needs_swap);
}
break;
while (len-- > 0) {
Quad_t aquad;
fromstr = NEXTFROM;
- aquad = (Quad_t)SvIV(fromstr);
+ aquad = (Quad_t)SvIV_no_inf(fromstr, datumtype);
PUSH_VAR(utf8, cur, aquad, needs_swap);
}
break;
https://perl5.git.perl.org / perl5.git / blobdiff