/* pp_pack.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* other pp*.c files for the rest of the pp_ functions.
*/
-
#include "EXTERN.h"
#define PERL_IN_PP_PACK_C
#include "perl.h"
(symptr)->grpend = NULL; \
(symptr)->code = 0; \
(symptr)->length = 0; \
- (symptr)->howlen = 0; \
+ (symptr)->howlen = e_no_len; \
(symptr)->level = 0; \
(symptr)->flags = (f); \
(symptr)->strbeg = 0; \
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0,
- /* C */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE,
+ /* C */ sizeof(unsigned char),
#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
/* D */ LONG_DOUBLESIZE,
#else
/* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- /* C */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE,
+ /* C */ sizeof(unsigned char),
#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
/* D */ LONG_DOUBLESIZE,
#else
static const char *_action( const tempsym_t* symptr )
{
- return ( symptr->flags & FLAG_PACK ) ? "pack" : "unpack";
+ return (const char *)(( symptr->flags & FLAG_PACK ) ? "pack" : "unpack");
}
/* Returns the sizeof() struct described by pat */
return unpack_rec(&sym, s, s, strend, NULL );
}
-STATIC
-I32
+STATIC I32
S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s )
{
dVAR; dSP;
symptr->previous = &savsym;
symptr->level++;
PUTBACK;
+ if (len && unpack_only_one) len = 1;
while (len--) {
symptr->patptr = savsym.grpbeg;
if (utf8) symptr->flags |= FLAG_PARSE_UTF8;
sv = from <= s ?
newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) :
newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s)));
- XPUSHs(sv_2mortal(sv));
+ mXPUSHs(sv);
break;
}
#ifdef PERL_PACK_CAN_SHRIEKSIGN
if (!(symptr->flags & FLAG_WAS_UTF8))
sv_utf8_downgrade(sv, 0);
}
- XPUSHs(sv_2mortal(sv));
+ mXPUSHs(sv);
s += len;
break;
case 'B':
XPUSHs(sv);
break;
}
+ case 'C':
+ if (len == 0) {
+ if (explicit_length)
+ /* Switch to "character" mode */
+ utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
+ break;
+ }
+ /* FALL THROUGH */
case 'c':
- while (len-- > 0) {
- int aint = SHIFT_BYTE(utf8, s, strend, datumtype);
- if (aint >= 128) /* fake up signed chars */
+ while (len-- > 0 && s < strend) {
+ int aint;
+ if (utf8)
+ {
+ STRLEN retlen;
+ aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
+ ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
+ if (retlen == (STRLEN) -1 || retlen == 0)
+ Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
+ s += retlen;
+ }
+ else
+ aint = *(U8 *)(s)++;
+ if (aint >= 128 && datumtype != 'C') /* fake up signed chars */
aint -= 256;
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)aint)));
+ mPUSHi(aint);
else if (checksum > bits_in_uv)
cdouble += (NV)aint;
else
cuv += aint;
}
break;
- case 'C':
case 'W':
W_checksum:
- if (len == 0) {
- if (explicit_length && datumtype == 'C')
- /* Switch to "character" mode */
- utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
- break;
- }
- if (datumtype == 'C' ?
- (symptr->flags & FLAG_DO_UTF8) &&
- !(symptr->flags & FLAG_WAS_UTF8) : utf8) {
+ if (utf8) {
while (len-- > 0 && s < strend) {
STRLEN retlen;
const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
s += retlen;
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV) val)));
+ mPUSHu(val);
else if (checksum > bits_in_uv)
cdouble += (NV) val;
else
} else if (!checksum)
while (len-- > 0) {
const U8 ch = *(U8 *) s++;
- PUSHs(sv_2mortal(newSVuv((UV) ch)));
+ mPUSHu(ch);
}
else if (checksum > bits_in_uv)
while (len-- > 0) cdouble += (NV) *(U8 *) s++;
s += retlen;
}
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV) auv)));
+ mPUSHu(auv);
else if (checksum > bits_in_uv)
cdouble += (NV) auv;
else
SHIFT_VAR(utf8, s, strend, ashort, datumtype);
DO_BO_UNPACK(ashort, s);
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)ashort)));
+ mPUSHi(ashort);
else if (checksum > bits_in_uv)
cdouble += (NV)ashort;
else
ai16 -= 65536;
#endif
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)ai16)));
+ mPUSHi(ai16);
else if (checksum > bits_in_uv)
cdouble += (NV)ai16;
else
SHIFT_VAR(utf8, s, strend, aushort, datumtype);
DO_BO_UNPACK(aushort, s);
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV) aushort)));
+ mPUSHu(aushort);
else if (checksum > bits_in_uv)
cdouble += (NV)aushort;
else
au16 = vtohs(au16);
#endif
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV)au16)));
+ mPUSHu(au16);
else if (checksum > bits_in_uv)
cdouble += (NV) au16;
else
ai16 = (I16) vtohs((U16) ai16);
# endif /* HAS_VTOHS */
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)ai16)));
+ mPUSHi(ai16);
else if (checksum > bits_in_uv)
cdouble += (NV) ai16;
else
SHIFT_VAR(utf8, s, strend, aint, datumtype);
DO_BO_UNPACK(aint, i);
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)aint)));
+ mPUSHi(aint);
else if (checksum > bits_in_uv)
cdouble += (NV)aint;
else
SHIFT_VAR(utf8, s, strend, auint, datumtype);
DO_BO_UNPACK(auint, i);
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV)auint)));
+ mPUSHu(auint);
else if (checksum > bits_in_uv)
cdouble += (NV)auint;
else
Perl_croak(aTHX_ "'j' not supported on this platform");
#endif
if (!checksum)
- PUSHs(sv_2mortal(newSViv(aiv)));
+ mPUSHi(aiv);
else if (checksum > bits_in_uv)
cdouble += (NV)aiv;
else
Perl_croak(aTHX_ "'J' not supported on this platform");
#endif
if (!checksum)
- PUSHs(sv_2mortal(newSVuv(auv)));
+ mPUSHu(auv);
else if (checksum > bits_in_uv)
cdouble += (NV)auv;
else
SHIFT_VAR(utf8, s, strend, along, datumtype);
DO_BO_UNPACK(along, l);
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)along)));
+ mPUSHi(along);
else if (checksum > bits_in_uv)
cdouble += (NV)along;
else
if (ai32 > 2147483647) ai32 -= 4294967296;
#endif
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)ai32)));
+ mPUSHi(ai32);
else if (checksum > bits_in_uv)
cdouble += (NV)ai32;
else
SHIFT_VAR(utf8, s, strend, aulong, datumtype);
DO_BO_UNPACK(aulong, l);
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV)aulong)));
+ mPUSHu(aulong);
else if (checksum > bits_in_uv)
cdouble += (NV)aulong;
else
au32 = vtohl(au32);
#endif
if (!checksum)
- PUSHs(sv_2mortal(newSVuv((UV)au32)));
+ mPUSHu(au32);
else if (checksum > bits_in_uv)
cdouble += (NV)au32;
else
ai32 = (I32)vtohl((U32)ai32);
# endif
if (!checksum)
- PUSHs(sv_2mortal(newSViv((IV)ai32)));
+ mPUSHi(ai32);
else if (checksum > bits_in_uv)
cdouble += (NV)ai32;
else
SHIFT_VAR(utf8, s, strend, aptr, datumtype);
DO_BO_UNPACK_PC(aptr);
/* newSVpv generates undef if aptr is NULL */
- PUSHs(sv_2mortal(newSVpv(aptr, 0)));
+ mPUSHs(newSVpv(aptr, 0));
}
break;
case 'w':
/* UTF8_IS_XXXXX not right here - using constant 0x80 */
if (ch < 0x80) {
bytes = 0;
- PUSHs(sv_2mortal(newSVuv(auv)));
+ mPUSHu(auv);
len--;
auv = 0;
continue;
if (++bytes >= sizeof(UV)) { /* promote to string */
const char *t;
- sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (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));
while (*t == '0')
t++;
sv_chop(sv, t);
- PUSHs(sv_2mortal(sv));
+ mPUSHs(sv);
len--;
auv = 0;
}
SHIFT_VAR(utf8, s, strend, aptr, datumtype);
DO_BO_UNPACK_PC(aptr);
/* newSVpvn generates undef if aptr is NULL */
- PUSHs(sv_2mortal(newSVpvn(aptr, len)));
+ PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP));
}
break;
#ifdef HAS_QUAD
SHIFT_VAR(utf8, s, strend, aquad, datumtype);
DO_BO_UNPACK(aquad, 64);
if (!checksum)
- PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ?
- newSViv((IV)aquad) : newSVnv((NV)aquad)));
+ mPUSHs(aquad >= IV_MIN && aquad <= IV_MAX ?
+ newSViv((IV)aquad) : newSVnv((NV)aquad));
else if (checksum > bits_in_uv)
cdouble += (NV)aquad;
else
SHIFT_VAR(utf8, s, strend, auquad, datumtype);
DO_BO_UNPACK(auquad, 64);
if (!checksum)
- PUSHs(sv_2mortal(auquad <= UV_MAX ?
- newSVuv((UV)auquad):newSVnv((NV)auquad)));
+ mPUSHs(auquad <= UV_MAX ?
+ newSVuv((UV)auquad) : newSVnv((NV)auquad));
else if (checksum > bits_in_uv)
cdouble += (NV)auquad;
else
SHIFT_VAR(utf8, s, strend, afloat, datumtype);
DO_BO_UNPACK_N(afloat, float);
if (!checksum)
- PUSHs(sv_2mortal(newSVnv((NV)afloat)));
+ mPUSHn(afloat);
else
cdouble += afloat;
}
SHIFT_VAR(utf8, s, strend, adouble, datumtype);
DO_BO_UNPACK_N(adouble, double);
if (!checksum)
- PUSHs(sv_2mortal(newSVnv((NV)adouble)));
+ mPUSHn(adouble);
else
cdouble += adouble;
}
SHIFT_VAR(utf8, s, strend, anv, datumtype);
DO_BO_UNPACK_N(anv, NV);
if (!checksum)
- PUSHs(sv_2mortal(newSVnv(anv)));
+ mPUSHn(anv);
else
cdouble += anv;
}
SHIFT_VAR(utf8, s, strend, aldouble, datumtype);
DO_BO_UNPACK_N(aldouble, long double);
if (!checksum)
- PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
+ mPUSHn(aldouble);
else
cdouble += aldouble;
}
break;
#endif
case 'u':
- /* MKS:
- * Initialise the decode mapping. By using a table driven
- * algorithm, the code will be character-set independent
- * (and just as fast as doing character arithmetic)
- */
- if (PL_uudmap['M'] == 0) {
- size_t i;
-
- for (i = 0; i < sizeof(PL_uuemap); ++i)
- PL_uudmap[(U8)PL_uuemap[i]] = i;
- /*
- * Because ' ' and '`' map to the same value,
- * we need to decode them both the same.
- */
- PL_uudmap[' '] = 0;
- }
{
const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
sv = sv_2mortal(newSV(l));
if (utf8) {
while (next_uni_uu(aTHX_ &s, strend, &len)) {
I32 a, b, c, d;
- char hunk[4];
+ char hunk[3];
- hunk[3] = '\0';
while (len > 0) {
next_uni_uu(aTHX_ &s, strend, &a);
next_uni_uu(aTHX_ &s, strend, &b);
} else {
while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
I32 a, b, c, d;
- char hunk[4];
+ char hunk[3];
- hunk[3] = '\0';
len = PL_uudmap[*(U8*)s++] & 077;
while (len > 0) {
if (s < strend && ISUUCHAR(*s))
}
sv = newSVuv(cuv);
}
- XPUSHs(sv_2mortal(sv));
+ mXPUSHs(sv);
checksum = 0;
}
by copying it to a temporary. */
STRLEN len;
const char *const pv = SvPV_const(*beglist, len);
- SV *const temp = sv_2mortal(newSVpvn(pv, len));
- if (SvUTF8(*beglist))
- SvUTF8_on(temp);
+ SV *const temp
+ = newSVpvn_flags(pv, len,
+ SVs_TEMP | SvUTF8(*beglist));
*beglist = temp;
}
count = DO_UTF8(*beglist) ?
if (savsym.howlen == e_star && beglist == endlist)
break; /* No way to continue */
}
+ items = endlist - beglist;
lookahead.flags = symptr->flags & ~group_modifiers;
goto no_change;
}
utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
break;
}
- GROWING(0, cat, start, cur, len);
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
ckWARN(WARN_PACK))
Perl_warner(aTHX_ packWARN(WARN_PACK),
"Character in 'C' format wrapped in pack");
- *cur++ = (char)(aiv & 0xff);
+ PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff));
}
break;
case 'W': {
projects / p5sagit/p5-mst-13.2.git / blobdiff