/* pp_pack.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, 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. * */ /* * He still hopefully carried some of his gear in his pack: a small tinder-box, * two small shallow pans, the smaller fitting into the larger; inside them a * wooden spoon, a short two-pronged fork and some skewers were stowed; and * hidden at the bottom of the pack in a flat wooden box a dwindling treasure, * some salt. */ /* This file contains pp ("push/pop") functions that * execute the opcodes that make up a perl program. A typical pp function * expects to find its arguments on the stack, and usually pushes its * results onto the stack, hence the 'pp' terminology. Each OP structure * contains a pointer to the relevant pp_foo() function. * * This particular file just contains pp_pack() and pp_unpack(). See the * other pp*.c files for the rest of the pp_ functions. */ #include "EXTERN.h" #define PERL_IN_PP_PACK_C #include "perl.h" /* Types used by pack/unpack */ typedef enum { e_no_len, /* no length */ e_number, /* number, [] */ e_star /* asterisk */ } howlen_t; typedef struct tempsym { const char* patptr; /* current template char */ const char* patend; /* one after last char */ const char* grpbeg; /* 1st char of ()-group */ const char* grpend; /* end of ()-group */ I32 code; /* template code (!<>) */ I32 length; /* length/repeat count */ howlen_t howlen; /* how length is given */ int level; /* () nesting level */ U32 flags; /* /=4, comma=2, pack=1 */ /* and group modifiers */ STRLEN strbeg; /* offset of group start */ struct tempsym *previous; /* previous group */ } tempsym_t; #define TEMPSYM_INIT(symptr, p, e, f) \ STMT_START { \ (symptr)->patptr = (p); \ (symptr)->patend = (e); \ (symptr)->grpbeg = NULL; \ (symptr)->grpend = NULL; \ (symptr)->grpend = NULL; \ (symptr)->code = 0; \ (symptr)->length = 0; \ (symptr)->howlen = 0; \ (symptr)->level = 0; \ (symptr)->flags = (f); \ (symptr)->strbeg = 0; \ (symptr)->previous = NULL; \ } STMT_END #if PERL_VERSION >= 9 # define PERL_PACK_CAN_BYTEORDER # define PERL_PACK_CAN_SHRIEKSIGN #endif #ifndef CHAR_BIT # define CHAR_BIT 8 #endif /* Maximum number of bytes to which a byte can grow due to upgrade */ #define UTF8_EXPAND 2 /* * Offset for integer pack/unpack. * * On architectures where I16 and I32 aren't really 16 and 32 bits, * which for now are all Crays, pack and unpack have to play games. */ /* * These values are required for portability of pack() output. * If they're not right on your machine, then pack() and unpack() * wouldn't work right anyway; you'll need to apply the Cray hack. * (I'd like to check them with #if, but you can't use sizeof() in * the preprocessor.) --??? */ /* The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE defines are now in config.h. --Andy Dougherty April 1998 */ #define SIZE16 2 #define SIZE32 4 /* 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 # define OFF16(p) ((char *) (p)) # define OFF32(p) ((char *) (p)) #endif /* Only to be used inside a loop (see the break) */ #define SHIFT16(utf8, s, strend, p, datumtype) STMT_START { \ if (utf8) { \ if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break; \ } else { \ Copy(s, OFF16(p), SIZE16, char); \ (s) += SIZE16; \ } \ } STMT_END /* Only to be used inside a loop (see the break) */ #define SHIFT32(utf8, s, strend, p, datumtype) STMT_START { \ if (utf8) { \ if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break; \ } else { \ Copy(s, OFF32(p), SIZE32, char); \ (s) += SIZE32; \ } \ } STMT_END #define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16) #define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32) /* Only to be used inside a loop (see the break) */ #define SHIFT_VAR(utf8, s, strend, var, datumtype) \ STMT_START { \ if (utf8) { \ if (!uni_to_bytes(aTHX_ &s, strend, \ (char *) &var, sizeof(var), datumtype)) break;\ } else { \ Copy(s, (char *) &var, sizeof(var), char); \ s += sizeof(var); \ } \ } STMT_END #define PUSH_VAR(utf8, aptr, var) \ PUSH_BYTES(utf8, aptr, &(var), sizeof(var)) /* Avoid stack overflow due to pathological templates. 100 should be plenty. */ #define MAX_SUB_TEMPLATE_LEVEL 100 /* flags (note that type modifiers can also be used as flags!) */ #define FLAG_WAS_UTF8 0x40 #define FLAG_PARSE_UTF8 0x20 /* Parse as utf8 */ #define FLAG_UNPACK_ONLY_ONE 0x10 #define FLAG_DO_UTF8 0x08 /* The underlying string is utf8 */ #define FLAG_SLASH 0x04 #define FLAG_COMMA 0x02 #define FLAG_PACK 0x01 STATIC SV * S_mul128(pTHX_ SV *sv, U8 m) 185 { 185 STRLEN len; 185 char *s = SvPV(sv, len); 185 char *t; 185 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ 47 SV *tmpNew = newSVpvn("0000000000", 10); 47 sv_catsv(tmpNew, sv); 47 SvREFCNT_dec(sv); /* free old sv */ 47 sv = tmpNew; 47 s = SvPV(sv, len); } 185 t = s + len - 1; 185 while (!*t) /* trailing '\0'? */ ###### t--; 24580 while (t > s) { 24395 const U32 i = ((*t - '0') << 7) + m; 24395 *(t--) = '0' + (char)(i % 10); 24395 m = (char)(i / 10); } 185 return (sv); } /* Explosives and implosives. */ #if 'I' == 73 && 'J' == 74 /* On an ASCII/ISO kind of system */ #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') #else /* Some other sort of character set - use memchr() so we don't match the null byte. */ #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') #endif /* type modifiers */ #define TYPE_IS_SHRIEKING 0x100 #define TYPE_IS_BIG_ENDIAN 0x200 #define TYPE_IS_LITTLE_ENDIAN 0x400 #define TYPE_IS_PACK 0x800 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN) #define TYPE_MODIFIERS(t) ((t) & ~0xFF) #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF) #ifdef PERL_PACK_CAN_SHRIEKSIGN # define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV@." #else # define SHRIEKING_ALLOWED_TYPES "sSiIlLxX" #endif #ifndef PERL_PACK_CAN_BYTEORDER /* Put "can't" first because it is shorter */ # define TYPE_ENDIANNESS(t) 0 # define TYPE_NO_ENDIANNESS(t) (t) # define ENDIANNESS_ALLOWED_TYPES "" # define DO_BO_UNPACK(var, type) # define DO_BO_PACK(var, type) # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) # define DO_BO_UNPACK_N(var, type) # define DO_BO_PACK_N(var, type) # define DO_BO_UNPACK_P(var) # define DO_BO_PACK_P(var) #else /* PERL_PACK_CAN_BYTEORDER */ # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK) # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK) # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP(" # define DO_BO_UNPACK(var, type) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \ case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \ default: break; \ } \ } STMT_END # define DO_BO_PACK(var, type) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \ case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \ default: break; \ } \ } STMT_END # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: \ var = (post_cast*) my_betoh ## type ((pre_cast) var); \ break; \ case TYPE_IS_LITTLE_ENDIAN: \ var = (post_cast *) my_letoh ## type ((pre_cast) var); \ break; \ default: \ break; \ } \ } STMT_END # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: \ var = (post_cast *) my_htobe ## type ((pre_cast) var); \ break; \ case TYPE_IS_LITTLE_ENDIAN: \ var = (post_cast *) my_htole ## type ((pre_cast) var); \ break; \ default: \ break; \ } \ } STMT_END # define BO_CANT_DOIT(action, type) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: \ Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \ "platform", #action, #type); \ break; \ case TYPE_IS_LITTLE_ENDIAN: \ Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \ "platform", #action, #type); \ break; \ default: \ break; \ } \ } STMT_END # if PTRSIZE == INTSIZE # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int, void) # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int, void) # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char) # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char) # elif PTRSIZE == LONGSIZE # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void) # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void) # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char) # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char) # else # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer) # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer) # endif # if defined(my_htolen) && defined(my_letohn) && \ defined(my_htoben) && defined(my_betohn) # define DO_BO_UNPACK_N(var, type) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\ case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\ default: break; \ } \ } STMT_END # define DO_BO_PACK_N(var, type) \ STMT_START { \ switch (TYPE_ENDIANNESS(datumtype)) { \ case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\ case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\ default: break; \ } \ } STMT_END # else # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type) # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type) # endif #endif /* PERL_PACK_CAN_BYTEORDER */ #define PACK_SIZE_CANNOT_CSUM 0x80 #define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */ #define PACK_SIZE_MASK 0x3F /* These tables are regenerated by genpacksizetables.pl (and then hand pasted in). You're unlikely ever to need to regenerate them. */ #if TYPE_IS_SHRIEKING != 0x100 ++++shriek offset should be 256 #endif typedef U8 packprops_t; #if 'J'-'I' == 1 /* ASCII */ const packprops_t packprops[512] = { /* normal */ 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, 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, #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) /* D */ LONG_DOUBLESIZE, #else 0, #endif 0, /* F */ NVSIZE, 0, 0, /* I */ sizeof(unsigned int), /* J */ UVSIZE, 0, /* L */ SIZE32, 0, /* N */ SIZE32, 0, 0, #if defined(HAS_QUAD) /* Q */ sizeof(Uquad_t), #else 0, #endif 0, /* S */ SIZE16, 0, /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE, /* V */ SIZE32, /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* c */ sizeof(char), /* d */ sizeof(double), 0, /* f */ sizeof(float), 0, 0, /* i */ sizeof(int), /* j */ IVSIZE, 0, /* l */ SIZE32, 0, /* n */ SIZE16, 0, /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM, #if defined(HAS_QUAD) /* q */ sizeof(Quad_t), #else 0, #endif 0, /* s */ SIZE16, 0, 0, /* v */ SIZE16, /* 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, 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, 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, 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, /* shrieking */ 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, 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, 0, /* I */ sizeof(unsigned int), 0, 0, /* L */ sizeof(unsigned long), 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* N */ SIZE32, #else 0, #endif 0, 0, 0, 0, /* S */ sizeof(unsigned short), 0, 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* V */ SIZE32, #else 0, #endif 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* i */ sizeof(int), 0, 0, /* l */ sizeof(long), 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* n */ SIZE16, #else 0, #endif 0, 0, 0, 0, /* s */ sizeof(short), 0, 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* v */ SIZE16, #else 0, #endif 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, 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, 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, 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 }; #else /* EBCDIC (or bust) */ const packprops_t packprops[512] = { /* normal */ 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, 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, 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, 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(char), /* d */ sizeof(double), 0, /* f */ sizeof(float), 0, 0, /* i */ sizeof(int), 0, 0, 0, 0, 0, 0, 0, /* j */ IVSIZE, 0, /* l */ SIZE32, 0, /* n */ SIZE16, 0, /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM, #if defined(HAS_QUAD) /* q */ sizeof(Quad_t), #else 0, #endif 0, 0, 0, 0, 0, 0, 0, 0, 0, /* s */ SIZE16, 0, 0, /* v */ SIZE16, /* 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, #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) /* D */ LONG_DOUBLESIZE, #else 0, #endif 0, /* F */ NVSIZE, 0, 0, /* I */ sizeof(unsigned int), 0, 0, 0, 0, 0, 0, 0, /* J */ UVSIZE, 0, /* L */ SIZE32, 0, /* N */ SIZE32, 0, 0, #if defined(HAS_QUAD) /* Q */ sizeof(Uquad_t), #else 0, #endif 0, 0, 0, 0, 0, 0, 0, 0, 0, /* S */ SIZE16, 0, /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE, /* V */ SIZE32, /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, 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, /* shrieking */ 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, 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, 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, 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, /* i */ sizeof(int), 0, 0, 0, 0, 0, 0, 0, 0, 0, /* l */ sizeof(long), 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* n */ SIZE16, #else 0, #endif 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* s */ sizeof(short), 0, 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* v */ SIZE16, #else 0, #endif 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, /* I */ sizeof(unsigned int), 0, 0, 0, 0, 0, 0, 0, 0, 0, /* L */ sizeof(unsigned long), 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* N */ SIZE32, #else 0, #endif 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* S */ sizeof(unsigned short), 0, 0, #if defined(PERL_PACK_CAN_SHRIEKSIGN) /* V */ SIZE32, #else 0, #endif 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 }; #endif STATIC U8 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) 22 { 22 UV val; 22 STRLEN retlen; 22 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 (preferrably with warnings), but these two mean we make no progress in the string and might enter an infinite loop */ 22 if (retlen == (STRLEN) -1 || retlen == 0) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack", (int) TYPE_NO_MODIFIERS(datumtype)); 22 if (val >= 0x100) { ###### if (ckWARN(WARN_UNPACK)) ###### Perl_warner(aTHX_ packWARN(WARN_UNPACK), "Character in '%c' format wrapped in unpack", (int) TYPE_NO_MODIFIERS(datumtype)); ###### val &= 0xff; } 22 *s += retlen; 22 return (U8)val; } #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \ uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \ *(U8 *)(s)++) STATIC bool uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype) 308 { 308 UV val; 308 STRLEN retlen; 308 const char *from = *s; 308 int bad = 0; 308 const U32 flags = ckWARN(WARN_UTF8) ? 308 UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY); 2406 for (;buf_len > 0; buf_len--) { 1049 if (from >= end) return FALSE; 1049 val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags); 1049 if (retlen == (STRLEN) -1 || retlen == 0) { ###### from += UTF8SKIP(from); ###### bad |= 1; 1049 } else from += retlen; 1049 if (val >= 0x100) { ###### bad |= 2; ###### val &= 0xff; } 1049 *(U8 *)buf++ = (U8)val; } /* We have enough characters for the buffer. Did we have problems ? */ 308 if (bad) { ###### if (bad & 1) { /* Rewalk the string fragment while warning */ ###### const char *ptr; ###### const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; ###### for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) { ###### if (ptr >= end) break; ###### utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags); } ###### if (from > end) from = end; } ###### if ((bad & 2) && ckWARN(WARN_UNPACK)) ###### Perl_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? WARN_PACK : WARN_UNPACK), "Character(s) in '%c' format wrapped in %s", (int) TYPE_NO_MODIFIERS(datumtype), datumtype & TYPE_IS_PACK ? "pack" : "unpack"); } 308 *s = from; 308 return TRUE; } STATIC bool next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) 18 { 18 UV val; 18 STRLEN retlen; 18 val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); 18 if (val >= 0x100 || !ISUUCHAR(val) || retlen == (STRLEN) -1 || retlen == 0) { 1 *out = 0; 1 return FALSE; } 17 *out = PL_uudmap[val] & 077; 17 *s += retlen; 17 return TRUE; } STATIC void 292 bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char **dest) { 292 U8 buffer[UTF8_MAXLEN]; 292 const U8 *end = start + len; 292 char *d = *dest; 1363 while (start < end) { 1071 const int length = 1071 uvuni_to_utf8_flags(buffer, NATIVE_TO_UNI(*start), 0) - buffer; 1071 switch(length) { case 1: 834 *d++ = buffer[0]; 834 break; case 2: 237 *d++ = buffer[0]; 237 *d++ = buffer[1]; 237 break; default: ###### Perl_croak(aTHX_ "Perl bug: value %d UTF-8 expands to %d bytes", *start, length); } 1071 start++; } 292 *dest = d; } #define PUSH_BYTES(utf8, cur, buf, len) \ STMT_START { \ if (utf8) bytes_to_uni(aTHX_ (U8 *) buf, len, &(cur)); \ else { \ Copy(buf, cur, len, char); \ (cur) += (len); \ } \ } STMT_END #define GROWING(utf8, cat, start, cur, in_len) \ STMT_START { \ STRLEN glen = (in_len); \ if (utf8) glen *= UTF8_EXPAND; \ if ((cur) + glen >= (start) + SvLEN(cat)) { \ (start) = sv_exp_grow(aTHX_ cat, glen); \ (cur) = (start) + SvCUR(cat); \ } \ } STMT_END #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \ STMT_START { \ const STRLEN glen = (in_len); \ STRLEN gl = glen; \ if (utf8) gl *= UTF8_EXPAND; \ if ((cur) + gl >= (start) + SvLEN(cat)) { \ *cur = '\0'; \ SvCUR_set((cat), (cur) - (start)); \ (start) = sv_exp_grow(aTHX_ cat, gl); \ (cur) = (start) + SvCUR(cat); \ } \ PUSH_BYTES(utf8, cur, buf, glen); \ } STMT_END #define PUSH_BYTE(utf8, s, byte) \ STMT_START { \ if (utf8) { \ const U8 au8 = (byte); \ bytes_to_uni(aTHX_ &au8, 1, &(s)); \ } else *(U8 *)(s)++ = (byte); \ } STMT_END /* Only to be used inside a loop (see the break) */ #define NEXT_UNI_VAL(val, cur, str, end, utf8_flags) \ STMT_START { \ STRLEN retlen; \ if (str >= end) break; \ val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \ if (retlen == (STRLEN) -1 || retlen == 0) { \ *cur = '\0'; \ Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \ } \ str += retlen; \ } STMT_END static const char *_action( const tempsym_t* symptr ) 135 { 135 return ( symptr->flags & FLAG_PACK ) ? "pack" : "unpack"; } /* Returns the sizeof() struct described by pat */ STATIC I32 S_measure_struct(pTHX_ tempsym_t* symptr) 7335 { 7335 I32 total = 0; 18323 while (next_symbol(symptr)) { 10989 I32 len; 10989 int size; 10989 switch (symptr->howlen) { case e_star: ###### Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", _action( symptr ) ); 10989 break; default: /* e_no_len and e_number */ 10989 len = symptr->length; 10989 break; } 10989 size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK; 10989 if (!size) { 7159 int star; /* endianness doesn't influence the size of a type */ 7159 switch(TYPE_NO_ENDIANNESS(symptr->code)) { default: ###### Perl_croak(aTHX_ "Invalid type '%c' in %s", (int)TYPE_NO_MODIFIERS(symptr->code), _action( symptr ) ); #ifdef PERL_PACK_CAN_SHRIEKSIGN case '.' | TYPE_IS_SHRIEKING: case '@' | TYPE_IS_SHRIEKING: #endif case '@': case '.': case '/': case 'U': /* XXXX Is it correct? */ case 'w': case 'u': 1 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s", (int) TYPE_NO_MODIFIERS(symptr->code), _action( symptr ) ); case '%': ###### size = 0; ###### break; case '(': { 2916 tempsym_t savsym = *symptr; 2916 symptr->patptr = savsym.grpbeg; 2916 symptr->patend = savsym.grpend; /* XXXX Theoretically, we need to measure many times at different positions, since the subexpression may contain alignment commands, but be not of aligned length. Need to detect this and croak(). */ 2916 size = measure_struct(symptr); 2916 *symptr = savsym; 2916 break; } case 'X' | TYPE_IS_SHRIEKING: /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */ 729 if (!len) /* Avoid division by 0 */ 13 len = 1; 729 len = total % len; /* Assumed: the start is aligned. */ /* FALL THROUGH */ case 'X': 1458 size = -1; 1458 if (total < len) ###### Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) ); 732 break; case 'x' | TYPE_IS_SHRIEKING: 732 if (!len) /* Avoid division by 0 */ ###### len = 1; 732 star = total % len; /* Assumed: the start is aligned. */ 732 if (star) /* Other portable ways? */ 312 len = len - star; else 420 len = 0; /* FALL THROUGH */ case 'x': case 'A': case 'Z': case 'a': 2406 size = 1; 2406 break; case 'B': case 'b': 108 len = (len + 7)/8; 108 size = 1; 108 break; case 'H': case 'h': 108 len = (len + 1)/2; 108 size = 1; 108 break; case 'P': 162 len = 1; 162 size = sizeof(char*); 10988 break; } } 10988 total += len * size; } 7334 return total; } /* locate matching closing parenthesis or bracket * returns char pointer to char after match, or NULL */ STATIC const char * S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender) 35541 { 137398 while (patptr < patend) { 137398 const char c = *patptr++; 137398 if (isSPACE(c)) 111587 continue; 111587 else if (c == ender) 35541 return patptr-1; 76046 else if (c == '#') { ###### while (patptr < patend && *patptr != '\n') ###### patptr++; 76046 continue; 76046 } else if (c == '(') 8449 patptr = group_end(patptr, patend, ')') + 1; 67597 else if (c == '[') 5052 patptr = group_end(patptr, patend, ']') + 1; } ###### Perl_croak(aTHX_ "No group ending character '%c' found in template", ender); 35541 return 0; } /* Convert unsigned decimal number to binary. * Expects a pointer to the first digit and address of length variable * Advances char pointer to 1st non-digit char and returns number */ STATIC const char * S_get_num(pTHX_ register const char *patptr, I32 *lenptr ) 162505 { 162505 I32 len = *patptr++ - '0'; 175415 while (isDIGIT(*patptr)) { 12910 if (len >= 0x7FFFFFFF/10) ###### Perl_croak(aTHX_ "pack/unpack repeat count overflow"); 12910 len = (len * 10) + (*patptr++ - '0'); } 162505 *lenptr = len; 162505 return patptr; } /* The marvellous template parsing routine: Using state stored in *symptr, * locates next template code and count */ STATIC bool S_next_symbol(pTHX_ tempsym_t* symptr ) 449735 { 449735 const char* patptr = symptr->patptr; 449735 const char* patend = symptr->patend; 449735 symptr->flags &= ~FLAG_SLASH; 472874 while (patptr < patend) { 325843 if (isSPACE(*patptr)) 23120 patptr++; 302723 else if (*patptr == '#') { 12 patptr++; 184 while (patptr < patend && *patptr != '\n') 172 patptr++; 12 if (patptr < patend) 12 patptr++; } else { /* We should have found a template code */ 302711 I32 code = *patptr++ & 0xFF; 302711 U32 inherited_modifiers = 0; 302711 if (code == ','){ /* grandfather in commas but with a warning */ 7 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){ 4 symptr->flags |= FLAG_COMMA; 4 Perl_warner(aTHX_ packWARN(WARN_UNPACK), "Invalid type ',' in %s", _action( symptr ) ); } 4 continue; } /* for '(', skip to ')' */ 302704 if (code == '(') { 6749 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' ) 4 Perl_croak(aTHX_ "()-group starts with a count in %s", _action( symptr ) ); 6745 symptr->grpbeg = patptr; 6745 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') ); 6745 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL ) 1 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s", _action( symptr ) ); } /* look for group modifiers to inherit */ 302699 if (TYPE_ENDIANNESS(symptr->flags)) { 296 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code))) 268 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags); } /* look for modifiers */ 327503 while (patptr < patend) { 297809 const char *allowed; 297809 I32 modifier; 297809 switch (*patptr) { case '!': 10002 modifier = TYPE_IS_SHRIEKING; 10002 allowed = SHRIEKING_ALLOWED_TYPES; 10002 break; #ifdef PERL_PACK_CAN_BYTEORDER case '>': 7458 modifier = TYPE_IS_BIG_ENDIAN; 7458 allowed = ENDIANNESS_ALLOWED_TYPES; 7458 break; case '<': 7460 modifier = TYPE_IS_LITTLE_ENDIAN; 7460 allowed = ENDIANNESS_ALLOWED_TYPES; 7460 break; #endif /* PERL_PACK_CAN_BYTEORDER */ default: 272889 allowed = ""; 272889 modifier = 0; 297809 break; } 297809 if (modifier == 0) 272889 break; 24920 if (!strchr(allowed, TYPE_NO_MODIFIERS(code))) 94 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr, allowed, _action( symptr ) ); 24826 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK) 16 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s", (int) TYPE_NO_MODIFIERS(code), _action( symptr ) ); 24810 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) == TYPE_ENDIANNESS_MASK) 6 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s", *patptr, _action( symptr ) ); 24804 if (ckWARN(WARN_UNPACK)) { 24348 if (code & modifier) 5 Perl_warner(aTHX_ packWARN(WARN_UNPACK), "Duplicate modifier '%c' after '%c' in %s", *patptr, (int) TYPE_NO_MODIFIERS(code), _action( symptr ) ); } 24804 code |= modifier; 24804 patptr++; } /* inherit modifiers */ 302583 code |= inherited_modifiers; /* look for count and/or / */ 302583 if (patptr < patend) { 272889 if (isDIGIT(*patptr)) { 151629 patptr = get_num( patptr, &symptr->length ); 151629 symptr->howlen = e_number; 121260 } else if (*patptr == '*') { 37235 patptr++; 37235 symptr->howlen = e_star; 84025 } else if (*patptr == '[') { 15295 const char* lenptr = ++patptr; 15295 symptr->howlen = e_number; 15295 patptr = group_end( patptr, patend, ']' ) + 1; /* what kind of [] is it? */ 15295 if (isDIGIT(*lenptr)) { 10876 lenptr = get_num( lenptr, &symptr->length ); 10876 if( *lenptr != ']' ) 1 Perl_croak(aTHX_ "Malformed integer in [] in %s", _action( symptr ) ); } else { 4419 tempsym_t savsym = *symptr; 4419 symptr->patend = patptr-1; 4419 symptr->patptr = lenptr; 4419 savsym.length = measure_struct(symptr); 4418 *symptr = savsym; } } else { 68730 symptr->howlen = e_no_len; 68730 symptr->length = 1; } /* try to find / */ 316610 while (patptr < patend) { 199258 if (isSPACE(*patptr)) 43709 patptr++; 155549 else if (*patptr == '#') { 14 patptr++; 156 while (patptr < patend && *patptr != '\n') 142 patptr++; 14 if (patptr < patend) 6 patptr++; } else { 155535 if (*patptr == '/') { 239 symptr->flags |= FLAG_SLASH; 239 patptr++; 239 if (patptr < patend && (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[')) 3 Perl_croak(aTHX_ "'/' does not take a repeat count in %s", _action( symptr ) ); } 29694 break; } } } else { /* at end - no count, no / */ 29694 symptr->howlen = e_no_len; 29694 symptr->length = 1; } 302578 symptr->code = code; 302578 symptr->patptr = patptr; 302578 return TRUE; } } 147031 symptr->patptr = patptr; 147031 return FALSE; } /* There is no way to cleanly handle the case where we should process the string per byte in its upgraded form while it's really in downgraded form (e.g. estimates like strend-s as an upper bound for the number of characters left wouldn't work). So if we foresee the need of this (pattern starts with U or contains U0), we want to work on the encoded version of the string. Users are advised to upgrade their pack string themselves if they need to do a lot of unpacks like this on it */ /* XXX These can be const */ STATIC bool need_utf8(const char *pat, const char *patend) 37501 { 37501 bool first = TRUE; 347625 while (pat < patend) { 310365 if (pat[0] == '#') { 26 pat++; 26 pat = (const char *) memchr(pat, '\n', patend-pat); 26 if (!pat) return FALSE; 310339 } else if (pat[0] == 'U') { 442 if (first || pat[1] == '0') return TRUE; 309897 } else first = FALSE; 310124 pat++; } 37260 return FALSE; } STATIC char 50207 first_symbol(const char *pat, const char *patend) { 50215 while (pat < patend) { 50214 if (pat[0] != '#') return pat[0]; 8 pat++; 8 pat = (const char *) memchr(pat, '\n', patend-pat); 8 if (!pat) return 0; 8 pat++; } 1 return 0; } /* =for apidoc unpack_str The engine implementing unpack() Perl function. Note: parameters strbeg, new_s and ocnt are not used. This call should not be used, use unpackstring instead. =cut */ I32 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags) ###### { ###### tempsym_t sym; ###### PERL_UNUSED_ARG(strbeg); ###### PERL_UNUSED_ARG(new_s); ###### PERL_UNUSED_ARG(ocnt); ###### if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; ###### else if (need_utf8(pat, patend)) { /* We probably should try to avoid this in case a scalar context call wouldn't get to the "U0" */ ###### STRLEN len = strend - s; ###### s = (char *) bytes_to_utf8((U8 *) s, &len); ###### SAVEFREEPV(s); ###### strend = s + len; ###### flags |= FLAG_DO_UTF8; } ###### if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) ###### flags |= FLAG_PARSE_UTF8; ###### TEMPSYM_INIT(&sym, pat, patend, flags); ###### return unpack_rec(&sym, s, s, strend, NULL ); } /* =for apidoc unpackstring The engine implementing unpack() Perl function. C puts the extracted list items on the stack and returns the number of elements. Issue C before and C after the call to this function. =cut */ I32 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags) 50207 { 50207 tempsym_t sym; 50207 if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; 37501 else if (need_utf8(pat, patend)) { /* We probably should try to avoid this in case a scalar context call wouldn't get to the "U0" */ 233 STRLEN len = strend - s; 233 s = (char *) bytes_to_utf8((U8 *) s, &len); 233 SAVEFREEPV(s); 233 strend = s + len; 233 flags |= FLAG_DO_UTF8; } 50207 if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) 7681 flags |= FLAG_PARSE_UTF8; 50207 TEMPSYM_INIT(&sym, pat, patend, flags); 50207 return unpack_rec(&sym, s, s, strend, NULL ); } STATIC I32 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s ) 50538 { 50538 dVAR; dSP; 50538 SV *sv; 50538 const I32 start_sp_offset = SP - PL_stack_base; 50538 howlen_t howlen; 50538 I32 checksum = 0; 50538 UV cuv = 0; 50538 NV cdouble = 0.0; 50538 const int bits_in_uv = CHAR_BIT * sizeof(cuv); 50538 bool beyond = FALSE; 50538 bool explicit_length; 50538 const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0; 50538 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; 50538 symptr->strbeg = s - strbeg; 210450 while (next_symbol(symptr)) { 159937 packprops_t props; 159937 I32 len; 159937 I32 datumtype = symptr->code; /* do first one only unless in list context / is implemented by unpacking the count, then popping it from the stack, so must check that we're not in the middle of a / */ 159937 if ( unpack_only_one && (SP - PL_stack_base == start_sp_offset + 1) && (datumtype != '/') ) /* XXX can this be omitted */ 6 break; 159931 switch (howlen = symptr->howlen) { case e_star: 14717 len = strend - strbeg; /* long enough */ 14717 break; default: /* e_no_len and e_number */ 145214 len = symptr->length; 159931 break; } 159931 explicit_length = TRUE; redo_switch: 160108 beyond = s >= strend; 160108 props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; 160108 if (props) { /* props nonzero means we can process this letter. */ 71097 const long size = props & PACK_SIZE_MASK; 71097 const long howmany = (strend - s) / size; 71097 if (len > howmany) 1067 len = howmany; 71097 if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) { 69912 if (len && unpack_only_one) len = 1; 69912 EXTEND(SP, len); 69912 EXTEND_MORTAL(len); } } 160108 switch(TYPE_NO_ENDIANNESS(datumtype)) { default: 4 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); case '%': 1191 if (howlen == e_no_len) 171 len = 16; /* len is not specified */ 1191 checksum = len; 1191 cuv = 0; 1191 cdouble = 0; 1191 continue; 141 break; case '(': { 141 tempsym_t savsym = *symptr; 141 const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); 141 symptr->flags |= group_modifiers; 141 symptr->patend = savsym.grpend; 141 symptr->previous = &savsym; 141 symptr->level++; 141 PUTBACK; 462 while (len--) { 331 symptr->patptr = savsym.grpbeg; 331 if (utf8) symptr->flags |= FLAG_PARSE_UTF8; 318 else symptr->flags &= ~FLAG_PARSE_UTF8; 331 unpack_rec(symptr, s, strbeg, strend, &s); 325 if (s == strend && savsym.howlen == e_star) 135 break; /* No way to continue */ } 135 SPAGAIN; 135 savsym.flags = symptr->flags & ~group_modifiers; 135 *symptr = savsym; 135 break; } #ifdef PERL_PACK_CAN_SHRIEKSIGN case '.' | TYPE_IS_SHRIEKING: #endif case '.': { 35 const char *from; 35 SV *sv; #ifdef PERL_PACK_CAN_SHRIEKSIGN 35 const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); #else /* PERL_PACK_CAN_SHRIEKSIGN */ const bool u8 = utf8; #endif 35 if (howlen == e_star) from = strbeg; 30 else if (len <= 0) from = s; else { 24 tempsym_t *group = symptr; 34 while (--len && group) group = group->previous; 24 from = group ? strbeg + group->strbeg : strbeg; } 35 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))); 35 XPUSHs(sv_2mortal(sv)); 35 break; } #ifdef PERL_PACK_CAN_SHRIEKSIGN case '@' | TYPE_IS_SHRIEKING: #endif case '@': 35 s = strbeg + symptr->strbeg; #ifdef PERL_PACK_CAN_SHRIEKSIGN 35 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) #else /* PERL_PACK_CAN_SHRIEKSIGN */ if (utf8) #endif { 48 while (len > 0) { 39 if (s >= strend) ###### Perl_croak(aTHX_ "'@' outside of string in unpack"); 39 s += UTF8SKIP(s); 39 len--; } 9 if (s > strend) ###### Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack"); } else { 26 if (strend-s < len) ###### Perl_croak(aTHX_ "'@' outside of string in unpack"); 26 s += len; } 26 break; case 'X' | TYPE_IS_SHRIEKING: 7 if (!len) /* Avoid division by 0 */ ###### len = 1; 7 if (utf8) { 3 const char *hop, *last; 3 I32 l = len; 3 hop = last = strbeg; 17 while (hop < s) { 14 hop += UTF8SKIP(hop); 14 if (--l == 0) { 2 last = hop; 2 l = len; } } 3 if (last > s) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 3 s = last; 3 break; } 4 len = (s - strbeg) % len; /* FALL THROUGH */ case 'X': 24 if (utf8) { 15 while (len > 0) { 10 if (s <= strbeg) ###### Perl_croak(aTHX_ "'X' outside of string in unpack"); 28 while (--s, UTF8_IS_CONTINUATION(*s)) { 18 if (s <= strbeg) ###### Perl_croak(aTHX_ "'X' outside of string in unpack"); } 10 len--; } } else { 19 if (len > s - strbeg) ###### Perl_croak(aTHX_ "'X' outside of string in unpack" ); 19 s -= len; } 19 break; case 'x' | TYPE_IS_SHRIEKING: { 12 I32 ai32; 12 if (!len) /* Avoid division by 0 */ ###### len = 1; 12 if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len; 10 else ai32 = (s - strbeg) % len; 12 if (ai32 == 0) break; 6 len -= ai32; } /* FALL THROUGH */ case 'x': 4544 if (utf8) { 1158 while (len>0) { 1082 if (s >= strend) ###### Perl_croak(aTHX_ "'x' outside of string in unpack"); 1082 s += UTF8SKIP(s); 1082 len--; } } else { 4468 if (len > strend - s) ###### Perl_croak(aTHX_ "'x' outside of string in unpack"); 4468 s += len; } 4468 break; case '/': 2 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); 82636 break; case 'A': case 'Z': case 'a': 82636 if (checksum) { /* Preliminary length estimate is assumed done in 'W' */ ###### if (len > strend - s) len = strend - s; ###### goto W_checksum; } 82636 if (utf8) { 34 I32 l; 34 const char *hop; 102 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) { 83 if (hop >= strend) { 15 if (hop > strend) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 68 break; } } 34 if (hop > strend) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 34 len = hop - s; 82602 } else if (len > strend - s) 10 len = strend - s; 82636 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ 23 const char *ptr, *end; 23 end = s + len; 23 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break; 23 sv = newSVpvn(s, ptr-s); 23 if (howlen == e_star) /* exact for 'Z*' */ 6 len = ptr-s + (ptr != strend ? 1 : 0); 82613 } else if (datumtype == 'A') { /* 'A' strips both nulls and spaces */ 1531 const char *ptr; 1531 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) { 30 for (ptr = s+len-1; ptr >= s; ptr--) 28 if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) && 4 !is_utf8_space((U8 *) ptr)) break; 6 if (ptr >= s) ptr += UTF8SKIP(ptr); 2 else ptr++; 6 if (ptr > s+len) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); } else { 38756 for (ptr = s+len-1; ptr >= s; ptr--) 38410 if (*ptr != 0 && !isSPACE(*ptr)) break; 1525 ptr++; } 1531 sv = newSVpvn(s, ptr-s); 81082 } else sv = newSVpvn(s, len); 82636 if (utf8) { 34 SvUTF8_on(sv); /* Undo any upgrade done due to need_utf8() */ 34 if (!(symptr->flags & FLAG_WAS_UTF8)) 10 sv_utf8_downgrade(sv, 0); } 82636 XPUSHs(sv_2mortal(sv)); 82636 s += len; 82636 break; case 'B': case 'b': { 91 char *str; 91 if (howlen == e_star || len > (strend - s) * 8) 4 len = (strend - s) * 8; 91 if (checksum) { 6 if (!PL_bitcount) { 1 int bits; 1 Newz(601, PL_bitcount, 256, char); 256 for (bits = 1; bits < 256; bits++) { 255 if (bits & 1) PL_bitcount[bits]++; 255 if (bits & 2) PL_bitcount[bits]++; 255 if (bits & 4) PL_bitcount[bits]++; 255 if (bits & 8) PL_bitcount[bits]++; 255 if (bits & 16) PL_bitcount[bits]++; 255 if (bits & 32) PL_bitcount[bits]++; 255 if (bits & 64) PL_bitcount[bits]++; 255 if (bits & 128) PL_bitcount[bits]++; } } 6 if (utf8) ###### while (len >= 8 && s < strend) { ###### cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)]; ###### len -= 8; } else 8259 while (len >= 8) { 8253 cuv += PL_bitcount[*(U8 *)s++]; 8253 len -= 8; } 6 if (len && s < strend) { 3 U8 bits; 3 bits = SHIFT_BYTE(utf8, s, strend, datumtype); 3 if (datumtype == 'b') 9 while (len-- > 0) { 7 if (bits & 1) cuv++; 7 bits >>= 1; } else 6 while (len-- > 0) { 5 if (bits & 0x80) cuv++; 5 bits <<= 1; } } 85 break; } 85 sv = sv_2mortal(NEWSV(35, len ? len : 1)); 85 SvPOK_on(sv); 85 str = SvPVX(sv); 85 if (datumtype == 'b') { 83 U8 bits = 0; 83 const I32 ai32 = len; 66927 for (len = 0; len < ai32; len++) { 66844 if (len & 7) bits >>= 1; 8358 else if (utf8) { 3 if (s >= strend) break; 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 8355 } else bits = *(U8 *) s++; 66844 *str++ = bits & 1 ? '1' : '0'; } } else { 2 U8 bits = 0; 2 const I32 ai32 = len; 44 for (len = 0; len < ai32; len++) { 42 if (len & 7) bits <<= 1; 6 else if (utf8) { 3 if (s >= strend) break; 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 3 } else bits = *(U8 *) s++; 42 *str++ = bits & 0x80 ? '1' : '0'; } } 85 *str = '\0'; 85 SvCUR_set(sv, str - SvPVX_const(sv)); 85 XPUSHs(sv); 85 break; } case 'H': case 'h': { 260 char *str; /* Preliminary length estimate, acceptable for utf8 too */ 260 if (howlen == e_star || len > (strend - s) * 2) 212 len = (strend - s) * 2; 260 sv = sv_2mortal(NEWSV(35, len ? len : 1)); 260 SvPOK_on(sv); 260 str = SvPVX(sv); 260 if (datumtype == 'h') { 46 U8 bits = 0; 46 I32 ai32 = len; 232 for (len = 0; len < ai32; len++) { 186 if (len & 1) bits >>= 4; 94 else if (utf8) { 3 if (s >= strend) break; 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 91 } else bits = * (U8 *) s++; 186 *str++ = PL_hexdigit[bits & 15]; } } else { 214 U8 bits = 0; 214 const I32 ai32 = len; 1712 for (len = 0; len < ai32; len++) { 1498 if (len & 1) bits <<= 4; 750 else if (utf8) { 3 if (s >= strend) break; 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 747 } else bits = *(U8 *) s++; 1498 *str++ = PL_hexdigit[(bits >> 4) & 15]; } } 260 *str = '\0'; 260 SvCUR_set(sv, str - SvPVX_const(sv)); 260 XPUSHs(sv); 260 break; } case 'c': 388 while (len-- > 0) { 236 int aint = SHIFT_BYTE(utf8, s, strend, datumtype); 236 if (aint >= 128) /* fake up signed chars */ 43 aint -= 256; 236 if (!checksum) 143 PUSHs(sv_2mortal(newSViv((IV)aint))); 93 else if (checksum > bits_in_uv) 30 cdouble += (NV)aint; else 63 cuv += aint; } 50197 break; case 'C': case 'W': W_checksum: 50197 if (len == 0) { 260 if (explicit_length && datumtype == 'C') /* Switch to "character" mode */ 258 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; 258 break; } 49937 if (datumtype == 'C' ? (symptr->flags & FLAG_DO_UTF8) && !(symptr->flags & FLAG_WAS_UTF8) : utf8) { 266 while (len-- > 0 && s < strend) { 193 STRLEN retlen; 193 const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, 193 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 193 if (retlen == (STRLEN) -1 || retlen == 0) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 193 s += retlen; 193 if (!checksum) 58 PUSHs(sv_2mortal(newSVuv((UV) val))); 135 else if (checksum > bits_in_uv) 54 cdouble += (NV) val; else 81 cuv += val; } 49864 } else if (!checksum) 1296687 while (len-- > 0) { 1246968 const U8 ch = *(U8 *) s++; 1246968 PUSHs(sv_2mortal(newSVuv((UV) ch))); } 145 else if (checksum > bits_in_uv) 36 while (len-- > 0) cdouble += (NV) *(U8 *) s++; else 66036 while (len-- > 0) cuv += *(U8 *) s++; 5568 break; case 'U': 5568 if (len == 0) { 480 if (explicit_length) { /* Switch to "bytes in UTF-8" mode */ 478 if (symptr->flags & FLAG_DO_UTF8) utf8 = 0; else /* Should be impossible due to the need_utf8() test */ ###### Perl_croak(aTHX_ "U0 mode on a byte string"); } 5088 break; } 5088 if (len > strend - s) len = strend - s; 5088 if (!checksum) { 5080 if (len && unpack_only_one) len = 1; 5080 EXTEND(SP, len); 5080 EXTEND_MORTAL(len); } 14230 while (len-- > 0 && s < strend) { 9142 STRLEN retlen; 9142 UV auv; 9142 if (utf8) { 19 U8 result[UTF8_MAXLEN]; 19 const char *ptr = s; 19 STRLEN len; /* Bug: warns about bad utf8 even if we are short on bytes and will break out of the loop */ 19 if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1, 'U')) ###### break; 19 len = UTF8SKIP(result); 19 if (!uni_to_bytes(aTHX_ &ptr, strend, ###### (char *) &result[1], len-1, 'U')) break; 19 auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV); 19 s = ptr; } else { 9123 auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV); 9123 if (retlen == (STRLEN) -1 || retlen == 0) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 9123 s += retlen; } 9142 if (!checksum) 9122 PUSHs(sv_2mortal(newSVuv((UV) auv))); 20 else if (checksum > bits_in_uv) 2 cdouble += (NV) auv; else 18 cuv += auv; } 202 break; case 's' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 while (len-- > 0) { short ashort; SHIFT_VAR(utf8, s, strend, ashort, datumtype); DO_BO_UNPACK(ashort, s); if (!checksum) PUSHs(sv_2mortal(newSViv((IV)ashort))); else if (checksum > bits_in_uv) cdouble += (NV)ashort; else cuv += ashort; } break; #else /* Fallthrough! */ #endif case 's': 821 while (len-- > 0) { 619 I16 ai16; #if U16SIZE > SIZE16 ai16 = 0; #endif 619 SHIFT16(utf8, s, strend, &ai16, datumtype); 619 DO_BO_UNPACK(ai16, 16); #if U16SIZE > SIZE16 if (ai16 > 32767) ai16 -= 65536; #endif 619 if (!checksum) 151 PUSHs(sv_2mortal(newSViv((IV)ai16))); 468 else if (checksum > bits_in_uv) 180 cdouble += (NV)ai16; else 288 cuv += ai16; } 8758 break; case 'S' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 while (len-- > 0) { unsigned short aushort; SHIFT_VAR(utf8, s, strend, aushort, datumtype); DO_BO_UNPACK(aushort, s); if (!checksum) PUSHs(sv_2mortal(newSVuv((UV) aushort))); else if (checksum > bits_in_uv) cdouble += (NV)aushort; else cuv += aushort; } break; #else /* Fallhrough! */ #endif case 'v': case 'n': case 'S': 371860 while (len-- > 0) { 363102 U16 au16; #if U16SIZE > SIZE16 au16 = 0; #endif 363102 SHIFT16(utf8, s, strend, &au16, datumtype); 363102 DO_BO_UNPACK(au16, 16); #ifdef HAS_NTOHS 363102 if (datumtype == 'n') 361777 au16 = PerlSock_ntohs(au16); #endif #ifdef HAS_VTOHS if (datumtype == 'v') au16 = vtohs(au16); #endif 363102 if (!checksum) 34768 PUSHs(sv_2mortal(newSVuv((UV)au16))); 328334 else if (checksum > bits_in_uv) 327920 cdouble += (NV) au16; else 414 cuv += au16; } 44 break; #ifdef PERL_PACK_CAN_SHRIEKSIGN case 'v' | TYPE_IS_SHRIEKING: case 'n' | TYPE_IS_SHRIEKING: 208 while (len-- > 0) { 164 I16 ai16; # if U16SIZE > SIZE16 ai16 = 0; # endif 164 SHIFT16(utf8, s, strend, &ai16, datumtype); # ifdef HAS_NTOHS 164 if (datumtype == ('n' | TYPE_IS_SHRIEKING)) 82 ai16 = (I16) PerlSock_ntohs((U16) ai16); # endif /* HAS_NTOHS */ # ifdef HAS_VTOHS if (datumtype == ('v' | TYPE_IS_SHRIEKING)) ai16 = (I16) vtohs((U16) ai16); # endif /* HAS_VTOHS */ 164 if (!checksum) 14 PUSHs(sv_2mortal(newSViv((IV)ai16))); 150 else if (checksum > bits_in_uv) 60 cdouble += (NV) ai16; else 90 cuv += ai16; } 200 break; #endif /* PERL_PACK_CAN_SHRIEKSIGN */ case 'i': case 'i' | TYPE_IS_SHRIEKING: 847 while (len-- > 0) { 647 int aint; 647 SHIFT_VAR(utf8, s, strend, aint, datumtype); 647 DO_BO_UNPACK(aint, i); 647 if (!checksum) 99 PUSHs(sv_2mortal(newSViv((IV)aint))); 548 else if (checksum > bits_in_uv) 180 cdouble += (NV)aint; else 368 cuv += aint; } 205 break; case 'I': case 'I' | TYPE_IS_SHRIEKING: 851 while (len-- > 0) { 646 unsigned int auint; 646 SHIFT_VAR(utf8, s, strend, auint, datumtype); 646 DO_BO_UNPACK(auint, i); 646 if (!checksum) 178 PUSHs(sv_2mortal(newSVuv((UV)auint))); 468 else if (checksum > bits_in_uv) 180 cdouble += (NV)auint; else 288 cuv += auint; } 101 break; case 'j': 412 while (len-- > 0) { 311 IV aiv; 311 SHIFT_VAR(utf8, s, strend, aiv, datumtype); #if IVSIZE == INTSIZE 311 DO_BO_UNPACK(aiv, i); #elif IVSIZE == LONGSIZE DO_BO_UNPACK(aiv, l); #elif defined(HAS_QUAD) && IVSIZE == U64SIZE DO_BO_UNPACK(aiv, 64); #else Perl_croak(aTHX_ "'j' not supported on this platform"); #endif 311 if (!checksum) 68 PUSHs(sv_2mortal(newSViv(aiv))); 243 else if (checksum > bits_in_uv) 90 cdouble += (NV)aiv; else 153 cuv += aiv; } 149 break; case 'J': 556 while (len-- > 0) { 407 UV auv; 407 SHIFT_VAR(utf8, s, strend, auv, datumtype); #if IVSIZE == INTSIZE 407 DO_BO_UNPACK(auv, i); #elif IVSIZE == LONGSIZE DO_BO_UNPACK(auv, l); #elif defined(HAS_QUAD) && IVSIZE == U64SIZE DO_BO_UNPACK(auv, 64); #else Perl_croak(aTHX_ "'J' not supported on this platform"); #endif 407 if (!checksum) 164 PUSHs(sv_2mortal(newSVuv(auv))); 243 else if (checksum > bits_in_uv) 90 cdouble += (NV)auv; else 153 cuv += auv; } 209 break; case 'l' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 while (len-- > 0) { long along; SHIFT_VAR(utf8, s, strend, along, datumtype); DO_BO_UNPACK(along, l); if (!checksum) PUSHs(sv_2mortal(newSViv((IV)along))); else if (checksum > bits_in_uv) cdouble += (NV)along; else cuv += along; } break; #else /* Fallthrough! */ #endif case 'l': 799 while (len-- > 0) { 590 I32 ai32; #if U32SIZE > SIZE32 ai32 = 0; #endif 590 SHIFT32(utf8, s, strend, &ai32, datumtype); 590 DO_BO_UNPACK(ai32, 32); #if U32SIZE > SIZE32 if (ai32 > 2147483647) ai32 -= 4294967296; #endif 590 if (!checksum) 122 PUSHs(sv_2mortal(newSViv((IV)ai32))); 468 else if (checksum > bits_in_uv) 180 cdouble += (NV)ai32; else 288 cuv += ai32; } 4947 break; case 'L' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 while (len-- > 0) { unsigned long aulong; SHIFT_VAR(utf8, s, strend, aulong, datumtype); DO_BO_UNPACK(aulong, l); if (!checksum) PUSHs(sv_2mortal(newSVuv((UV)aulong))); else if (checksum > bits_in_uv) cdouble += (NV)aulong; else cuv += aulong; } break; #else /* Fall through! */ #endif case 'V': case 'N': case 'L': 23652 while (len-- > 0) { 18705 U32 au32; #if U32SIZE > SIZE32 au32 = 0; #endif 18705 SHIFT32(utf8, s, strend, &au32, datumtype); 18705 DO_BO_UNPACK(au32, 32); #ifdef HAS_NTOHL 18705 if (datumtype == 'N') 17814 au32 = PerlSock_ntohl(au32); #endif #ifdef HAS_VTOHL if (datumtype == 'V') au32 = vtohl(au32); #endif 18705 if (!checksum) 18051 PUSHs(sv_2mortal(newSVuv((UV)au32))); 654 else if (checksum > bits_in_uv) 240 cdouble += (NV)au32; else 414 cuv += au32; } 44 break; #ifdef PERL_PACK_CAN_SHRIEKSIGN case 'V' | TYPE_IS_SHRIEKING: case 'N' | TYPE_IS_SHRIEKING: 208 while (len-- > 0) { 164 I32 ai32; # if U32SIZE > SIZE32 ai32 = 0; # endif 164 SHIFT32(utf8, s, strend, &ai32, datumtype); # ifdef HAS_NTOHL 164 if (datumtype == ('N' | TYPE_IS_SHRIEKING)) 82 ai32 = (I32)PerlSock_ntohl((U32)ai32); # endif # ifdef HAS_VTOHL if (datumtype == ('V' | TYPE_IS_SHRIEKING)) ai32 = (I32)vtohl((U32)ai32); # endif 164 if (!checksum) 14 PUSHs(sv_2mortal(newSViv((IV)ai32))); 150 else if (checksum > bits_in_uv) 60 cdouble += (NV)ai32; else 90 cuv += ai32; } 8 break; #endif /* PERL_PACK_CAN_SHRIEKSIGN */ case 'p': 16 while (len-- > 0) { 8 const char *aptr; 8 SHIFT_VAR(utf8, s, strend, aptr, datumtype); 8 DO_BO_UNPACK_PC(aptr); /* newSVpv generates undef if aptr is NULL */ 8 PUSHs(sv_2mortal(newSVpv(aptr, 0))); } 24 break; case 'w': { 24 UV auv = 0; 24 U32 bytes = 0; 123 while (len > 0 && s < strend) { 99 U8 ch; 99 ch = SHIFT_BYTE(utf8, s, strend, datumtype); 99 auv = (auv << 7) | (ch & 0x7f); /* UTF8_IS_XXXXX not right here - using constant 0x80 */ 99 if (ch < 0x80) { 25 bytes = 0; 25 PUSHs(sv_2mortal(newSVuv(auv))); 25 len--; 25 auv = 0; 25 continue; } 74 if (++bytes >= sizeof(UV)) { /* promote to string */ 15 const char *t; 15 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); 187 while (s < strend) { 185 ch = SHIFT_BYTE(utf8, s, strend, datumtype); 185 sv = mul128(sv, (U8)(ch & 0x7f)); 185 if (!(ch & 0x80)) { 13 bytes = 0; break; } } 15 t = SvPV_nolen_const(sv); 123 while (*t == '0') 108 t++; 15 sv_chop(sv, t); 15 PUSHs(sv_2mortal(sv)); 15 len--; 15 auv = 0; } } 24 if ((s >= strend) && bytes) 3 Perl_croak(aTHX_ "Unterminated compressed integer in unpack"); } 3 break; case 'P': 3 if (symptr->howlen == e_star) 1 Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); 2 EXTEND(SP, 1); 2 if (sizeof(char*) <= strend - s) { 2 char *aptr; 2 SHIFT_VAR(utf8, s, strend, aptr, datumtype); 2 DO_BO_UNPACK_PC(aptr); /* newSVpvn generates undef if aptr is NULL */ 2 PUSHs(sv_2mortal(newSVpvn(aptr, len))); } 2 break; #ifdef HAS_QUAD case 'q': while (len-- > 0) { Quad_t aquad; 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))); else if (checksum > bits_in_uv) cdouble += (NV)aquad; else cuv += aquad; } break; case 'Q': while (len-- > 0) { Uquad_t auquad; 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))); else if (checksum > bits_in_uv) cdouble += (NV)auquad; else cuv += auquad; } break; #endif /* HAS_QUAD */ /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': 393 while (len-- > 0) { 297 float afloat; 297 SHIFT_VAR(utf8, s, strend, afloat, datumtype); 297 DO_BO_UNPACK_N(afloat, float); 297 if (!checksum) 54 PUSHs(sv_2mortal(newSVnv((NV)afloat))); else 243 cdouble += afloat; } 100 break; case 'd': 401 while (len-- > 0) { 301 double adouble; 301 SHIFT_VAR(utf8, s, strend, adouble, datumtype); 301 DO_BO_UNPACK_N(adouble, double); 301 if (!checksum) 58 PUSHs(sv_2mortal(newSVnv((NV)adouble))); else 243 cdouble += adouble; } 93 break; case 'F': 384 while (len-- > 0) { 291 NV anv; 291 SHIFT_VAR(utf8, s, strend, anv, datumtype); 291 DO_BO_UNPACK_N(anv, NV); 291 if (!checksum) 48 PUSHs(sv_2mortal(newSVnv(anv))); else 243 cdouble += anv; } 36 break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': while (len-- > 0) { long double aldouble; SHIFT_VAR(utf8, s, strend, aldouble, datumtype); DO_BO_UNPACK_N(aldouble, long double); if (!checksum) PUSHs(sv_2mortal(newSVnv((NV)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) */ 36 if (PL_uudmap['M'] == 0) { 5 int i; 330 for (i = 0; i < sizeof(PL_uuemap); i += 1) 325 PL_uudmap[(U8)PL_uuemap[i]] = i; /* * Because ' ' and '`' map to the same value, * we need to decode them both the same. */ 5 PL_uudmap[' '] = 0; } { 36 const STRLEN l = (STRLEN) (strend - s) * 3 / 4; 36 sv = sv_2mortal(NEWSV(42, l)); 36 if (l) SvPOK_on(sv); } 36 if (utf8) { 2 while (next_uni_uu(aTHX_ &s, strend, &len)) { 1 I32 a, b, c, d; 1 char hunk[4]; 1 hunk[3] = '\0'; 5 while (len > 0) { 4 next_uni_uu(aTHX_ &s, strend, &a); 4 next_uni_uu(aTHX_ &s, strend, &b); 4 next_uni_uu(aTHX_ &s, strend, &c); 4 next_uni_uu(aTHX_ &s, strend, &d); 4 hunk[0] = (char)((a << 2) | (b >> 4)); 4 hunk[1] = (char)((b << 4) | (c >> 2)); 4 hunk[2] = (char)((c << 6) | d); 4 sv_catpvn(sv, hunk, (len > 3) ? 3 : len); 4 len -= 3; } 1 if (s < strend) { 1 if (*s == '\n') { 1 s++; } else { /* possible checksum byte */ ###### const char *skip = s+UTF8SKIP(s); ###### if (skip < strend && *skip == '\n') ###### s = skip+1; } } } } else { 122 while (s < strend && *s > ' ' && ISUUCHAR(*s)) { 87 I32 a, b, c, d; 87 char hunk[4]; 87 hunk[3] = '\0'; 87 len = PL_uudmap[*(U8*)s++] & 077; 1136 while (len > 0) { 1049 if (s < strend && ISUUCHAR(*s)) 1048 a = PL_uudmap[*(U8*)s++] & 077; else 1 a = 0; 1049 if (s < strend && ISUUCHAR(*s)) 1048 b = PL_uudmap[*(U8*)s++] & 077; else 1 b = 0; 1049 if (s < strend && ISUUCHAR(*s)) 1048 c = PL_uudmap[*(U8*)s++] & 077; else 1 c = 0; 1049 if (s < strend && ISUUCHAR(*s)) 1048 d = PL_uudmap[*(U8*)s++] & 077; else 1 d = 0; 1049 hunk[0] = (char)((a << 2) | (b >> 4)); 1049 hunk[1] = (char)((b << 4) | (c >> 2)); 1049 hunk[2] = (char)((c << 6) | d); 1049 sv_catpvn(sv, hunk, (len > 3) ? 3 : len); 1049 len -= 3; } 87 if (*s == '\n') 86 s++; else /* possible checksum byte */ 1 if (s + 1 < strend && s[1] == '\n') ###### s += 2; } } 36 XPUSHs(sv); 158901 break; } 158901 if (checksum) { 1191 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) || (checksum > bits_in_uv && strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { 478 NV trouble, anv; 478 anv = (NV) (1 << (checksum & 15)); 1754 while (checksum >= 16) { 1276 checksum -= 16; 1276 anv *= 65536.0; } 634 while (cdouble < 0.0) 156 cdouble += anv; 478 cdouble = Perl_modf(cdouble / anv, &trouble) * anv; 478 sv = newSVnv(cdouble); } else { 713 if (checksum < bits_in_uv) { 636 UV mask = ((UV)1 << checksum) - 1; 636 cuv &= mask; } 713 sv = newSVuv(cuv); } 1191 XPUSHs(sv_2mortal(sv)); 1191 checksum = 0; } 158901 if (symptr->flags & FLAG_SLASH){ 180 if (SP - PL_stack_base - start_sp_offset <= 0) ###### Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); 180 if( next_symbol(symptr) ){ 179 if( symptr->howlen == e_number ) ###### Perl_croak(aTHX_ "Count after length/code in unpack" ); 179 if( beyond ){ /* ...end of char buffer then no decent length available */ 2 Perl_croak(aTHX_ "length/code after end of string in unpack" ); } else { /* take top of stack (hope it's numeric) */ 177 len = POPi; 177 if( len < 0 ) ###### Perl_croak(aTHX_ "Negative '/' count in unpack" ); } } else { 1 Perl_croak(aTHX_ "Code missing after '/' in unpack" ); } 177 datumtype = symptr->code; 177 explicit_length = FALSE; 177 goto redo_switch; } } 50500 if (new_s) 325 *new_s = s; 50500 PUTBACK; 50500 return SP - PL_stack_base - start_sp_offset; } PP(pp_unpack) 50207 { 50207 dSP; 50207 dPOPPOPssrl; 50207 I32 gimme = GIMME_V; 50207 STRLEN llen; 50207 STRLEN rlen; 50207 const char *pat = SvPV_const(left, llen); 50207 const char *s = SvPV_const(right, rlen); 50207 const char *strend = s + rlen; 50207 const char *patend = pat + llen; 50207 I32 cnt; 50207 PUTBACK; 50207 cnt = unpackstring(pat, patend, s, strend, ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0) | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0)); 50175 SPAGAIN; 50175 if ( !cnt && gimme == G_SCALAR ) 3 PUSHs(&PL_sv_undef); 50175 RETURN; } STATIC U8 * doencodes(U8 *h, const char *s, I32 len) 101 { 101 *h++ = PL_uuemap[len]; 486 while (len > 2) { 385 *h++ = PL_uuemap[(077 & (s[0] >> 2))]; 385 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))]; 385 *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; 385 *h++ = PL_uuemap[(077 & (s[2] & 077))]; 385 s += 3; 385 len -= 3; } 101 if (len > 0) { 57 const char r = (len > 1 ? s[1] : '\0'); 57 *h++ = PL_uuemap[(077 & (s[0] >> 2))]; 57 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))]; 57 *h++ = PL_uuemap[(077 & ((r << 2) & 074))]; 57 *h++ = PL_uuemap[0]; } 101 *h++ = '\n'; 101 return h; } STATIC SV * S_is_an_int(pTHX_ const char *s, STRLEN l) 8 { 8 SV *result = newSVpvn(s, l); 8 char *const result_c = SvPV_nolen(result); /* convenience */ 8 char *out = result_c; 8 bool skip = 1; 8 bool ignore = 0; 153 while (*s) { 146 switch (*s) { case ' ': ###### break; case '+': ###### if (!skip) { ###### SvREFCNT_dec(result); ###### return (NULL); } 145 break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': 145 skip = 0; 145 if (!ignore) { 145 *(out++) = *s; } 145 break; case '.': ###### ignore = 1; ###### break; default: 1 SvREFCNT_dec(result); 1 return (NULL); } 145 s++; } 7 *(out++) = '\0'; 7 SvCUR_set(result, out - result_c); 7 return (result); } /* pnum must be '\0' terminated */ STATIC int S_div128(pTHX_ SV *pnum, bool *done) 64 { 64 STRLEN len; 64 char * const s = SvPV(pnum, len); 64 char *t = s; 64 int m = 0; 64 *done = 1; 1406 while (*t) { 1342 const int i = m * 10 + (*t - '0'); 1342 const int r = (i >> 7); /* r < 10 */ 1342 m = i & 0x7F; 1342 if (r) { 551 *done = 0; } 1342 *(t++) = '0' + r; } 64 *(t++) = '\0'; 64 SvCUR_set(pnum, (STRLEN) (t - s)); 64 return (m); } /* =for apidoc pack_cat The engine implementing pack() Perl function. Note: parameters next_in_list and flags are not used. This call should not be used; use packlist instead. =cut */ void Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) ###### { ###### tempsym_t sym; ###### PERL_UNUSED_ARG(next_in_list); ###### PERL_UNUSED_ARG(flags); ###### TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); ###### (void)pack_rec( cat, &sym, beglist, endlist ); } /* =for apidoc packlist The engine implementing pack() Perl function. =cut */ void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist ) 71852 { 71852 STRLEN no_len; 71852 tempsym_t sym; 71852 TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); /* We're going to do changes through SvPVX(cat). Make sure it's valid. Also make sure any UTF8 flag is loaded */ 71852 SvPV_force(cat, no_len); 71852 if (DO_UTF8(cat)) sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; 71852 (void)pack_rec( cat, &sym, beglist, endlist ); } /* like sv_utf8_upgrade, but also repoint the group start markers */ STATIC void 20565 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { 20565 STRLEN len; 20565 tempsym_t *group; 20565 const char *from_ptr, *from_start, *from_end, **marks, **m; 20565 char *to_start, *to_ptr; 20565 if (SvUTF8(sv)) return; 20565 from_start = SvPVX_const(sv); 20565 from_end = from_start + SvCUR(sv); 20641 for (from_ptr = from_start; from_ptr < from_end; from_ptr++) 94 if (!NATIVE_IS_INVARIANT(*from_ptr)) break; 20565 if (from_ptr == from_end) { /* Simple case: no character needs to be changed */ 20547 SvUTF8_on(sv); 20547 return; } 18 len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1; 18 New('U', to_start, len, char); 18 Copy(from_start, to_start, from_ptr-from_start, char); 18 to_ptr = to_start + (from_ptr-from_start); 18 New('U', marks, sym_ptr->level+2, const char *); 42 for (group=sym_ptr; group; group = group->previous) 24 marks[group->level] = from_start + group->strbeg; 18 marks[sym_ptr->level+1] = from_end+1; 33 for (m = marks; *m < from_ptr; m++) 15 *m = to_start + (*m-from_start); 96 for (;from_ptr < from_end; from_ptr++) { 48 while (*m == from_ptr) *m++ = to_ptr; 39 to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr); } 18 *to_ptr = 0; 18 while (*m == from_ptr) *m++ = to_ptr; 18 if (m != marks + sym_ptr->level+1) { ###### Safefree(marks); ###### Safefree(to_start); ###### Perl_croak(aTHX_ "Assertion: marks beyond string end"); } 42 for (group=sym_ptr; group; group = group->previous) 24 group->strbeg = marks[group->level] - to_start; 18 Safefree(marks); 18 if (SvOOK(sv)) { ###### if (SvIVX(sv)) { ###### SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); ###### from_start -= SvIVX(sv); ###### SvIV_set(sv, 0); } ###### SvFLAGS(sv) &= ~SVf_OOK; } 18 if (SvLEN(sv) != 0) 18 Safefree(from_start); 18 SvPV_set(sv, to_start); 18 SvCUR_set(sv, to_ptr - to_start); 18 SvLEN_set(sv, len); 18 SvUTF8_on(sv); } /* Exponential string grower. Makes string extension effectively O(n) needed says how many extra bytes we need (not counting the final '\0') Only grows the string if there is an actual lack of space */ STATIC char * 1261 sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { 1261 const STRLEN cur = SvCUR(sv); 1261 const STRLEN len = SvLEN(sv); 1261 STRLEN extend; 1261 if (len - cur > needed) return SvPVX(sv); 1261 extend = needed > len ? needed : len; 1261 return SvGROW(sv, len+extend+1); } STATIC SV ** S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 89317 { 89317 tempsym_t lookahead; 89317 I32 items = endlist - beglist; 89317 bool found = next_symbol(symptr); 89221 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; 89221 if (symptr->level == 0 && found && symptr->code == 'U') { 18871 marked_upgrade(aTHX_ cat, symptr); 18871 symptr->flags |= FLAG_DO_UTF8; 18871 utf8 = 0; } 89221 symptr->strbeg = SvCUR(cat); 220475 while (found) { 131465 SV *fromstr; 131465 STRLEN fromlen; 131465 I32 len; 131465 SV *lengthcode = Nullsv; 131465 I32 datumtype = symptr->code; 131465 howlen_t howlen = symptr->howlen; 131465 char *start = SvPVX(cat); 131465 char *cur = start + SvCUR(cat); #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no) 131465 switch (howlen) { case e_star: 22438 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items; 22438 break; default: /* e_no_len and e_number */ 109027 len = symptr->length; 131465 break; } 131465 if (len) { 119926 packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; 119926 if (props && !(props & PACK_SIZE_UNPREDICTABLE)) { /* We can process this letter. */ 62429 STRLEN size = props & PACK_SIZE_MASK; 62429 GROWING(utf8, cat, start, cur, (STRLEN) len * size); } } /* Look ahead for next symbol. Do we have code/code? */ 131465 lookahead = *symptr; 131465 found = next_symbol(&lookahead); 131454 if (symptr->flags & FLAG_SLASH) { 54 IV count; 54 if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack"); 54 if (strchr("aAZ", lookahead.code)) { 48 if (lookahead.howlen == e_number) count = lookahead.length; else { 42 if (items > 0) 41 count = DO_UTF8(*beglist) ? sv_len_utf8(*beglist) : sv_len(*beglist); 1 else count = 0; 42 if (lookahead.code == 'Z') count++; } } else { 6 if (lookahead.howlen == e_number && lookahead.length < items) 2 count = lookahead.length; 4 else count = items; } 54 lookahead.howlen = e_number; 54 lookahead.length = count; 54 lengthcode = sv_2mortal(newSViv(count)); } /* 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 */ 131454 switch(TYPE_NO_ENDIANNESS(datumtype)) { default: 91 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int) TYPE_NO_MODIFIERS(datumtype)); case '%': ###### Perl_croak(aTHX_ "'%%' may not be used in pack"); { 27 char *from; #ifdef PERL_PACK_CAN_SHRIEKSIGN case '.' | TYPE_IS_SHRIEKING: #endif case '.': 27 if (howlen == e_star) from = start; 24 else if (len == 0) from = cur; else { 21 tempsym_t *group = symptr; 24 while (--len && group) group = group->previous; 21 from = group ? start + group->strbeg : start; } 27 fromstr = NEXTFROM; 27 len = SvIV(fromstr); 27 goto resize; #ifdef PERL_PACK_CAN_SHRIEKSIGN case '@' | TYPE_IS_SHRIEKING: #endif case '@': 25 from = start + symptr->strbeg; resize: #ifdef PERL_PACK_CAN_SHRIEKSIGN 52 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) #else /* PERL_PACK_CAN_SHRIEKSIGN */ if (utf8) #endif 15 if (len >= 0) { 64 while (len && from < cur) { 51 from += UTF8SKIP(from); 51 len--; } 13 if (from > cur) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); 13 if (len) { /* Here we know from == cur */ grow: 2086 GROWING(0, cat, start, cur, len); 2086 Zero(cur, len, char); 2086 cur += len; 2 } else if (from < cur) { 1 len = cur - from; 1 goto shrink; 2 } else goto no_change; } else { 2 cur = from; 2 len = -len; 2 goto utf8_shrink; } else { 37 len -= cur - from; 37 if (len > 0) goto grow; 22 if (len == 0) goto no_change; 14 len = -len; 14 goto shrink; } 3685 break; } case '(': { 3685 tempsym_t savsym = *symptr; 3685 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); 3685 symptr->flags |= group_modifiers; 3685 symptr->patend = savsym.grpend; 3685 symptr->level++; 3685 symptr->previous = &lookahead; 21041 while (len--) { 17465 U32 was_utf8; 17465 if (utf8) symptr->flags |= FLAG_PARSE_UTF8; 17261 else symptr->flags &= ~FLAG_PARSE_UTF8; 17465 was_utf8 = SvUTF8(cat); 17465 symptr->patptr = savsym.grpbeg; 17465 beglist = pack_rec(cat, symptr, beglist, endlist); 17360 if (SvUTF8(cat) != was_utf8) /* This had better be an upgrade while in utf8==0 mode */ 59 utf8 = 1; 17360 if (savsym.howlen == e_star && beglist == endlist) 3580 break; /* No way to continue */ } 3580 lookahead.flags = symptr->flags & ~group_modifiers; 3580 goto no_change; } case 'X' | TYPE_IS_SHRIEKING: 734 if (!len) /* Avoid division by 0 */ 13 len = 1; 734 if (utf8) { 11 char *hop, *last; 11 I32 l = len; 11 hop = last = start; 181 while (hop < cur) { 170 hop += UTF8SKIP(hop); 170 if (--l == 0) { 20 last = hop; 20 l = len; } } 11 if (last > cur) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); 11 cur = last; 11 break; } 723 len = (cur-start) % len; /* FALL THROUGH */ case 'X': 1459 if (utf8) { 11 if (len < 1) goto no_change; utf8_shrink: 100 while (len > 0) { 88 if (cur <= start) ###### Perl_croak(aTHX_ "'%c' outside of string in pack", (int) TYPE_NO_MODIFIERS(datumtype)); 257 while (--cur, UTF8_IS_CONTINUATION(*cur)) { 169 if (cur <= start) ###### Perl_croak(aTHX_ "'%c' outside of string in pack", (int) TYPE_NO_MODIFIERS(datumtype)); } 88 len--; } } else { shrink: 1463 if (cur - start < len) 1 Perl_croak(aTHX_ "'%c' outside of string in pack", (int) TYPE_NO_MODIFIERS(datumtype)); 1462 cur -= len; } 1474 if (cur < start+symptr->strbeg) { /* Make sure group starts don't point into the void */ 10 tempsym_t *group; 10 const STRLEN length = cur-start; 20 for (group = symptr; group && length < group->strbeg; 10 group = group->previous) group->strbeg = length; 10 lookahead.strbeg = length; } 10 break; case 'x' | TYPE_IS_SHRIEKING: { 739 I32 ai32; 739 if (!len) /* Avoid division by 0 */ ###### len = 1; 739 if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len; 728 else ai32 = (cur - start) % len; 739 if (ai32 == 0) goto no_change; 313 len -= ai32; } /* FALL THROUGH */ case 'x': 313 goto grow; case 'A': case 'Z': case 'a': { 3387 const char *aptr; 3387 fromstr = NEXTFROM; 3387 aptr = SvPV_const(fromstr, fromlen); 3387 if (DO_UTF8(fromstr)) { 1617 const char *end, *s; 1617 if (!utf8 && !SvUTF8(cat)) { 1593 marked_upgrade(aTHX_ cat, symptr); 1593 lookahead.flags |= FLAG_DO_UTF8; 1593 lookahead.strbeg = symptr->strbeg; 1593 utf8 = 1; 1593 start = SvPVX(cat); 1593 cur = start + SvCUR(cat); } 1617 if (howlen == e_star) { 1515 if (utf8) goto string_copy; 3 len = fromlen+1; } 105 s = aptr; 105 end = aptr + fromlen; 105 fromlen = datumtype == 'Z' ? len-1 : len; 177 while ((I32) fromlen > 0 && s < end) { 72 s += UTF8SKIP(s); 72 fromlen--; } 105 if (s > end) ###### Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); 105 if (utf8) { 87 len = fromlen; 87 if (datumtype == 'Z') len++; 87 fromlen = s-aptr; 87 len += fromlen; 87 goto string_copy; } 18 fromlen = len - fromlen; 18 if (datumtype == 'Z') fromlen--; 18 if (howlen == e_star) { 3 len = fromlen; 3 if (datumtype == 'Z') len++; } 18 GROWING(0, cat, start, cur, len); 18 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen, datumtype | TYPE_IS_PACK)) ###### Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available"); 18 cur += fromlen; 18 len -= fromlen; 1770 } else if (utf8) { 32 if (howlen == e_star) { 24 len = fromlen; 24 if (datumtype == 'Z') len++; } 32 if (len <= (I32) fromlen) { 32 fromlen = len; 32 if (datumtype == 'Z' && fromlen > 0) fromlen--; } /* assumes a byte expands to at most UTF8_EXPAND bytes on upgrade, so: expected_length <= from_len*UTF8_EXPAND + (len-from_len) */ 32 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len); 32 len -= fromlen; 97 while (fromlen > 0) { 65 cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr); 65 aptr++; 65 fromlen--; } } else { string_copy: 3337 if (howlen == e_star) { 1577 len = fromlen; 1577 if (datumtype == 'Z') len++; } 3337 if (len <= (I32) fromlen) { 2390 fromlen = len; 2390 if (datumtype == 'Z' && fromlen > 0) fromlen--; } 3337 GROWING(0, cat, start, cur, len); 3337 Copy(aptr, cur, fromlen, char); 3337 cur += fromlen; 3337 len -= fromlen; } 3387 memset(cur, datumtype == 'A' ? ' ' : '\0', len); 3387 cur += len; 3387 break; } case 'B': case 'b': { 653 const char *str, *end; 653 I32 l, field_len; 653 U8 bits; 653 bool utf8_source; 653 U32 utf8_flags; 653 fromstr = NEXTFROM; 653 str = SvPV_const(fromstr, fromlen); 653 end = str + fromlen; 653 if (DO_UTF8(fromstr)) { ###### utf8_source = TRUE; ###### utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; } else { 653 utf8_source = FALSE; 653 utf8_flags = 0; /* Unused, but keep compilers happy */ } 653 if (howlen == e_star) len = fromlen; 653 field_len = (len+7)/8; 653 GROWING(utf8, cat, start, cur, field_len); 653 if (len > (I32)fromlen) len = fromlen; 653 bits = 0; 653 l = 0; 653 if (datumtype == 'B') 4713 while (l++ < len) { 4295 if (utf8_source) { ###### UV val; ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); ###### bits |= val & 1; 4295 } else bits |= *str++ & 1; 4295 if (l & 7) bits <<= 1; else { 466 PUSH_BYTE(utf8, cur, bits); 466 bits = 0; } } else /* datumtype == 'b' */ 858 while (l++ < len) { 623 if (utf8_source) { ###### UV val; ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); ###### if (val & 1) bits |= 0x80; 623 } else if (*str++ & 1) 441 bits |= 0x80; 623 if (l & 7) bits >>= 1; else { 8 PUSH_BYTE(utf8, cur, bits); 8 bits = 0; } } 653 l--; 653 if (l & 7) { 472 if (datumtype == 'B') 237 bits <<= 7 - (l & 7); else 235 bits >>= 7 - (l & 7); 472 PUSH_BYTE(utf8, cur, bits); 472 l += 7; } /* Determine how many chars are left in the requested field */ 653 l /= 8; 653 if (howlen == e_star) field_len = 0; 470 else field_len -= l; 653 Zero(cur, field_len, char); 653 cur += field_len; 653 break; } case 'H': case 'h': { 1389 const char *str, *end; 1389 I32 l, field_len; 1389 U8 bits; 1389 bool utf8_source; 1389 U32 utf8_flags; 1389 fromstr = NEXTFROM; 1389 str = SvPV_const(fromstr, fromlen); 1389 end = str + fromlen; 1389 if (DO_UTF8(fromstr)) { ###### utf8_source = TRUE; ###### utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; } else { 1389 utf8_source = FALSE; 1389 utf8_flags = 0; /* Unused, but keep compilers happy */ } 1389 if (howlen == e_star) len = fromlen; 1389 field_len = (len+1)/2; 1389 GROWING(utf8, cat, start, cur, field_len); 1389 if (!utf8 && len > (I32)fromlen) len = fromlen; 1389 bits = 0; 1389 l = 0; 1389 if (datumtype == 'H') 51892 while (l++ < len) { 50739 if (utf8_source) { ###### UV val; ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); ###### if (val < 256 && isALPHA(val)) ###### bits |= (val + 9) & 0xf; else ###### bits |= val & 0xf; 50739 } else if (isALPHA(*str)) 4112 bits |= (*str++ + 9) & 0xf; else 46627 bits |= *str++ & 0xf; 50739 if (l & 1) bits <<= 4; else { 25329 PUSH_BYTE(utf8, cur, bits); 25329 bits = 0; } } else 641 while (l++ < len) { 405 if (utf8_source) { ###### UV val; ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); ###### if (val < 256 && isALPHA(val)) ###### bits |= ((val + 9) & 0xf) << 4; else ###### bits |= (val & 0xf) << 4; 405 } else if (isALPHA(*str)) 243 bits |= ((*str++ + 9) & 0xf) << 4; else 162 bits |= (*str++ & 0xf) << 4; 405 if (l & 1) bits >>= 4; else { 162 PUSH_BYTE(utf8, cur, bits); 162 bits = 0; } } 1389 l--; 1389 if (l & 1) { 162 PUSH_BYTE(utf8, cur, bits); 162 l++; } /* Determine how many chars are left in the requested field */ 1389 l /= 2; 1389 if (howlen == e_star) field_len = 0; 472 else field_len -= l; 1389 Zero(cur, field_len, char); 1389 cur += field_len; 1389 break; } case 'c': 1547 while (len-- > 0) { 1270 IV aiv; 1270 fromstr = NEXTFROM; 1270 aiv = SvIV(fromstr); 1270 if ((-128 > aiv || aiv > 127) && ckWARN(WARN_PACK)) 2 Perl_warner(aTHX_ packWARN(WARN_PACK), "Character in 'c' format wrapped in pack"); 1270 PUSH_BYTE(utf8, cur, aiv & 0xff); } 26030 break; case 'C': 26030 if (len == 0) { 112 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; 112 break; } 25918 GROWING(0, cat, start, cur, len); 54724 while (len-- > 0) { 28806 IV aiv; 28806 fromstr = NEXTFROM; 28806 aiv = SvIV(fromstr); 28806 if ((0 > aiv || aiv > 0xff) && ckWARN(WARN_PACK)) 2 Perl_warner(aTHX_ packWARN(WARN_PACK), "Character in 'C' format wrapped in pack"); 28806 *cur++ = aiv & 0xff; } 416 break; case 'W': { 416 char *end; 416 U8 in_bytes = IN_BYTES; 416 end = start+SvLEN(cat)-1; 416 if (utf8) end -= UTF8_MAXLEN-1; 1891 while (len-- > 0) { 1475 UV auv; 1475 fromstr = NEXTFROM; 1475 auv = SvUV(fromstr); 1475 if (in_bytes) auv = auv % 0x100; 1475 if (utf8) { W_utf8: 1326 if (cur > end) { 44 *cur = '\0'; 44 SvCUR_set(cat, cur - start); 44 GROWING(0, cat, start, cur, len+UTF8_MAXLEN); 44 end = start+SvLEN(cat)-UTF8_MAXLEN; } 1326 cur = (char *) uvuni_to_utf8_flags((U8 *) cur, NATIVE_TO_UNI(auv), ckWARN(WARN_UTF8) ? 0 : UNICODE_ALLOW_ANY); } else { 239 if (auv >= 0x100) { 90 if (!SvUTF8(cat)) { 90 *cur = '\0'; 90 SvCUR_set(cat, cur - start); 90 marked_upgrade(aTHX_ cat, symptr); 90 lookahead.flags |= FLAG_DO_UTF8; 90 lookahead.strbeg = symptr->strbeg; 90 utf8 = 1; 90 start = SvPVX(cat); 90 cur = start + SvCUR(cat); 90 end = start+SvLEN(cat)-UTF8_MAXLEN; 90 goto W_utf8; } ###### if (ckWARN(WARN_PACK)) ###### Perl_warner(aTHX_ packWARN(WARN_PACK), "Character in 'W' format wrapped in pack"); ###### auv &= 0xff; } 149 if (cur >= end) { ###### *cur = '\0'; ###### SvCUR_set(cat, cur - start); ###### GROWING(0, cat, start, cur, len+1); ###### end = start+SvLEN(cat)-1; } 149 *(U8 *) cur++ = (U8)auv; } } 26328 break; } case 'U': { 26328 char *end; 26328 if (len == 0) { 9053 if (!(symptr->flags & FLAG_DO_UTF8)) { 11 marked_upgrade(aTHX_ cat, symptr); 11 lookahead.flags |= FLAG_DO_UTF8; 11 lookahead.strbeg = symptr->strbeg; } 9053 utf8 = 0; 9053 goto no_change; } 17275 end = start+SvLEN(cat); 17275 if (!utf8) end -= UTF8_MAXLEN; 39510 while (len-- > 0) { 22235 UV auv; 22235 fromstr = NEXTFROM; 22235 auv = SvUV(fromstr); 22235 if (utf8) { 1 U8 buffer[UTF8_MAXLEN], *endb; 1 endb = uvuni_to_utf8_flags(buffer, auv, ckWARN(WARN_UTF8) ? 0 : UNICODE_ALLOW_ANY); 1 if (cur+(endb-buffer)*UTF8_EXPAND >= end) { 1 *cur = '\0'; 1 SvCUR_set(cat, cur - start); GROWING(0, cat, start, cur, 1 len+(endb-buffer)*UTF8_EXPAND); 1 end = start+SvLEN(cat); } 1 bytes_to_uni(aTHX_ buffer, endb-buffer, &cur); } else { 22234 if (cur >= end) { 187 *cur = '\0'; 187 SvCUR_set(cat, cur - start); 187 GROWING(0, cat, start, cur, len+UTF8_MAXLEN); 187 end = start+SvLEN(cat)-UTF8_MAXLEN; } 22234 cur = (char *) uvuni_to_utf8_flags((U8 *) cur, auv, ckWARN(WARN_UTF8) ? 0 : UNICODE_ALLOW_ANY); } } 782 break; } /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ case 'f': 4522 while (len-- > 0) { 3740 float afloat; 3740 NV anv; 3740 fromstr = NEXTFROM; 3740 anv = SvNV(fromstr); #ifdef __VOS__ /* VOS does not automatically map a floating-point overflow during conversion from double to float into infinity, so we do it by hand. This code should either be generalized for any OS that needs it, or removed if and when VOS implements posix-976 (suggestion to support mapping to infinity). Paul.Green@stratus.com 02-04-02. */ if (anv > FLT_MAX) afloat = _float_constants[0]; /* single prec. inf. */ else if (anv < -FLT_MAX) afloat = _float_constants[0]; /* single prec. inf. */ else afloat = (float) anv; #else /* __VOS__ */ # if defined(VMS) && !defined(__IEEE_FP) /* IEEE fp overflow shenanigans are unavailable on VAX and optional * on Alpha; fake it if we don't have them. */ if (anv > FLT_MAX) afloat = FLT_MAX; else if (anv < -FLT_MAX) afloat = -FLT_MAX; else afloat = (float)anv; # else 3740 afloat = (float)anv; # endif #endif /* __VOS__ */ 3740 DO_BO_PACK_N(afloat, float); 3740 PUSH_VAR(utf8, cur, afloat); } 1477 break; case 'd': 8684 while (len-- > 0) { 7207 double adouble; 7207 NV anv; 7207 fromstr = NEXTFROM; 7207 anv = SvNV(fromstr); #ifdef __VOS__ /* VOS does not automatically map a floating-point overflow during conversion from long double to double into infinity, so we do it by hand. This code should either be generalized for any OS that needs it, or removed if and when VOS implements posix-976 (suggestion to support mapping to infinity). Paul.Green@stratus.com 02-04-02. */ if (anv > DBL_MAX) adouble = _double_constants[0]; /* double prec. inf. */ else if (anv < -DBL_MAX) adouble = _double_constants[0]; /* double prec. inf. */ else adouble = (double) anv; #else /* __VOS__ */ # if defined(VMS) && !defined(__IEEE_FP) /* IEEE fp overflow shenanigans are unavailable on VAX and optional * on Alpha; fake it if we don't have them. */ if (anv > DBL_MAX) adouble = DBL_MAX; else if (anv < -DBL_MAX) adouble = -DBL_MAX; else adouble = (double)anv; # else 7207 adouble = (double)anv; # endif #endif /* __VOS__ */ 7207 DO_BO_PACK_N(adouble, double); 7207 PUSH_VAR(utf8, cur, adouble); } 786 break; case 'F': { 786 NV anv; 786 Zero(&anv, 1, NV); /* can be long double with unused bits */ 4527 while (len-- > 0) { 3741 fromstr = NEXTFROM; 3741 anv = SvNV(fromstr); 3741 DO_BO_PACK_N(anv, NV); 3741 PUSH_VAR(utf8, cur, anv); } 30937 break; } #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) case 'D': { long double aldouble; /* long doubles can have unused bits, which may be nonzero */ Zero(&aldouble, 1, long double); while (len-- > 0) { fromstr = NEXTFROM; aldouble = (long double)SvNV(fromstr); DO_BO_PACK_N(aldouble, long double); PUSH_VAR(utf8, cur, aldouble); } break; } #endif #ifdef PERL_PACK_CAN_SHRIEKSIGN case 'n' | TYPE_IS_SHRIEKING: #endif case 'n': 141452 while (len-- > 0) { 110515 I16 ai16; 110515 fromstr = NEXTFROM; 110515 ai16 = (I16)SvIV(fromstr); #ifdef HAS_HTONS 110515 ai16 = PerlSock_htons(ai16); #endif 110515 PUSH16(utf8, cur, &ai16); } 411 break; #ifdef PERL_PACK_CAN_SHRIEKSIGN case 'v' | TYPE_IS_SHRIEKING: #endif case 'v': 1889 while (len-- > 0) { 1478 I16 ai16; 1478 fromstr = NEXTFROM; 1478 ai16 = (I16)SvIV(fromstr); #ifdef HAS_HTOVS ai16 = htovs(ai16); #endif 1478 PUSH16(utf8, cur, &ai16); } 2691 break; case 'S' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 while (len-- > 0) { unsigned short aushort; fromstr = NEXTFROM; aushort = SvUV(fromstr); DO_BO_PACK(aushort, s); PUSH_VAR(utf8, cur, aushort); } break; #else /* Fall through! */ #endif case 'S': 14639 while (len-- > 0) { 11948 U16 au16; 11948 fromstr = NEXTFROM; 11948 au16 = (U16)SvUV(fromstr); 11948 DO_BO_PACK(au16, 16); 11948 PUSH16(utf8, cur, &au16); } 2508 break; case 's' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 while (len-- > 0) { short ashort; fromstr = NEXTFROM; ashort = SvIV(fromstr); DO_BO_PACK(ashort, s); PUSH_VAR(utf8, cur, ashort); } break; #else /* Fall through! */ #endif case 's': 13745 while (len-- > 0) { 11237 I16 ai16; 11237 fromstr = NEXTFROM; 11237 ai16 = (I16)SvIV(fromstr); 11237 DO_BO_PACK(ai16, 16); 11237 PUSH16(utf8, cur, &ai16); } 1588 break; case 'I': case 'I' | TYPE_IS_SHRIEKING: 9147 while (len-- > 0) { 7559 unsigned int auint; 7559 fromstr = NEXTFROM; 7559 auint = SvUV(fromstr); 7559 DO_BO_PACK(auint, i); 7559 PUSH_VAR(utf8, cur, auint); } 800 break; case 'j': 4567 while (len-- > 0) { 3767 IV aiv; 3767 fromstr = NEXTFROM; 3767 aiv = SvIV(fromstr); #if IVSIZE == INTSIZE 3767 DO_BO_PACK(aiv, i); #elif IVSIZE == LONGSIZE DO_BO_PACK(aiv, l); #elif defined(HAS_QUAD) && IVSIZE == U64SIZE DO_BO_PACK(aiv, 64); #else Perl_croak(aTHX_ "'j' not supported on this platform"); #endif 3767 PUSH_VAR(utf8, cur, aiv); } 836 break; case 'J': 4687 while (len-- > 0) { 3851 UV auv; 3851 fromstr = NEXTFROM; 3851 auv = SvUV(fromstr); #if UVSIZE == INTSIZE 3851 DO_BO_PACK(auv, i); #elif UVSIZE == LONGSIZE DO_BO_PACK(auv, l); #elif defined(HAS_QUAD) && UVSIZE == U64SIZE DO_BO_PACK(auv, 64); #else Perl_croak(aTHX_ "'J' not supported on this platform"); #endif 3851 PUSH_VAR(utf8, cur, auv); } 20 break; case 'w': 50 while (len-- > 0) { 33 NV anv; 33 fromstr = NEXTFROM; 33 anv = SvNV(fromstr); 33 if (anv < 0) { 1 *cur = '\0'; 1 SvCUR_set(cat, cur - start); 1 Perl_croak(aTHX_ "Cannot compress negative numbers in pack"); } /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0, which is == UV_MAX_P1. IOK is fine (instead of UV_only), as any negative IVs will have already been got by the croak() above. IOK is untrue for fractions, so we test them against UV_MAX_P1. */ 32 if (SvIOK(fromstr) || anv < UV_MAX_P1) { 18 char buf[(sizeof(UV)*CHAR_BIT)/7+1]; 18 char *in = buf + sizeof(buf); 18 UV auv = SvUV(fromstr); 49 do { 49 *--in = (char)((auv & 0x7f) | 0x80); 49 auv >>= 7; 49 } while (auv); 18 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ PUSH_GROWING_BYTES(utf8, cat, start, cur, 18 in, (buf + sizeof(buf)) - in); 14 } else if (SvPOKp(fromstr)) 7 goto w_string; 7 else if (SvNOKp(fromstr)) { /* 10**NV_MAX_10_EXP is the largest power of 10 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x: x = (NV_MAX_10_EXP+1) * log (10) / log (128) And with that many bytes only Inf can overflow. Some C compilers are strict about integral constant expressions so we conservatively divide by a slightly smaller integer instead of multiplying by the exact floating-point value. */ #ifdef NV_MAX_10_EXP /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */ 6 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */ #else /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */ char buf[1 + (int)((308 + 1) / 2)]; /* valid C */ #endif 6 char *in = buf + sizeof(buf); 6 anv = Perl_floor(anv); 329 do { 329 const NV next = Perl_floor(anv / 128); 329 if (in <= buf) /* this cannot happen ;-) */ 1 Perl_croak(aTHX_ "Cannot compress integer in pack"); 328 *--in = (unsigned char)(anv - (next * 128)) | 0x80; 328 anv = next; 328 } while (anv > 0); 5 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ PUSH_GROWING_BYTES(utf8, cat, start, cur, 5 in, (buf + sizeof(buf)) - in); } else { 8 const char *from; 8 char *result, *in; 8 SV *norm; 8 STRLEN len; 8 bool done; w_string: /* Copy string and check for compliance */ 8 from = SvPV_const(fromstr, len); 8 if ((norm = is_an_int(from, len)) == NULL) 1 Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); 7 New('w', result, len, char); 7 in = result + len; 7 done = FALSE; 71 while (!done) *--in = div128(norm, &done) | 0x80; 7 result[len - 1] &= 0x7F; /* clear continue bit */ PUSH_GROWING_BYTES(utf8, cat, start, cur, 7 in, (result + len) - in); 7 Safefree(result); 7 SvREFCNT_dec(norm); /* free norm */ } } 1637 break; case 'i': case 'i' | TYPE_IS_SHRIEKING: 9190 while (len-- > 0) { 7553 int aint; 7553 fromstr = NEXTFROM; 7553 aint = SvIV(fromstr); 7553 DO_BO_PACK(aint, i); 7553 PUSH_VAR(utf8, cur, aint); } 12949 break; #ifdef PERL_PACK_CAN_SHRIEKSIGN case 'N' | TYPE_IS_SHRIEKING: #endif case 'N': 40068 while (len-- > 0) { 27119 U32 au32; 27119 fromstr = NEXTFROM; 27119 au32 = SvUV(fromstr); #ifdef HAS_HTONL 27119 au32 = PerlSock_htonl(au32); #endif 27119 PUSH32(utf8, cur, &au32); } 296 break; #ifdef PERL_PACK_CAN_SHRIEKSIGN case 'V' | TYPE_IS_SHRIEKING: #endif case 'V': 1640 while (len-- > 0) { 1344 U32 au32; 1344 fromstr = NEXTFROM; 1344 au32 = SvUV(fromstr); #ifdef HAS_HTOVL au32 = htovl(au32); #endif 1344 PUSH32(utf8, cur, &au32); } 4298 break; case 'L' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 while (len-- > 0) { unsigned long aulong; fromstr = NEXTFROM; aulong = SvUV(fromstr); DO_BO_PACK(aulong, l); PUSH_VAR(utf8, cur, aulong); } break; #else /* Fall though! */ #endif case 'L': 14506 while (len-- > 0) { 10208 U32 au32; 10208 fromstr = NEXTFROM; 10208 au32 = SvUV(fromstr); 10208 DO_BO_PACK(au32, 32); 10208 PUSH32(utf8, cur, &au32); } 1674 break; case 'l' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 while (len-- > 0) { long along; fromstr = NEXTFROM; along = SvIV(fromstr); DO_BO_PACK(along, l); PUSH_VAR(utf8, cur, along); } break; #else /* Fall though! */ #endif case 'l': 9258 while (len-- > 0) { 7584 I32 ai32; 7584 fromstr = NEXTFROM; 7584 ai32 = SvIV(fromstr); 7584 DO_BO_PACK(ai32, 32); 7584 PUSH32(utf8, cur, &ai32); } 698 break; #ifdef HAS_QUAD case 'Q': while (len-- > 0) { Uquad_t auquad; fromstr = NEXTFROM; auquad = (Uquad_t) SvUV(fromstr); DO_BO_PACK(auquad, 64); PUSH_VAR(utf8, cur, auquad); } break; case 'q': while (len-- > 0) { Quad_t aquad; fromstr = NEXTFROM; aquad = (Quad_t)SvIV(fromstr); DO_BO_PACK(aquad, 64); PUSH_VAR(utf8, cur, aquad); } break; #endif /* HAS_QUAD */ case 'P': 698 len = 1; /* assume SV is correct length */ 698 GROWING(utf8, cat, start, cur, sizeof(char *)); /* Fall through! */ case 'p': 5588 while (len-- > 0) { 4180 const char *aptr; 4180 fromstr = NEXTFROM; 4180 SvGETMAGIC(fromstr); 4180 if (!SvOK(fromstr)) aptr = NULL; else { 4177 STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are * gone. */ 4177 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) || (SvPADTMP(fromstr) && !SvREADONLY(fromstr)))) { 2 Perl_warner(aTHX_ packWARN(WARN_PACK), "Attempt to pack pointer to temporary value"); } 4177 if (SvPOK(fromstr) || SvNIOK(fromstr)) 4177 aptr = SvPV_nomg_const(fromstr, n_a); else ###### aptr = SvPV_force_flags(fromstr, n_a, 0); } 4180 DO_BO_PACK_PC(aptr); 4180 PUSH_VAR(utf8, cur, aptr); } 92 break; case 'u': { 92 const char *aptr, *aend; 92 bool from_utf8; 92 fromstr = NEXTFROM; 92 if (len <= 2) len = 45; 2 else len = len / 3 * 3; 92 if (len >= 64) { 1 Perl_warner(aTHX_ packWARN(WARN_PACK), "Field too wide in 'u' format in pack"); 1 len = 63; } 92 aptr = SvPV_const(fromstr, fromlen); 92 from_utf8 = DO_UTF8(fromstr); 92 if (from_utf8) { 1 aend = aptr + fromlen; 1 fromlen = sv_len_utf8(fromstr); 91 } else aend = NULL; /* Unused, but keep compilers happy */ 92 GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2); 193 while (fromlen > 0) { 101 U8 *end; 101 I32 todo; 101 U8 hunk[1+63/3*4+1]; 101 if ((I32)fromlen > len) 9 todo = len; else 92 todo = fromlen; 101 if (from_utf8) { 1 char buffer[64]; 1 if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo, 'u' | TYPE_IS_PACK)) { ###### *cur = '\0'; ###### SvCUR_set(cat, cur - start); ###### Perl_croak(aTHX_ "Assertion: string is shorter than advertised"); } 1 end = doencodes(hunk, buffer, todo); } else { 100 end = doencodes(hunk, aptr, todo); 100 aptr += todo; } 101 PUSH_BYTES(utf8, cur, hunk, end-hunk); 101 fromlen -= todo; } 118185 break; } } 118185 *cur = '\0'; 118185 SvCUR_set(cat, cur - start); no_change: 131254 *symptr = lookahead; } 89010 return beglist; } #undef NEXTFROM PP(pp_pack) 71852 { 71852 dSP; dMARK; dORIGMARK; dTARGET; 71852 register SV *cat = TARG; 71852 STRLEN fromlen; 71852 SV *pat_sv = *++MARK; 71852 register const char *pat = SvPV_const(pat_sv, fromlen); 71852 register const char *patend = pat + fromlen; 71852 MARK++; 71852 sv_setpvn(cat, "", 0); 71852 SvUTF8_off(cat); 71852 packlist(cat, pat, patend, MARK, SP + 1); 71650 SvSETMAGIC(cat); 71650 SP = ORIGMARK; 71650 PUSHs(cat); 71650 RETURN; } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */