/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
--jhi Feb 1999 */
-#if U16SIZE > SIZE16 || U32SIZE > SIZE32
-# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
-# define OFF16(p) ((char*)(p))
-# define OFF32(p) ((char*)(p))
-# else
-# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
-# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
-# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
-# else
- ++++ bad cray byte order
-# endif
-# endif
-#else
+#if U16SIZE <= SIZE16 && U32SIZE <= SIZE32
# define OFF16(p) ((char *) (p))
# define OFF32(p) ((char *) (p))
+#elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
+# define OFF16(p) ((char*)(p))
+# define OFF32(p) ((char*)(p))
+#elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
+# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
+# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
+#else
+# error "bad cray byte order"
#endif
#define PUSH16(utf8, cur, p, needs_swap) \
PERL_ARGS_ASSERT_MUL128;
- if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
+ if (! memBEGINs(s, len, "0000")) { /* need to grow sv */
SV * const tmpNew = newSVpvs("0000000000");
sv_catsv(tmpNew, sv);
utf8_to_byte(pTHX_ const char **s, const char *end, I32 datumtype)
{
STRLEN retlen;
- UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
+ UV val;
+
+ if (*s >= end) {
+ goto croak;
+ }
+ val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- /* We try to process malformed UTF-8 as much as possible (preferably with
- warnings), but these two mean we make no progress in the string and
- might enter an infinite loop */
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
+ croak:
Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
(int) TYPE_NO_MODIFIERS(datumtype));
if (val >= 0x100) {
for (;buf_len > 0; buf_len--) {
if (from >= end) return FALSE;
val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
- if (retlen == (STRLEN) -1 || retlen == 0) {
+ if (retlen == (STRLEN) -1) {
from += UTF8SKIP(from);
bad |= 1;
} else from += retlen;
STRLEN retlen; \
if (str >= end) break; \
val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \
- if (retlen == (STRLEN) -1 || retlen == 0) { \
+ if (retlen == (STRLEN) -1) { \
*cur = '\0'; \
Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \
} \
/* 'A' strips both nulls and spaces */
const char *ptr;
if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
- for (ptr = s+len-1; ptr >= s; ptr--)
- if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) &&
- !isSPACE_utf8(ptr)) break;
+ for (ptr = s+len-1; ptr >= s; ptr--) {
+ if ( *ptr != 0
+ && !UTF8_IS_CONTINUATION(*ptr)
+ && !isSPACE_utf8_safe(ptr, strend))
+ {
+ break;
+ }
+ }
if (ptr >= s) ptr += UTF8SKIP(ptr);
else ptr++;
if (ptr > s+len)
STRLEN retlen;
aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
}
STRLEN retlen;
const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
if (!checksum)
strend - s,
&retlen,
UTF8_ALLOW_DEFAULT));
- if (retlen == (STRLEN) -1 || retlen == 0)
+ if (retlen == (STRLEN) -1)
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
}
if (++bytes >= sizeof(UV)) { /* promote to string */
const char *t;
- sv = Perl_newSVpvf(aTHX_ "%.*"UVuf, (int)TYPE_DIGITS(UV), auv);
+ sv = Perl_newSVpvf(aTHX_ "%.*" UVuf,
+ (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
ch = SHIFT_BYTE(utf8, s, strend, datumtype);
sv = mul128(sv, (U8)(ch & 0x7f));
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);
+ Perl_croak(aTHX_ "Cannot compress %" NVgf " in pack", nv);
else
- Perl_croak(aTHX_ "Cannot pack %"NVgf" with '%c'", nv, (int) c);
+ Perl_croak(aTHX_ "Cannot pack %" NVgf " with '%c'", nv, (int) c);
}
return sv;
}
if (!S_utf8_to_bytes(aTHX_ &aptr, end, cur, fromlen,
datumtype | TYPE_IS_PACK))
Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
- "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
+ "for '%c', aptr=%p end=%p cur=%p, fromlen=%" UVuf,
(int)datumtype, aptr, end, cur, (UV)fromlen);
cur += fromlen;
len -= fromlen;
if (in_bytes) auv = auv % 0x100;
if (utf8) {
W_utf8:
- if (cur > end) {
+ if (cur >= end) {
*cur = '\0';
SvCUR_set(cat, cur - start);
GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
end = start+SvLEN(cat)-UTF8_MAXLEN;
}
- cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
- auv,
- warn_utf8 ?
- 0 : UNICODE_ALLOW_ANY);
+ cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, 0);
} else {
if (auv >= 0x100) {
if (!SvUTF8(cat)) {
auv = SvUV_no_inf(fromstr, datumtype);
if (utf8) {
U8 buffer[UTF8_MAXLEN], *endb;
- endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv),
- warn_utf8 ?
- 0 : UNICODE_ALLOW_ANY);
+ endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv), 0);
if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
*cur = '\0';
SvCUR_set(cat, cur - start);
GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
end = start+SvLEN(cat)-UTF8_MAXLEN;
}
- cur = (char *) uvchr_to_utf8_flags((U8 *) cur, UNI_TO_NATIVE(auv),
- warn_utf8 ?
- 0 : UNICODE_ALLOW_ANY);
+ cur = (char *) uvchr_to_utf8_flags((U8 *) cur,
+ UNI_TO_NATIVE(auv),
+ 0);
}
}
break;
NV anv;
fromstr = NEXTFROM;
anv = SvNV(fromstr);
-# if defined(VMS) && !defined(_IEEE_FP)
+# if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT)
/* IEEE fp overflow shenanigans are unavailable on VAX and optional
* on Alpha; fake it if we don't have them.
*/
afloat = -FLT_MAX;
else afloat = (float)anv;
# else
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+# if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
if(Perl_isnan(anv))
afloat = (float)NV_NAN;
else
-#endif
+# endif
+# ifdef NV_INF
/* a simple cast to float is undefined if outside
* the range of values that can be represented */
afloat = (float)(anv > FLT_MAX ? NV_INF :
anv < -FLT_MAX ? -NV_INF : anv);
+# endif
# endif
PUSH_VAR(utf8, cur, afloat, needs_swap);
}
NV anv;
fromstr = NEXTFROM;
anv = SvNV(fromstr);
-# if defined(VMS) && !defined(_IEEE_FP)
+# if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT)
/* IEEE fp overflow shenanigans are unavailable on VAX and optional
* on Alpha; fake it if we don't have them.
*/
* of pack() (and all copies of the result) are
* gone.
*/
- if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) &&
+ if (((SvTEMP(fromstr) && SvREFCNT(fromstr) == 1)
+ || (SvPADTMP(fromstr) &&
!SvREADONLY(fromstr)))) {
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Attempt to pack pointer to temporary value");
const char *patend = pat + fromlen;
MARK++;
- sv_setpvs(cat, "");
+ SvPVCLEAR(cat);
SvUTF8_off(cat);
packlist(cat, pat, patend, MARK, SP + 1);