perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	/* pp_pack.c
	2	*
	3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
	4	* 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
	5	*
	6	* You may distribute under the terms of either the GNU General Public
	7	* License or the Artistic License, as specified in the README file.
	8	*
	9	*/
	10
	11	/*
	12	* He still hopefully carried some of his gear in his pack: a small tinder-box,
	13	* two small shallow pans, the smaller fitting into the larger; inside them a
	14	* wooden spoon, a short two-pronged fork and some skewers were stowed; and
	15	* hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
	16	* some salt.
	17	*/
	18
	19	/* This file contains pp ("push/pop") functions that
	20	* execute the opcodes that make up a perl program. A typical pp function
	21	* expects to find its arguments on the stack, and usually pushes its
	22	* results onto the stack, hence the 'pp' terminology. Each OP structure
	23	* contains a pointer to the relevant pp_foo() function.
	24	*
	25	* This particular file just contains pp_pack() and pp_unpack(). See the
	26	* other pp*.c files for the rest of the pp_ functions.
	27	*/
	28
	29
	30	#include "EXTERN.h"
	31	#define PERL_IN_PP_PACK_C
	32	#include "perl.h"
	33
	34	/* Types used by pack/unpack */
	35	typedef enum {
	36	e_no_len, /* no length */
	37	e_number, /* number, [] */
	38	e_star /* asterisk */
	39	} howlen_t;
	40
	41	typedef struct tempsym {
	42	const char* patptr; /* current template char */
	43	const char* patend; /* one after last char */
	44	const char* grpbeg; /* 1st char of ()-group */
	45	const char* grpend; /* end of ()-group */
	46	I32 code; /* template code (!<>) */
	47	I32 length; /* length/repeat count */
	48	howlen_t howlen; /* how length is given */
	49	int level; /* () nesting level */
	50	U32 flags; /* /=4, comma=2, pack=1 */
	51	/* and group modifiers */
	52	STRLEN strbeg; /* offset of group start */
	53	struct tempsym previous; / previous group */
	54	} tempsym_t;
	55
	56	#define TEMPSYM_INIT(symptr, p, e, f) \
	57	STMT_START { \
	58	(symptr)->patptr = (p); \
	59	(symptr)->patend = (e); \
	60	(symptr)->grpbeg = NULL; \
	61	(symptr)->grpend = NULL; \
	62	(symptr)->grpend = NULL; \
	63	(symptr)->code = 0; \
	64	(symptr)->length = 0; \
	65	(symptr)->howlen = 0; \
	66	(symptr)->level = 0; \
	67	(symptr)->flags = (f); \
	68	(symptr)->strbeg = 0; \
	69	(symptr)->previous = NULL; \
	70	} STMT_END
	71
	72	#if PERL_VERSION >= 9
	73	# define PERL_PACK_CAN_BYTEORDER
	74	# define PERL_PACK_CAN_SHRIEKSIGN
	75	#endif
	76
	77	#ifndef CHAR_BIT
	78	# define CHAR_BIT 8
	79	#endif
	80	/* Maximum number of bytes to which a byte can grow due to upgrade */
	81	#define UTF8_EXPAND 2
	82
	83	/*
	84	* Offset for integer pack/unpack.
	85	*
	86	* On architectures where I16 and I32 aren't really 16 and 32 bits,
	87	* which for now are all Crays, pack and unpack have to play games.
	88	*/
	89
	90	/*
	91	* These values are required for portability of pack() output.
	92	* If they're not right on your machine, then pack() and unpack()
	93	* wouldn't work right anyway; you'll need to apply the Cray hack.
	94	* (I'd like to check them with #if, but you can't use sizeof() in
	95	* the preprocessor.) --???
	96	*/
	97	/*
	98	The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
	99	defines are now in config.h. --Andy Dougherty April 1998
	100	*/
	101	#define SIZE16 2
	102	#define SIZE32 4
	103
	104	/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
	105	--jhi Feb 1999 */
	106
	107	#if U16SIZE > SIZE16 \|\| U32SIZE > SIZE32
	108	# if BYTEORDER == 0x1234 \|\| BYTEORDER == 0x12345678 /* little-endian */
	109	# define OFF16(p) ((char*)(p))
	110	# define OFF32(p) ((char*)(p))
	111	# else
	112	# if BYTEORDER == 0x4321 \|\| BYTEORDER == 0x87654321 /* big-endian */
	113	# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
	114	# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
	115	# else
	116	++++ bad cray byte order
	117	# endif
	118	# endif
	119	#else
	120	# define OFF16(p) ((char *) (p))
	121	# define OFF32(p) ((char *) (p))
	122	#endif
	123
	124	/* Only to be used inside a loop (see the break) */
	125	#define SHIFT16(utf8, s, strend, p, datumtype) STMT_START { \
	126	if (utf8) { \
	127	if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break; \
	128	} else { \
	129	Copy(s, OFF16(p), SIZE16, char); \
	130	(s) += SIZE16; \
	131	} \
	132	} STMT_END
	133
	134	/* Only to be used inside a loop (see the break) */
	135	#define SHIFT32(utf8, s, strend, p, datumtype) STMT_START { \
	136	if (utf8) { \
	137	if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break; \
	138	} else { \
	139	Copy(s, OFF32(p), SIZE32, char); \
	140	(s) += SIZE32; \
	141	} \
	142	} STMT_END
	143
	144	#define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16)
	145	#define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32)
	146
	147	/* Only to be used inside a loop (see the break) */
	148	#define SHIFT_VAR(utf8, s, strend, var, datumtype) \
	149	STMT_START { \
	150	if (utf8) { \
	151	if (!uni_to_bytes(aTHX_ &s, strend, \
	152	(char *) &var, sizeof(var), datumtype)) break;\
	153	} else { \
	154	Copy(s, (char *) &var, sizeof(var), char); \
	155	s += sizeof(var); \
	156	} \
	157	} STMT_END
	158
	159	#define PUSH_VAR(utf8, aptr, var) \
	160	PUSH_BYTES(utf8, aptr, &(var), sizeof(var))
	161
	162	/* Avoid stack overflow due to pathological templates. 100 should be plenty. */
	163	#define MAX_SUB_TEMPLATE_LEVEL 100
	164
	165	/* flags (note that type modifiers can also be used as flags!) */
	166	#define FLAG_WAS_UTF8 0x40
	167	#define FLAG_PARSE_UTF8 0x20 /* Parse as utf8 */
	168	#define FLAG_UNPACK_ONLY_ONE 0x10
	169	#define FLAG_DO_UTF8 0x08 /* The underlying string is utf8 */
	170	#define FLAG_SLASH 0x04
	171	#define FLAG_COMMA 0x02
	172	#define FLAG_PACK 0x01
	173
	174	STATIC SV *
	175	S_mul128(pTHX_ SV *sv, U8 m)
	176	{
	177	STRLEN len;
	178	char *s = SvPV(sv, len);
	179	char *t;
	180
	181	if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
	182	SV *tmpNew = newSVpvn("0000000000", 10);
	183
	184	sv_catsv(tmpNew, sv);
	185	SvREFCNT_dec(sv); /* free old sv */
	186	sv = tmpNew;
	187	s = SvPV(sv, len);
	188	}
	189	t = s + len - 1;
	190	while (!t) / trailing '\0'? */
	191	t--;
	192	while (t > s) {
	193	const U32 i = ((*t - '0') << 7) + m;
	194	*(t--) = '0' + (char)(i % 10);
	195	m = (char)(i / 10);
	196	}
	197	return (sv);
	198	}
	199
	200	/* Explosives and implosives. */
	201
	202	#if 'I' == 73 && 'J' == 74
	203	/* On an ASCII/ISO kind of system */
	204	#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
	205	#else
	206	/*
	207	Some other sort of character set - use memchr() so we don't match
	208	the null byte.
	209	*/
	210	#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) \|\| (ch) == ' ')
	211	#endif
	212
	213	/* type modifiers */
	214	#define TYPE_IS_SHRIEKING 0x100
	215	#define TYPE_IS_BIG_ENDIAN 0x200
	216	#define TYPE_IS_LITTLE_ENDIAN 0x400
	217	#define TYPE_IS_PACK 0x800
	218	#define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN\|TYPE_IS_LITTLE_ENDIAN)
	219	#define TYPE_MODIFIERS(t) ((t) & ~0xFF)
	220	#define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
	221
	222	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	223	# define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV@."
	224	#else
	225	# define SHRIEKING_ALLOWED_TYPES "sSiIlLxX"
	226	#endif
	227
	228	#ifndef PERL_PACK_CAN_BYTEORDER
	229	/* Put "can't" first because it is shorter */
	230	# define TYPE_ENDIANNESS(t) 0
	231	# define TYPE_NO_ENDIANNESS(t) (t)
	232
	233	# define ENDIANNESS_ALLOWED_TYPES ""
	234
	235	# define DO_BO_UNPACK(var, type)
	236	# define DO_BO_PACK(var, type)
	237	# define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast)
	238	# define DO_BO_PACK_PTR(var, type, pre_cast, post_cast)
	239	# define DO_BO_UNPACK_N(var, type)
	240	# define DO_BO_PACK_N(var, type)
	241	# define DO_BO_UNPACK_P(var)
	242	# define DO_BO_PACK_P(var)
	243
	244	#else /* PERL_PACK_CAN_BYTEORDER */
	245
	246	# define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
	247	# define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
	248
	249	# define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
	250
	251	# define DO_BO_UNPACK(var, type) \
	252	STMT_START { \
	253	switch (TYPE_ENDIANNESS(datumtype)) { \
	254	case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
	255	case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
	256	default: break; \
	257	} \
	258	} STMT_END
	259
	260	# define DO_BO_PACK(var, type) \
	261	STMT_START { \
	262	switch (TYPE_ENDIANNESS(datumtype)) { \
	263	case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
	264	case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
	265	default: break; \
	266	} \
	267	} STMT_END
	268
	269	# define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) \
	270	STMT_START { \
	271	switch (TYPE_ENDIANNESS(datumtype)) { \
	272	case TYPE_IS_BIG_ENDIAN: \
	273	var = (post_cast*) my_betoh ## type ((pre_cast) var); \
	274	break; \
	275	case TYPE_IS_LITTLE_ENDIAN: \
	276	var = (post_cast *) my_letoh ## type ((pre_cast) var); \
	277	break; \
	278	default: \
	279	break; \
	280	} \
	281	} STMT_END
	282
	283	# define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) \
	284	STMT_START { \
	285	switch (TYPE_ENDIANNESS(datumtype)) { \
	286	case TYPE_IS_BIG_ENDIAN: \
	287	var = (post_cast *) my_htobe ## type ((pre_cast) var); \
	288	break; \
	289	case TYPE_IS_LITTLE_ENDIAN: \
	290	var = (post_cast *) my_htole ## type ((pre_cast) var); \
	291	break; \
	292	default: \
	293	break; \
	294	} \
	295	} STMT_END
	296
	297	# define BO_CANT_DOIT(action, type) \
	298	STMT_START { \
	299	switch (TYPE_ENDIANNESS(datumtype)) { \
	300	case TYPE_IS_BIG_ENDIAN: \
	301	Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
	302	"platform", #action, #type); \
	303	break; \
	304	case TYPE_IS_LITTLE_ENDIAN: \
	305	Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
	306	"platform", #action, #type); \
	307	break; \
	308	default: \
	309	break; \
	310	} \
	311	} STMT_END
	312
	313	# if PTRSIZE == INTSIZE
	314	# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int, void)
	315	# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int, void)
	316	# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char)
	317	# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char)
	318	# elif PTRSIZE == LONGSIZE
	319	# define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void)
	320	# define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void)
	321	# define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char)
	322	# define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char)
	323	# else
	324	# define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
	325	# define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
	326	# endif
	327
	328	# if defined(my_htolen) && defined(my_letohn) && \
	329	defined(my_htoben) && defined(my_betohn)
	330	# define DO_BO_UNPACK_N(var, type) \
	331	STMT_START { \
	332	switch (TYPE_ENDIANNESS(datumtype)) { \
	333	case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
	334	case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
	335	default: break; \
	336	} \
	337	} STMT_END
	338
	339	# define DO_BO_PACK_N(var, type) \
	340	STMT_START { \
	341	switch (TYPE_ENDIANNESS(datumtype)) { \
	342	case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
	343	case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
	344	default: break; \
	345	} \
	346	} STMT_END
	347	# else
	348	# define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
	349	# define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
	350	# endif
	351
	352	#endif /* PERL_PACK_CAN_BYTEORDER */
	353
	354	#define PACK_SIZE_CANNOT_CSUM 0x80
	355	#define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */
	356	#define PACK_SIZE_MASK 0x3F
	357
	358	/* These tables are regenerated by genpacksizetables.pl (and then hand pasted
	359	in). You're unlikely ever to need to regenerate them. */
	360
	361	#if TYPE_IS_SHRIEKING != 0x100
	362	++++shriek offset should be 256
	363	#endif
	364
	365	typedef U8 packprops_t;
	366	#if 'J'-'I' == 1
	367	/* ASCII */
	368	const packprops_t packprops[512] = {
	369	/* normal */
	370	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	371	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	372	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	373	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	374	0, 0, 0,
	375	/* C */ sizeof(unsigned char) \| PACK_SIZE_UNPREDICTABLE,
	376	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
	377	/* D */ LONG_DOUBLESIZE,
	378	#else
	379	0,
	380	#endif
	381	0,
	382	/* F */ NVSIZE,
	383	0, 0,
	384	/* I */ sizeof(unsigned int),
	385	/* J */ UVSIZE,
	386	0,
	387	/* L */ SIZE32,
	388	0,
	389	/* N */ SIZE32,
	390	0, 0,
	391	#if defined(HAS_QUAD)
	392	/* Q */ sizeof(Uquad_t),
	393	#else
	394	0,
	395	#endif
	396	0,
	397	/* S */ SIZE16,
	398	0,
	399	/* U */ sizeof(char) \| PACK_SIZE_UNPREDICTABLE,
	400	/* V */ SIZE32,
	401	/* W */ sizeof(unsigned char) \| PACK_SIZE_UNPREDICTABLE,
	402	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	403	/* c */ sizeof(char),
	404	/* d */ sizeof(double),
	405	0,
	406	/* f */ sizeof(float),
	407	0, 0,
	408	/* i */ sizeof(int),
	409	/* j */ IVSIZE,
	410	0,
	411	/* l */ SIZE32,
	412	0,
	413	/* n */ SIZE16,
	414	0,
	415	/* p / sizeof(char ) \| PACK_SIZE_CANNOT_CSUM,
	416	#if defined(HAS_QUAD)
	417	/* q */ sizeof(Quad_t),
	418	#else
	419	0,
	420	#endif
	421	0,
	422	/* s */ SIZE16,
	423	0, 0,
	424	/* v */ SIZE16,
	425	/* w */ sizeof(char) \| PACK_SIZE_UNPREDICTABLE \| PACK_SIZE_CANNOT_CSUM,
	426	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	427	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	428	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	429	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	430	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	431	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	432	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	433	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	434	0, 0, 0, 0, 0, 0, 0, 0,
	435	/* shrieking */
	436	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	437	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	438	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	439	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	440	0, 0, 0, 0, 0, 0, 0, 0, 0,
	441	/* I */ sizeof(unsigned int),
	442	0, 0,
	443	/* L */ sizeof(unsigned long),
	444	0,
	445	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	446	/* N */ SIZE32,
	447	#else
	448	0,
	449	#endif
	450	0, 0, 0, 0,
	451	/* S */ sizeof(unsigned short),
	452	0, 0,
	453	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	454	/* V */ SIZE32,
	455	#else
	456	0,
	457	#endif
	458	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	459	0, 0,
	460	/* i */ sizeof(int),
	461	0, 0,
	462	/* l */ sizeof(long),
	463	0,
	464	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	465	/* n */ SIZE16,
	466	#else
	467	0,
	468	#endif
	469	0, 0, 0, 0,
	470	/* s */ sizeof(short),
	471	0, 0,
	472	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	473	/* v */ SIZE16,
	474	#else
	475	0,
	476	#endif
	477	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	478	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	479	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	480	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	481	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	482	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	483	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	484	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	485	0, 0, 0, 0, 0, 0, 0, 0, 0
	486	};
	487	#else
	488	/* EBCDIC (or bust) */
	489	const packprops_t packprops[512] = {
	490	/* normal */
	491	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	492	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	493	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	494	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	495	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	496	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	497	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	498	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	499	0, 0, 0,
	500	/* c */ sizeof(char),
	501	/* d */ sizeof(double),
	502	0,
	503	/* f */ sizeof(float),
	504	0, 0,
	505	/* i */ sizeof(int),
	506	0, 0, 0, 0, 0, 0, 0,
	507	/* j */ IVSIZE,
	508	0,
	509	/* l */ SIZE32,
	510	0,
	511	/* n */ SIZE16,
	512	0,
	513	/* p / sizeof(char ) \| PACK_SIZE_CANNOT_CSUM,
	514	#if defined(HAS_QUAD)
	515	/* q */ sizeof(Quad_t),
	516	#else
	517	0,
	518	#endif
	519	0, 0, 0, 0, 0, 0, 0, 0, 0,
	520	/* s */ SIZE16,
	521	0, 0,
	522	/* v */ SIZE16,
	523	/* w */ sizeof(char) \| PACK_SIZE_UNPREDICTABLE \| PACK_SIZE_CANNOT_CSUM,
	524	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	525	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	526	/* C */ sizeof(unsigned char) \| PACK_SIZE_UNPREDICTABLE,
	527	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
	528	/* D */ LONG_DOUBLESIZE,
	529	#else
	530	0,
	531	#endif
	532	0,
	533	/* F */ NVSIZE,
	534	0, 0,
	535	/* I */ sizeof(unsigned int),
	536	0, 0, 0, 0, 0, 0, 0,
	537	/* J */ UVSIZE,
	538	0,
	539	/* L */ SIZE32,
	540	0,
	541	/* N */ SIZE32,
	542	0, 0,
	543	#if defined(HAS_QUAD)
	544	/* Q */ sizeof(Uquad_t),
	545	#else
	546	0,
	547	#endif
	548	0, 0, 0, 0, 0, 0, 0, 0, 0,
	549	/* S */ SIZE16,
	550	0,
	551	/* U */ sizeof(char) \| PACK_SIZE_UNPREDICTABLE,
	552	/* V */ SIZE32,
	553	/* W */ sizeof(unsigned char) \| PACK_SIZE_UNPREDICTABLE,
	554	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	555	0, 0, 0, 0, 0, 0, 0, 0, 0,
	556	/* shrieking */
	557	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	558	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	559	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	560	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	561	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	562	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	563	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	564	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	565	0, 0, 0, 0, 0, 0, 0, 0, 0,
	566	/* i */ sizeof(int),
	567	0, 0, 0, 0, 0, 0, 0, 0, 0,
	568	/* l */ sizeof(long),
	569	0,
	570	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	571	/* n */ SIZE16,
	572	#else
	573	0,
	574	#endif
	575	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	576	/* s */ sizeof(short),
	577	0, 0,
	578	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	579	/* v */ SIZE16,
	580	#else
	581	0,
	582	#endif
	583	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	584	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	585	0, 0, 0,
	586	/* I */ sizeof(unsigned int),
	587	0, 0, 0, 0, 0, 0, 0, 0, 0,
	588	/* L */ sizeof(unsigned long),
	589	0,
	590	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	591	/* N */ SIZE32,
	592	#else
	593	0,
	594	#endif
	595	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	596	/* S */ sizeof(unsigned short),
	597	0, 0,
	598	#if defined(PERL_PACK_CAN_SHRIEKSIGN)
	599	/* V */ SIZE32,
	600	#else
	601	0,
	602	#endif
	603	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	604	0, 0, 0, 0, 0, 0, 0, 0, 0, 0
	605	};
	606	#endif
	607
	608	STATIC U8
	609	uni_to_byte(pTHX_ const char *s, const char end, I32 datumtype)
	610	{
	611	UV val;
	612	STRLEN retlen;
	613	val = utf8n_to_uvchr((U8 ) s, end-*s, &retlen,
	614	ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
	615	/* We try to process malformed UTF-8 as much as possible (preferrably with
	616	warnings), but these two mean we make no progress in the string and
	617	might enter an infinite loop */
	618	if (retlen == (STRLEN) -1 \|\| retlen == 0)
	619	Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack",
	620	(int) TYPE_NO_MODIFIERS(datumtype));
	621	if (val >= 0x100) {
	622	if (ckWARN(WARN_UNPACK))
	623	Perl_warner(aTHX_ packWARN(WARN_UNPACK),
	624	"Character in '%c' format wrapped in unpack",
	625	(int) TYPE_NO_MODIFIERS(datumtype));
	626	val &= 0xff;
	627	}
	628	*s += retlen;
	629	return (U8)val;
	630	}
	631
	632	#define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \
	633	uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \
	634	(U8 )(s)++)
	635
	636	STATIC bool
	637	uni_to_bytes(pTHX_ const char *s, const char end, const char *buf, int buf_len, I32 datumtype)
	638	{
	639	UV val;
	640	STRLEN retlen;
	641	const char from = s;
	642	int bad = 0;
	643	const U32 flags = ckWARN(WARN_UTF8) ?
	644	UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY \| UTF8_ALLOW_ANY);
	645	for (;buf_len > 0; buf_len--) {
	646	if (from >= end) return FALSE;
	647	val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags);
	648	if (retlen == (STRLEN) -1 \|\| retlen == 0) {
	649	from += UTF8SKIP(from);
	650	bad \|= 1;
	651	} else from += retlen;
	652	if (val >= 0x100) {
	653	bad \|= 2;
	654	val &= 0xff;
	655	}
	656	(U8 )buf++ = (U8)val;
	657	}
	658	/* We have enough characters for the buffer. Did we have problems ? */
	659	if (bad) {
	660	if (bad & 1) {
	661	/* Rewalk the string fragment while warning */
	662	const char *ptr;
	663	const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
	664	for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) {
	665	if (ptr >= end) break;
	666	utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags);
	667	}
	668	if (from > end) from = end;
	669	}
	670	if ((bad & 2) && ckWARN(WARN_UNPACK))
	671	Perl_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ?
	672	WARN_PACK : WARN_UNPACK),
	673	"Character(s) in '%c' format wrapped in %s",
	674	(int) TYPE_NO_MODIFIERS(datumtype),
	675	datumtype & TYPE_IS_PACK ? "pack" : "unpack");
	676	}
	677	*s = from;
	678	return TRUE;
	679	}
	680
	681	STATIC bool
	682	next_uni_uu(pTHX_ const char *s, const char end, I32 *out)
	683	{
	684	UV val;
	685	STRLEN retlen;
	686	val = utf8n_to_uvchr((U8 ) s, end-*s, &retlen, UTF8_CHECK_ONLY);
	687	if (val >= 0x100 \|\| !ISUUCHAR(val) \|\|
	688	retlen == (STRLEN) -1 \|\| retlen == 0) {
	689	*out = 0;
	690	return FALSE;
	691	}
	692	*out = PL_uudmap[val] & 077;
	693	*s += retlen;
	694	return TRUE;
	695	}
	696
	697	STATIC void
	698	bytes_to_uni(pTHX_ const U8 start, STRLEN len, char *dest) {
	699	U8 buffer[UTF8_MAXLEN];
	700	const U8 *end = start + len;
	701	char d = dest;
	702	while (start < end) {
	703	const int length =
	704	uvuni_to_utf8_flags(buffer, NATIVE_TO_UNI(*start), 0) - buffer;
	705	switch(length) {
	706	case 1:
	707	*d++ = buffer[0];
	708	break;
	709	case 2:
	710	*d++ = buffer[0];
	711	*d++ = buffer[1];
	712	break;
	713	default:
	714	Perl_croak(aTHX_ "Perl bug: value %d UTF-8 expands to %d bytes",
	715	*start, length);
	716	}
	717	start++;
	718	}
	719	*dest = d;
	720	}
	721
	722	#define PUSH_BYTES(utf8, cur, buf, len) \
	723	STMT_START { \
	724	if (utf8) bytes_to_uni(aTHX_ (U8 *) buf, len, &(cur)); \
	725	else { \
	726	Copy(buf, cur, len, char); \
	727	(cur) += (len); \
	728	} \
	729	} STMT_END
	730
	731	#define GROWING(utf8, cat, start, cur, in_len) \
	732	STMT_START { \
	733	STRLEN glen = (in_len); \
	734	if (utf8) glen *= UTF8_EXPAND; \
	735	if ((cur) + glen >= (start) + SvLEN(cat)) { \
	736	(start) = sv_exp_grow(aTHX_ cat, glen); \
	737	(cur) = (start) + SvCUR(cat); \
	738	} \
	739	} STMT_END
	740
	741	#define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \
	742	STMT_START { \
	743	const STRLEN glen = (in_len); \
	744	STRLEN gl = glen; \
	745	if (utf8) gl *= UTF8_EXPAND; \
	746	if ((cur) + gl >= (start) + SvLEN(cat)) { \
	747	*cur = '\0'; \
	748	SvCUR_set((cat), (cur) - (start)); \
	749	(start) = sv_exp_grow(aTHX_ cat, gl); \
	750	(cur) = (start) + SvCUR(cat); \
	751	} \
	752	PUSH_BYTES(utf8, cur, buf, glen); \
	753	} STMT_END
	754
	755	#define PUSH_BYTE(utf8, s, byte) \
	756	STMT_START { \
	757	if (utf8) { \
	758	const U8 au8 = (byte); \
	759	bytes_to_uni(aTHX_ &au8, 1, &(s)); \
	760	} else (U8 )(s)++ = (byte); \
	761	} STMT_END
	762
	763	/* Only to be used inside a loop (see the break) */
	764	#define NEXT_UNI_VAL(val, cur, str, end, utf8_flags) \
	765	STMT_START { \
	766	STRLEN retlen; \
	767	if (str >= end) break; \
	768	val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \
	769	if (retlen == (STRLEN) -1 \|\| retlen == 0) { \
	770	*cur = '\0'; \
	771	Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \
	772	} \
	773	str += retlen; \
	774	} STMT_END
	775
	776	static const char _action( const tempsym_t symptr )
	777	{
	778	return ( symptr->flags & FLAG_PACK ) ? "pack" : "unpack";
	779	}
	780
	781	/* Returns the sizeof() struct described by pat */
	782	STATIC I32
	783	S_measure_struct(pTHX_ tempsym_t* symptr)
	784	{
	785	I32 total = 0;
	786
	787	while (next_symbol(symptr)) {
	788	I32 len;
	789	int size;
	790
	791	switch (symptr->howlen) {
	792	case e_star:
	793	Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
	794	_action( symptr ) );
	795	break;
	796	default:
	797	/* e_no_len and e_number */
	798	len = symptr->length;
	799	break;
	800	}
	801
	802	size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK;
	803	if (!size) {
	804	int star;
	805	/* endianness doesn't influence the size of a type */
	806	switch(TYPE_NO_ENDIANNESS(symptr->code)) {
	807	default:
	808	Perl_croak(aTHX_ "Invalid type '%c' in %s",
	809	(int)TYPE_NO_MODIFIERS(symptr->code),
	810	_action( symptr ) );
	811	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	812	case '.' \| TYPE_IS_SHRIEKING:
	813	case '@' \| TYPE_IS_SHRIEKING:
	814	#endif
	815	case '@':
	816	case '.':
	817	case '/':
	818	case 'U': /* XXXX Is it correct? */
	819	case 'w':
	820	case 'u':
	821	Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
	822	(int) TYPE_NO_MODIFIERS(symptr->code),
	823	_action( symptr ) );
	824	case '%':
	825	size = 0;
	826	break;
	827	case '(':
	828	{
	829	tempsym_t savsym = *symptr;
	830	symptr->patptr = savsym.grpbeg;
	831	symptr->patend = savsym.grpend;
	832	/* XXXX Theoretically, we need to measure many times at
	833	different positions, since the subexpression may contain
	834	alignment commands, but be not of aligned length.
	835	Need to detect this and croak(). */
	836	size = measure_struct(symptr);
	837	*symptr = savsym;
	838	break;
	839	}
	840	case 'X' \| TYPE_IS_SHRIEKING:
	841	/* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS.
	842	*/
	843	if (!len) /* Avoid division by 0 */
	844	len = 1;
	845	len = total % len; /* Assumed: the start is aligned. */
	846	/* FALL THROUGH */
	847	case 'X':
	848	size = -1;
	849	if (total < len)
	850	Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) );
	851	break;
	852	case 'x' \| TYPE_IS_SHRIEKING:
	853	if (!len) /* Avoid division by 0 */
	854	len = 1;
	855	star = total % len; /* Assumed: the start is aligned. */
	856	if (star) /* Other portable ways? */
	857	len = len - star;
	858	else
	859	len = 0;
	860	/* FALL THROUGH */
	861	case 'x':
	862	case 'A':
	863	case 'Z':
	864	case 'a':
	865	size = 1;
	866	break;
	867	case 'B':
	868	case 'b':
	869	len = (len + 7)/8;
	870	size = 1;
	871	break;
	872	case 'H':
	873	case 'h':
	874	len = (len + 1)/2;
	875	size = 1;
	876	break;
	877
	878	case 'P':
	879	len = 1;
	880	size = sizeof(char*);
	881	break;
	882	}
	883	}
	884	total += len * size;
	885	}
	886	return total;
	887	}
	888
	889
	890	/* locate matching closing parenthesis or bracket
	891	* returns char pointer to char after match, or NULL
	892	*/
	893	STATIC const char *
	894	S_group_end(pTHX_ register const char patptr, register const char patend, char ender)
	895	{
	896	while (patptr < patend) {
	897	const char c = *patptr++;
	898
	899	if (isSPACE(c))
	900	continue;
	901	else if (c == ender)
	902	return patptr-1;
	903	else if (c == '#') {
	904	while (patptr < patend && *patptr != '\n')
	905	patptr++;
	906	continue;
	907	} else if (c == '(')
	908	patptr = group_end(patptr, patend, ')') + 1;
	909	else if (c == '[')
	910	patptr = group_end(patptr, patend, ']') + 1;
	911	}
	912	Perl_croak(aTHX_ "No group ending character '%c' found in template",
	913	ender);
	914	return 0;
	915	}
	916
	917
	918	/* Convert unsigned decimal number to binary.
	919	* Expects a pointer to the first digit and address of length variable
	920	* Advances char pointer to 1st non-digit char and returns number
	921	*/
	922	STATIC const char *
	923	S_get_num(pTHX_ register const char patptr, I32 lenptr )
	924	{
	925	I32 len = *patptr++ - '0';
	926	while (isDIGIT(*patptr)) {
	927	if (len >= 0x7FFFFFFF/10)
	928	Perl_croak(aTHX_ "pack/unpack repeat count overflow");
	929	len = (len * 10) + (*patptr++ - '0');
	930	}
	931	*lenptr = len;
	932	return patptr;
	933	}
	934
	935	/* The marvellous template parsing routine: Using state stored in *symptr,
	936	* locates next template code and count
	937	*/
	938	STATIC bool
	939	S_next_symbol(pTHX_ tempsym_t* symptr )
	940	{
	941	const char* patptr = symptr->patptr;
	942	const char* patend = symptr->patend;
	943
	944	symptr->flags &= ~FLAG_SLASH;
	945
	946	while (patptr < patend) {
	947	if (isSPACE(*patptr))
	948	patptr++;
	949	else if (*patptr == '#') {
	950	patptr++;
	951	while (patptr < patend && *patptr != '\n')
	952	patptr++;
	953	if (patptr < patend)
	954	patptr++;
	955	} else {
	956	/* We should have found a template code */
	957	I32 code = *patptr++ & 0xFF;
	958	U32 inherited_modifiers = 0;
	959
	960	if (code == ','){ /* grandfather in commas but with a warning */
	961	if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
	962	symptr->flags \|= FLAG_COMMA;
	963	Perl_warner(aTHX_ packWARN(WARN_UNPACK),
	964	"Invalid type ',' in %s", _action( symptr ) );
	965	}
	966	continue;
	967	}
	968
	969	/* for '(', skip to ')' */
	970	if (code == '(') {
	971	if( isDIGIT(patptr) \|\| patptr == '' \|\| patptr == '[' )
	972	Perl_croak(aTHX_ "()-group starts with a count in %s",
	973	_action( symptr ) );
	974	symptr->grpbeg = patptr;
	975	patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
	976	if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
	977	Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
	978	_action( symptr ) );
	979	}
	980
	981	/* look for group modifiers to inherit */
	982	if (TYPE_ENDIANNESS(symptr->flags)) {
	983	if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
	984	inherited_modifiers \|= TYPE_ENDIANNESS(symptr->flags);
	985	}
	986
	987	/* look for modifiers */
	988	while (patptr < patend) {
	989	const char *allowed;
	990	I32 modifier;
	991	switch (*patptr) {
	992	case '!':
	993	modifier = TYPE_IS_SHRIEKING;
	994	allowed = SHRIEKING_ALLOWED_TYPES;
	995	break;
	996	#ifdef PERL_PACK_CAN_BYTEORDER
	997	case '>':
	998	modifier = TYPE_IS_BIG_ENDIAN;
	999	allowed = ENDIANNESS_ALLOWED_TYPES;
	1000	break;
	1001	case '<':
	1002	modifier = TYPE_IS_LITTLE_ENDIAN;
	1003	allowed = ENDIANNESS_ALLOWED_TYPES;
	1004	break;
	1005	#endif /* PERL_PACK_CAN_BYTEORDER */
	1006	default:
	1007	allowed = "";
	1008	modifier = 0;
	1009	break;
	1010	}
	1011
	1012	if (modifier == 0)
	1013	break;
	1014
	1015	if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
	1016	Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
	1017	allowed, _action( symptr ) );
	1018
	1019	if (TYPE_ENDIANNESS(code \| modifier) == TYPE_ENDIANNESS_MASK)
	1020	Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
	1021	(int) TYPE_NO_MODIFIERS(code), _action( symptr ) );
	1022	else if (TYPE_ENDIANNESS(code \| modifier \| inherited_modifiers) ==
	1023	TYPE_ENDIANNESS_MASK)
	1024	Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
	1025	*patptr, _action( symptr ) );
	1026
	1027	if ((code & modifier) && ckWARN(WARN_UNPACK)) {
	1028	Perl_warner(aTHX_ packWARN(WARN_UNPACK),
	1029	"Duplicate modifier '%c' after '%c' in %s",
	1030	*patptr, (int) TYPE_NO_MODIFIERS(code),
	1031	_action( symptr ) );
	1032	}
	1033
	1034	code \|= modifier;
	1035	patptr++;
	1036	}
	1037
	1038	/* inherit modifiers */
	1039	code \|= inherited_modifiers;
	1040
	1041	/* look for count and/or / */
	1042	if (patptr < patend) {
	1043	if (isDIGIT(*patptr)) {
	1044	patptr = get_num( patptr, &symptr->length );
	1045	symptr->howlen = e_number;
	1046
	1047	} else if (patptr == '') {
	1048	patptr++;
	1049	symptr->howlen = e_star;
	1050
	1051	} else if (*patptr == '[') {
	1052	const char* lenptr = ++patptr;
	1053	symptr->howlen = e_number;
	1054	patptr = group_end( patptr, patend, ']' ) + 1;
	1055	/* what kind of [] is it? */
	1056	if (isDIGIT(*lenptr)) {
	1057	lenptr = get_num( lenptr, &symptr->length );
	1058	if( *lenptr != ']' )
	1059	Perl_croak(aTHX_ "Malformed integer in [] in %s",
	1060	_action( symptr ) );
	1061	} else {
	1062	tempsym_t savsym = *symptr;
	1063	symptr->patend = patptr-1;
	1064	symptr->patptr = lenptr;
	1065	savsym.length = measure_struct(symptr);
	1066	*symptr = savsym;
	1067	}
	1068	} else {
	1069	symptr->howlen = e_no_len;
	1070	symptr->length = 1;
	1071	}
	1072
	1073	/* try to find / */
	1074	while (patptr < patend) {
	1075	if (isSPACE(*patptr))
	1076	patptr++;
	1077	else if (*patptr == '#') {
	1078	patptr++;
	1079	while (patptr < patend && *patptr != '\n')
	1080	patptr++;
	1081	if (patptr < patend)
	1082	patptr++;
	1083	} else {
	1084	if (*patptr == '/') {
	1085	symptr->flags \|= FLAG_SLASH;
	1086	patptr++;
	1087	if (patptr < patend &&
	1088	(isDIGIT(patptr) \|\| patptr == '' \|\| patptr == '['))
	1089	Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
	1090	_action( symptr ) );
	1091	}
	1092	break;
	1093	}
	1094	}
	1095	} else {
	1096	/* at end - no count, no / */
	1097	symptr->howlen = e_no_len;
	1098	symptr->length = 1;
	1099	}
	1100
	1101	symptr->code = code;
	1102	symptr->patptr = patptr;
	1103	return TRUE;
	1104	}
	1105	}
	1106	symptr->patptr = patptr;
	1107	return FALSE;
	1108	}
	1109
	1110	/*
	1111	There is no way to cleanly handle the case where we should process the
	1112	string per byte in its upgraded form while it's really in downgraded form
	1113	(e.g. estimates like strend-s as an upper bound for the number of
	1114	characters left wouldn't work). So if we foresee the need of this
	1115	(pattern starts with U or contains U0), we want to work on the encoded
	1116	version of the string. Users are advised to upgrade their pack string
	1117	themselves if they need to do a lot of unpacks like this on it
	1118	*/
	1119	STATIC bool
	1120	need_utf8(const char pat, const char patend)
	1121	{
	1122	bool first = TRUE;
	1123	while (pat < patend) {
	1124	if (pat[0] == '#') {
	1125	pat++;
	1126	pat = (const char *) memchr(pat, '\n', patend-pat);
	1127	if (!pat) return FALSE;
	1128	} else if (pat[0] == 'U') {
	1129	if (first \|\| pat[1] == '0') return TRUE;
	1130	} else first = FALSE;
	1131	pat++;
	1132	}
	1133	return FALSE;
	1134	}
	1135
	1136	STATIC char
	1137	first_symbol(const char pat, const char patend) {
	1138	while (pat < patend) {
	1139	if (pat[0] != '#') return pat[0];
	1140	pat++;
	1141	pat = (const char *) memchr(pat, '\n', patend-pat);
	1142	if (!pat) return 0;
	1143	pat++;
	1144	}
	1145	return 0;
	1146	}
	1147
	1148	/*
	1149	=for apidoc unpack_str
	1150
	1151	The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
	1152	and ocnt are not used. This call should not be used, use unpackstring instead.
	1153
	1154	=cut */
	1155
	1156	I32
	1157	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)
	1158	{
	1159	tempsym_t sym;
	1160	PERL_UNUSED_ARG(strbeg);
	1161	PERL_UNUSED_ARG(new_s);
	1162	PERL_UNUSED_ARG(ocnt);
	1163
	1164	if (flags & FLAG_DO_UTF8) flags \|= FLAG_WAS_UTF8;
	1165	else if (need_utf8(pat, patend)) {
	1166	/* We probably should try to avoid this in case a scalar context call
	1167	wouldn't get to the "U0" */
	1168	STRLEN len = strend - s;
	1169	s = (char ) bytes_to_utf8((U8 ) s, &len);
	1170	SAVEFREEPV(s);
	1171	strend = s + len;
	1172	flags \|= FLAG_DO_UTF8;
	1173	}
	1174
	1175	if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
	1176	flags \|= FLAG_PARSE_UTF8;
	1177
	1178	TEMPSYM_INIT(&sym, pat, patend, flags);
	1179
	1180	return unpack_rec(&sym, s, s, strend, NULL );
	1181	}
	1182
	1183	/*
	1184	=for apidoc unpackstring
	1185
	1186	The engine implementing unpack() Perl function. C<unpackstring> puts the
	1187	extracted list items on the stack and returns the number of elements.
	1188	Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
	1189
	1190	=cut */
	1191
	1192	I32
	1193	Perl_unpackstring(pTHX_ const char pat, const char patend, const char s, const char strend, U32 flags)
	1194	{
	1195	tempsym_t sym;
	1196
	1197	if (flags & FLAG_DO_UTF8) flags \|= FLAG_WAS_UTF8;
	1198	else if (need_utf8(pat, patend)) {
	1199	/* We probably should try to avoid this in case a scalar context call
	1200	wouldn't get to the "U0" */
	1201	STRLEN len = strend - s;
	1202	s = (char ) bytes_to_utf8((U8 ) s, &len);
	1203	SAVEFREEPV(s);
	1204	strend = s + len;
	1205	flags \|= FLAG_DO_UTF8;
	1206	}
	1207
	1208	if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8))
	1209	flags \|= FLAG_PARSE_UTF8;
	1210
	1211	TEMPSYM_INIT(&sym, pat, patend, flags);
	1212
	1213	return unpack_rec(&sym, s, s, strend, NULL );
	1214	}
	1215
	1216	STATIC
	1217	I32
	1218	S_unpack_rec(pTHX_ tempsym_t* symptr, const char s, const char strbeg, const char strend, const char *new_s )
	1219	{
	1220	dVAR; dSP;
	1221	SV *sv;
	1222	const I32 start_sp_offset = SP - PL_stack_base;
	1223	howlen_t howlen;
	1224
	1225	I32 checksum = 0;
	1226	UV cuv = 0;
	1227	NV cdouble = 0.0;
	1228	const int bits_in_uv = CHAR_BIT * sizeof(cuv);
	1229	bool beyond = FALSE;
	1230	bool explicit_length;
	1231	const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
	1232	bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
	1233	symptr->strbeg = s - strbeg;
	1234
	1235	while (next_symbol(symptr)) {
	1236	packprops_t props;
	1237	I32 len;
	1238	I32 datumtype = symptr->code;
	1239	/* do first one only unless in list context
	1240	/ is implemented by unpacking the count, then popping it from the
	1241	stack, so must check that we're not in the middle of a / */
	1242	if ( unpack_only_one
	1243	&& (SP - PL_stack_base == start_sp_offset + 1)
	1244	&& (datumtype != '/') ) /* XXX can this be omitted */
	1245	break;
	1246
	1247	switch (howlen = symptr->howlen) {
	1248	case e_star:
	1249	len = strend - strbeg; /* long enough */
	1250	break;
	1251	default:
	1252	/* e_no_len and e_number */
	1253	len = symptr->length;
	1254	break;
	1255	}
	1256
	1257	explicit_length = TRUE;
	1258	redo_switch:
	1259	beyond = s >= strend;
	1260
	1261	props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
	1262	if (props) {
	1263	/* props nonzero means we can process this letter. */
	1264	const long size = props & PACK_SIZE_MASK;
	1265	const long howmany = (strend - s) / size;
	1266	if (len > howmany)
	1267	len = howmany;
	1268
	1269	if (!checksum \|\| (props & PACK_SIZE_CANNOT_CSUM)) {
	1270	if (len && unpack_only_one) len = 1;
	1271	EXTEND(SP, len);
	1272	EXTEND_MORTAL(len);
	1273	}
	1274	}
	1275
	1276	switch(TYPE_NO_ENDIANNESS(datumtype)) {
	1277	default:
	1278	Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
	1279
	1280	case '%':
	1281	if (howlen == e_no_len)
	1282	len = 16; /* len is not specified */
	1283	checksum = len;
	1284	cuv = 0;
	1285	cdouble = 0;
	1286	continue;
	1287	break;
	1288	case '(':
	1289	{
	1290	tempsym_t savsym = *symptr;
	1291	const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
	1292	symptr->flags \|= group_modifiers;
	1293	symptr->patend = savsym.grpend;
	1294	symptr->previous = &savsym;
	1295	symptr->level++;
	1296	PUTBACK;
	1297	while (len--) {
	1298	symptr->patptr = savsym.grpbeg;
	1299	if (utf8) symptr->flags \|= FLAG_PARSE_UTF8;
	1300	else symptr->flags &= ~FLAG_PARSE_UTF8;
	1301	unpack_rec(symptr, s, strbeg, strend, &s);
	1302	if (s == strend && savsym.howlen == e_star)
	1303	break; /* No way to continue */
	1304	}
	1305	SPAGAIN;
	1306	savsym.flags = symptr->flags & ~group_modifiers;
	1307	*symptr = savsym;
	1308	break;
	1309	}
	1310	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	1311	case '.' \| TYPE_IS_SHRIEKING:
	1312	#endif
	1313	case '.': {
	1314	const char *from;
	1315	SV *sv;
	1316	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	1317	const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING);
	1318	#else /* PERL_PACK_CAN_SHRIEKSIGN */
	1319	const bool u8 = utf8;
	1320	#endif
	1321	if (howlen == e_star) from = strbeg;
	1322	else if (len <= 0) from = s;
	1323	else {
	1324	tempsym_t *group = symptr;
	1325
	1326	while (--len && group) group = group->previous;
	1327	from = group ? strbeg + group->strbeg : strbeg;
	1328	}
	1329	sv = from <= s ?
	1330	newSVuv( u8 ? (UV) utf8_length((const U8)from, (const U8)s) : (UV) (s-from)) :
	1331	newSViv(-(u8 ? (IV) utf8_length((const U8)s, (const U8)from) : (IV) (from-s)));
	1332	XPUSHs(sv_2mortal(sv));
	1333	break;
	1334	}
	1335	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	1336	case '@' \| TYPE_IS_SHRIEKING:
	1337	#endif
	1338	case '@':
	1339	s = strbeg + symptr->strbeg;
	1340	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	1341	if (utf8 && !(datumtype & TYPE_IS_SHRIEKING))
	1342	#else /* PERL_PACK_CAN_SHRIEKSIGN */
	1343	if (utf8)
	1344	#endif
	1345	{
	1346	while (len > 0) {
	1347	if (s >= strend)
	1348	Perl_croak(aTHX_ "'@' outside of string in unpack");
	1349	s += UTF8SKIP(s);
	1350	len--;
	1351	}
	1352	if (s > strend)
	1353	Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack");
	1354	} else {
	1355	if (strend-s < len)
	1356	Perl_croak(aTHX_ "'@' outside of string in unpack");
	1357	s += len;
	1358	}
	1359	break;
	1360	case 'X' \| TYPE_IS_SHRIEKING:
	1361	if (!len) /* Avoid division by 0 */
	1362	len = 1;
	1363	if (utf8) {
	1364	const char hop, last;
	1365	I32 l = len;
	1366	hop = last = strbeg;
	1367	while (hop < s) {
	1368	hop += UTF8SKIP(hop);
	1369	if (--l == 0) {
	1370	last = hop;
	1371	l = len;
	1372	}
	1373	}
	1374	if (last > s)
	1375	Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
	1376	s = last;
	1377	break;
	1378	}
	1379	len = (s - strbeg) % len;
	1380	/* FALL THROUGH */
	1381	case 'X':
	1382	if (utf8) {
	1383	while (len > 0) {
	1384	if (s <= strbeg)
	1385	Perl_croak(aTHX_ "'X' outside of string in unpack");
	1386	while (--s, UTF8_IS_CONTINUATION(*s)) {
	1387	if (s <= strbeg)
	1388	Perl_croak(aTHX_ "'X' outside of string in unpack");
	1389	}
	1390	len--;
	1391	}
	1392	} else {
	1393	if (len > s - strbeg)
	1394	Perl_croak(aTHX_ "'X' outside of string in unpack" );
	1395	s -= len;
	1396	}
	1397	break;
	1398	case 'x' \| TYPE_IS_SHRIEKING: {
	1399	I32 ai32;
	1400	if (!len) /* Avoid division by 0 */
	1401	len = 1;
	1402	if (utf8) ai32 = utf8_length((U8 ) strbeg, (U8 ) s) % len;
	1403	else ai32 = (s - strbeg) % len;
	1404	if (ai32 == 0) break;
	1405	len -= ai32;
	1406	}
	1407	/* FALL THROUGH */
	1408	case 'x':
	1409	if (utf8) {
	1410	while (len>0) {
	1411	if (s >= strend)
	1412	Perl_croak(aTHX_ "'x' outside of string in unpack");
	1413	s += UTF8SKIP(s);
	1414	len--;
	1415	}
	1416	} else {
	1417	if (len > strend - s)
	1418	Perl_croak(aTHX_ "'x' outside of string in unpack");
	1419	s += len;
	1420	}
	1421	break;
	1422	case '/':
	1423	Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
	1424	break;
	1425	case 'A':
	1426	case 'Z':
	1427	case 'a':
	1428	if (checksum) {
	1429	/* Preliminary length estimate is assumed done in 'W' */
	1430	if (len > strend - s) len = strend - s;
	1431	goto W_checksum;
	1432	}
	1433	if (utf8) {
	1434	I32 l;
	1435	const char *hop;
	1436	for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) {
	1437	if (hop >= strend) {
	1438	if (hop > strend)
	1439	Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
	1440	break;
	1441	}
	1442	}
	1443	if (hop > strend)
	1444	Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
	1445	len = hop - s;
	1446	} else if (len > strend - s)
	1447	len = strend - s;
	1448
	1449	if (datumtype == 'Z') {
	1450	/* 'Z' strips stuff after first null */
	1451	const char ptr, end;
	1452	end = s + len;
	1453	for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break;
	1454	sv = newSVpvn(s, ptr-s);
	1455	if (howlen == e_star) /* exact for 'Z' /
	1456	len = ptr-s + (ptr != strend ? 1 : 0);
	1457	} else if (datumtype == 'A') {
	1458	/* 'A' strips both nulls and spaces */
	1459	const char *ptr;
	1460	if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) {
	1461	for (ptr = s+len-1; ptr >= s; ptr--)
	1462	if (ptr != 0 && !UTF8_IS_CONTINUATION(ptr) &&
	1463	!is_utf8_space((U8 *) ptr)) break;
	1464	if (ptr >= s) ptr += UTF8SKIP(ptr);
	1465	else ptr++;
	1466	if (ptr > s+len)
	1467	Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
	1468	} else {
	1469	for (ptr = s+len-1; ptr >= s; ptr--)
	1470	if (ptr != 0 && !isSPACE(ptr)) break;
	1471	ptr++;
	1472	}
	1473	sv = newSVpvn(s, ptr-s);
	1474	} else sv = newSVpvn(s, len);
	1475
	1476	if (utf8) {
	1477	SvUTF8_on(sv);
	1478	/* Undo any upgrade done due to need_utf8() */
	1479	if (!(symptr->flags & FLAG_WAS_UTF8))
	1480	sv_utf8_downgrade(sv, 0);
	1481	}
	1482	XPUSHs(sv_2mortal(sv));
	1483	s += len;
	1484	break;
	1485	case 'B':
	1486	case 'b': {
	1487	char *str;
	1488	if (howlen == e_star \|\| len > (strend - s) * 8)
	1489	len = (strend - s) * 8;
	1490	if (checksum) {
	1491	if (!PL_bitcount) {
	1492	int bits;
	1493	Newxz(PL_bitcount, 256, char);
	1494	for (bits = 1; bits < 256; bits++) {
	1495	if (bits & 1) PL_bitcount[bits]++;
	1496	if (bits & 2) PL_bitcount[bits]++;
	1497	if (bits & 4) PL_bitcount[bits]++;
	1498	if (bits & 8) PL_bitcount[bits]++;
	1499	if (bits & 16) PL_bitcount[bits]++;
	1500	if (bits & 32) PL_bitcount[bits]++;
	1501	if (bits & 64) PL_bitcount[bits]++;
	1502	if (bits & 128) PL_bitcount[bits]++;
	1503	}
	1504	}
	1505	if (utf8)
	1506	while (len >= 8 && s < strend) {
	1507	cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)];
	1508	len -= 8;
	1509	}
	1510	else
	1511	while (len >= 8) {
	1512	cuv += PL_bitcount[(U8 )s++];
	1513	len -= 8;
	1514	}
	1515	if (len && s < strend) {
	1516	U8 bits;
	1517	bits = SHIFT_BYTE(utf8, s, strend, datumtype);
	1518	if (datumtype == 'b')
	1519	while (len-- > 0) {
	1520	if (bits & 1) cuv++;
	1521	bits >>= 1;
	1522	}
	1523	else
	1524	while (len-- > 0) {
	1525	if (bits & 0x80) cuv++;
	1526	bits <<= 1;
	1527	}
	1528	}
	1529	break;
	1530	}
	1531
	1532	sv = sv_2mortal(NEWSV(35, len ? len : 1));
	1533	SvPOK_on(sv);
	1534	str = SvPVX(sv);
	1535	if (datumtype == 'b') {
	1536	U8 bits = 0;
	1537	const I32 ai32 = len;
	1538	for (len = 0; len < ai32; len++) {
	1539	if (len & 7) bits >>= 1;
	1540	else if (utf8) {
	1541	if (s >= strend) break;
	1542	bits = uni_to_byte(aTHX_ &s, strend, datumtype);
	1543	} else bits = (U8 ) s++;
	1544	*str++ = bits & 1 ? '1' : '0';
	1545	}
	1546	} else {
	1547	U8 bits = 0;
	1548	const I32 ai32 = len;
	1549	for (len = 0; len < ai32; len++) {
	1550	if (len & 7) bits <<= 1;
	1551	else if (utf8) {
	1552	if (s >= strend) break;
	1553	bits = uni_to_byte(aTHX_ &s, strend, datumtype);
	1554	} else bits = (U8 ) s++;
	1555	*str++ = bits & 0x80 ? '1' : '0';
	1556	}
	1557	}
	1558	*str = '\0';
	1559	SvCUR_set(sv, str - SvPVX_const(sv));
	1560	XPUSHs(sv);
	1561	break;
	1562	}
	1563	case 'H':
	1564	case 'h': {
	1565	char *str;
	1566	/* Preliminary length estimate, acceptable for utf8 too */
	1567	if (howlen == e_star \|\| len > (strend - s) * 2)
	1568	len = (strend - s) * 2;
	1569	sv = sv_2mortal(NEWSV(35, len ? len : 1));
	1570	SvPOK_on(sv);
	1571	str = SvPVX(sv);
	1572	if (datumtype == 'h') {
	1573	U8 bits = 0;
	1574	I32 ai32 = len;
	1575	for (len = 0; len < ai32; len++) {
	1576	if (len & 1) bits >>= 4;
	1577	else if (utf8) {
	1578	if (s >= strend) break;
	1579	bits = uni_to_byte(aTHX_ &s, strend, datumtype);
	1580	} else bits = * (U8 *) s++;
	1581	*str++ = PL_hexdigit[bits & 15];
	1582	}
	1583	} else {
	1584	U8 bits = 0;
	1585	const I32 ai32 = len;
	1586	for (len = 0; len < ai32; len++) {
	1587	if (len & 1) bits <<= 4;
	1588	else if (utf8) {
	1589	if (s >= strend) break;
	1590	bits = uni_to_byte(aTHX_ &s, strend, datumtype);
	1591	} else bits = (U8 ) s++;
	1592	*str++ = PL_hexdigit[(bits >> 4) & 15];
	1593	}
	1594	}
	1595	*str = '\0';
	1596	SvCUR_set(sv, str - SvPVX_const(sv));
	1597	XPUSHs(sv);
	1598	break;
	1599	}
	1600	case 'c':
	1601	while (len-- > 0) {
	1602	int aint = SHIFT_BYTE(utf8, s, strend, datumtype);
	1603	if (aint >= 128) /* fake up signed chars */
	1604	aint -= 256;
	1605	if (!checksum)
	1606	PUSHs(sv_2mortal(newSViv((IV)aint)));
	1607	else if (checksum > bits_in_uv)
	1608	cdouble += (NV)aint;
	1609	else
	1610	cuv += aint;
	1611	}
	1612	break;
	1613	case 'C':
	1614	case 'W':
	1615	W_checksum:
	1616	if (len == 0) {
	1617	if (explicit_length && datumtype == 'C')
	1618	/* Switch to "character" mode */
	1619	utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
	1620	break;
	1621	}
	1622	if (datumtype == 'C' ?
	1623	(symptr->flags & FLAG_DO_UTF8) &&
	1624	!(symptr->flags & FLAG_WAS_UTF8) : utf8) {
	1625	while (len-- > 0 && s < strend) {
	1626	STRLEN retlen;
	1627	const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen,
	1628	ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
	1629	if (retlen == (STRLEN) -1 \|\| retlen == 0)
	1630	Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
	1631	s += retlen;
	1632	if (!checksum)
	1633	PUSHs(sv_2mortal(newSVuv((UV) val)));
	1634	else if (checksum > bits_in_uv)
	1635	cdouble += (NV) val;
	1636	else
	1637	cuv += val;
	1638	}
	1639	} else if (!checksum)
	1640	while (len-- > 0) {
	1641	const U8 ch = (U8 ) s++;
	1642	PUSHs(sv_2mortal(newSVuv((UV) ch)));
	1643	}
	1644	else if (checksum > bits_in_uv)
	1645	while (len-- > 0) cdouble += (NV) (U8 ) s++;
	1646	else
	1647	while (len-- > 0) cuv += (U8 ) s++;
	1648	break;
	1649	case 'U':
	1650	if (len == 0) {
	1651	if (explicit_length) {
	1652	/* Switch to "bytes in UTF-8" mode */
	1653	if (symptr->flags & FLAG_DO_UTF8) utf8 = 0;
	1654	else
	1655	/* Should be impossible due to the need_utf8() test */
	1656	Perl_croak(aTHX_ "U0 mode on a byte string");
	1657	}
	1658	break;
	1659	}
	1660	if (len > strend - s) len = strend - s;
	1661	if (!checksum) {
	1662	if (len && unpack_only_one) len = 1;
	1663	EXTEND(SP, len);
	1664	EXTEND_MORTAL(len);
	1665	}
	1666	while (len-- > 0 && s < strend) {
	1667	STRLEN retlen;
	1668	UV auv;
	1669	if (utf8) {
	1670	U8 result[UTF8_MAXLEN];
	1671	const char *ptr = s;
	1672	STRLEN len;
	1673	/* Bug: warns about bad utf8 even if we are short on bytes
	1674	and will break out of the loop */
	1675	if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1,
	1676	'U'))
	1677	break;
	1678	len = UTF8SKIP(result);
	1679	if (!uni_to_bytes(aTHX_ &ptr, strend,
	1680	(char *) &result[1], len-1, 'U')) break;
	1681	auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
	1682	s = ptr;
	1683	} else {
	1684	auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV);
	1685	if (retlen == (STRLEN) -1 \|\| retlen == 0)
	1686	Perl_croak(aTHX_ "Malformed UTF-8 string in unpack");
	1687	s += retlen;
	1688	}
	1689	if (!checksum)
	1690	PUSHs(sv_2mortal(newSVuv((UV) auv)));
	1691	else if (checksum > bits_in_uv)
	1692	cdouble += (NV) auv;
	1693	else
	1694	cuv += auv;
	1695	}
	1696	break;
	1697	case 's' \| TYPE_IS_SHRIEKING:
	1698	#if SHORTSIZE != SIZE16
	1699	while (len-- > 0) {
	1700	short ashort;
	1701	SHIFT_VAR(utf8, s, strend, ashort, datumtype);
	1702	DO_BO_UNPACK(ashort, s);
	1703	if (!checksum)
	1704	PUSHs(sv_2mortal(newSViv((IV)ashort)));
	1705	else if (checksum > bits_in_uv)
	1706	cdouble += (NV)ashort;
	1707	else
	1708	cuv += ashort;
	1709	}
	1710	break;
	1711	#else
	1712	/* Fallthrough! */
	1713	#endif
	1714	case 's':
	1715	while (len-- > 0) {
	1716	I16 ai16;
	1717
	1718	#if U16SIZE > SIZE16
	1719	ai16 = 0;
	1720	#endif
	1721	SHIFT16(utf8, s, strend, &ai16, datumtype);
	1722	DO_BO_UNPACK(ai16, 16);
	1723	#if U16SIZE > SIZE16
	1724	if (ai16 > 32767)
	1725	ai16 -= 65536;
	1726	#endif
	1727	if (!checksum)
	1728	PUSHs(sv_2mortal(newSViv((IV)ai16)));
	1729	else if (checksum > bits_in_uv)
	1730	cdouble += (NV)ai16;
	1731	else
	1732	cuv += ai16;
	1733	}
	1734	break;
	1735	case 'S' \| TYPE_IS_SHRIEKING:
	1736	#if SHORTSIZE != SIZE16
	1737	while (len-- > 0) {
	1738	unsigned short aushort;
	1739	SHIFT_VAR(utf8, s, strend, aushort, datumtype);
	1740	DO_BO_UNPACK(aushort, s);
	1741	if (!checksum)
	1742	PUSHs(sv_2mortal(newSVuv((UV) aushort)));
	1743	else if (checksum > bits_in_uv)
	1744	cdouble += (NV)aushort;
	1745	else
	1746	cuv += aushort;
	1747	}
	1748	break;
	1749	#else
	1750	/* Fallhrough! */
	1751	#endif
	1752	case 'v':
	1753	case 'n':
	1754	case 'S':
	1755	while (len-- > 0) {
	1756	U16 au16;
	1757	#if U16SIZE > SIZE16
	1758	au16 = 0;
	1759	#endif
	1760	SHIFT16(utf8, s, strend, &au16, datumtype);
	1761	DO_BO_UNPACK(au16, 16);
	1762	#ifdef HAS_NTOHS
	1763	if (datumtype == 'n')
	1764	au16 = PerlSock_ntohs(au16);
	1765	#endif
	1766	#ifdef HAS_VTOHS
	1767	if (datumtype == 'v')
	1768	au16 = vtohs(au16);
	1769	#endif
	1770	if (!checksum)
	1771	PUSHs(sv_2mortal(newSVuv((UV)au16)));
	1772	else if (checksum > bits_in_uv)
	1773	cdouble += (NV) au16;
	1774	else
	1775	cuv += au16;
	1776	}
	1777	break;
	1778	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	1779	case 'v' \| TYPE_IS_SHRIEKING:
	1780	case 'n' \| TYPE_IS_SHRIEKING:
	1781	while (len-- > 0) {
	1782	I16 ai16;
	1783	# if U16SIZE > SIZE16
	1784	ai16 = 0;
	1785	# endif
	1786	SHIFT16(utf8, s, strend, &ai16, datumtype);
	1787	# ifdef HAS_NTOHS
	1788	if (datumtype == ('n' \| TYPE_IS_SHRIEKING))
	1789	ai16 = (I16) PerlSock_ntohs((U16) ai16);
	1790	# endif /* HAS_NTOHS */
	1791	# ifdef HAS_VTOHS
	1792	if (datumtype == ('v' \| TYPE_IS_SHRIEKING))
	1793	ai16 = (I16) vtohs((U16) ai16);
	1794	# endif /* HAS_VTOHS */
	1795	if (!checksum)
	1796	PUSHs(sv_2mortal(newSViv((IV)ai16)));
	1797	else if (checksum > bits_in_uv)
	1798	cdouble += (NV) ai16;
	1799	else
	1800	cuv += ai16;
	1801	}
	1802	break;
	1803	#endif /* PERL_PACK_CAN_SHRIEKSIGN */
	1804	case 'i':
	1805	case 'i' \| TYPE_IS_SHRIEKING:
	1806	while (len-- > 0) {
	1807	int aint;
	1808	SHIFT_VAR(utf8, s, strend, aint, datumtype);
	1809	DO_BO_UNPACK(aint, i);
	1810	if (!checksum)
	1811	PUSHs(sv_2mortal(newSViv((IV)aint)));
	1812	else if (checksum > bits_in_uv)
	1813	cdouble += (NV)aint;
	1814	else
	1815	cuv += aint;
	1816	}
	1817	break;
	1818	case 'I':
	1819	case 'I' \| TYPE_IS_SHRIEKING:
	1820	while (len-- > 0) {
	1821	unsigned int auint;
	1822	SHIFT_VAR(utf8, s, strend, auint, datumtype);
	1823	DO_BO_UNPACK(auint, i);
	1824	if (!checksum)
	1825	PUSHs(sv_2mortal(newSVuv((UV)auint)));
	1826	else if (checksum > bits_in_uv)
	1827	cdouble += (NV)auint;
	1828	else
	1829	cuv += auint;
	1830	}
	1831	break;
	1832	case 'j':
	1833	while (len-- > 0) {
	1834	IV aiv;
	1835	SHIFT_VAR(utf8, s, strend, aiv, datumtype);
	1836	#if IVSIZE == INTSIZE
	1837	DO_BO_UNPACK(aiv, i);
	1838	#elif IVSIZE == LONGSIZE
	1839	DO_BO_UNPACK(aiv, l);
	1840	#elif defined(HAS_QUAD) && IVSIZE == U64SIZE
	1841	DO_BO_UNPACK(aiv, 64);
	1842	#else
	1843	Perl_croak(aTHX_ "'j' not supported on this platform");
	1844	#endif
	1845	if (!checksum)
	1846	PUSHs(sv_2mortal(newSViv(aiv)));
	1847	else if (checksum > bits_in_uv)
	1848	cdouble += (NV)aiv;
	1849	else
	1850	cuv += aiv;
	1851	}
	1852	break;
	1853	case 'J':
	1854	while (len-- > 0) {
	1855	UV auv;
	1856	SHIFT_VAR(utf8, s, strend, auv, datumtype);
	1857	#if IVSIZE == INTSIZE
	1858	DO_BO_UNPACK(auv, i);
	1859	#elif IVSIZE == LONGSIZE
	1860	DO_BO_UNPACK(auv, l);
	1861	#elif defined(HAS_QUAD) && IVSIZE == U64SIZE
	1862	DO_BO_UNPACK(auv, 64);
	1863	#else
	1864	Perl_croak(aTHX_ "'J' not supported on this platform");
	1865	#endif
	1866	if (!checksum)
	1867	PUSHs(sv_2mortal(newSVuv(auv)));
	1868	else if (checksum > bits_in_uv)
	1869	cdouble += (NV)auv;
	1870	else
	1871	cuv += auv;
	1872	}
	1873	break;
	1874	case 'l' \| TYPE_IS_SHRIEKING:
	1875	#if LONGSIZE != SIZE32
	1876	while (len-- > 0) {
	1877	long along;
	1878	SHIFT_VAR(utf8, s, strend, along, datumtype);
	1879	DO_BO_UNPACK(along, l);
	1880	if (!checksum)
	1881	PUSHs(sv_2mortal(newSViv((IV)along)));
	1882	else if (checksum > bits_in_uv)
	1883	cdouble += (NV)along;
	1884	else
	1885	cuv += along;
	1886	}
	1887	break;
	1888	#else
	1889	/* Fallthrough! */
	1890	#endif
	1891	case 'l':
	1892	while (len-- > 0) {
	1893	I32 ai32;
	1894	#if U32SIZE > SIZE32
	1895	ai32 = 0;
	1896	#endif
	1897	SHIFT32(utf8, s, strend, &ai32, datumtype);
	1898	DO_BO_UNPACK(ai32, 32);
	1899	#if U32SIZE > SIZE32
	1900	if (ai32 > 2147483647) ai32 -= 4294967296;
	1901	#endif
	1902	if (!checksum)
	1903	PUSHs(sv_2mortal(newSViv((IV)ai32)));
	1904	else if (checksum > bits_in_uv)
	1905	cdouble += (NV)ai32;
	1906	else
	1907	cuv += ai32;
	1908	}
	1909	break;
	1910	case 'L' \| TYPE_IS_SHRIEKING:
	1911	#if LONGSIZE != SIZE32
	1912	while (len-- > 0) {
	1913	unsigned long aulong;
	1914	SHIFT_VAR(utf8, s, strend, aulong, datumtype);
	1915	DO_BO_UNPACK(aulong, l);
	1916	if (!checksum)
	1917	PUSHs(sv_2mortal(newSVuv((UV)aulong)));
	1918	else if (checksum > bits_in_uv)
	1919	cdouble += (NV)aulong;
	1920	else
	1921	cuv += aulong;
	1922	}
	1923	break;
	1924	#else
	1925	/* Fall through! */
	1926	#endif
	1927	case 'V':
	1928	case 'N':
	1929	case 'L':
	1930	while (len-- > 0) {
	1931	U32 au32;
	1932	#if U32SIZE > SIZE32
	1933	au32 = 0;
	1934	#endif
	1935	SHIFT32(utf8, s, strend, &au32, datumtype);
	1936	DO_BO_UNPACK(au32, 32);
	1937	#ifdef HAS_NTOHL
	1938	if (datumtype == 'N')
	1939	au32 = PerlSock_ntohl(au32);
	1940	#endif
	1941	#ifdef HAS_VTOHL
	1942	if (datumtype == 'V')
	1943	au32 = vtohl(au32);
	1944	#endif
	1945	if (!checksum)
	1946	PUSHs(sv_2mortal(newSVuv((UV)au32)));
	1947	else if (checksum > bits_in_uv)
	1948	cdouble += (NV)au32;
	1949	else
	1950	cuv += au32;
	1951	}
	1952	break;
	1953	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	1954	case 'V' \| TYPE_IS_SHRIEKING:
	1955	case 'N' \| TYPE_IS_SHRIEKING:
	1956	while (len-- > 0) {
	1957	I32 ai32;
	1958	# if U32SIZE > SIZE32
	1959	ai32 = 0;
	1960	# endif
	1961	SHIFT32(utf8, s, strend, &ai32, datumtype);
	1962	# ifdef HAS_NTOHL
	1963	if (datumtype == ('N' \| TYPE_IS_SHRIEKING))
	1964	ai32 = (I32)PerlSock_ntohl((U32)ai32);
	1965	# endif
	1966	# ifdef HAS_VTOHL
	1967	if (datumtype == ('V' \| TYPE_IS_SHRIEKING))
	1968	ai32 = (I32)vtohl((U32)ai32);
	1969	# endif
	1970	if (!checksum)
	1971	PUSHs(sv_2mortal(newSViv((IV)ai32)));
	1972	else if (checksum > bits_in_uv)
	1973	cdouble += (NV)ai32;
	1974	else
	1975	cuv += ai32;
	1976	}
	1977	break;
	1978	#endif /* PERL_PACK_CAN_SHRIEKSIGN */
	1979	case 'p':
	1980	while (len-- > 0) {
	1981	const char *aptr;
	1982	SHIFT_VAR(utf8, s, strend, aptr, datumtype);
	1983	DO_BO_UNPACK_PC(aptr);
	1984	/* newSVpv generates undef if aptr is NULL */
	1985	PUSHs(sv_2mortal(newSVpv(aptr, 0)));
	1986	}
	1987	break;
	1988	case 'w':
	1989	{
	1990	UV auv = 0;
	1991	U32 bytes = 0;
	1992
	1993	while (len > 0 && s < strend) {
	1994	U8 ch;
	1995	ch = SHIFT_BYTE(utf8, s, strend, datumtype);
	1996	auv = (auv << 7) \| (ch & 0x7f);
	1997	/* UTF8_IS_XXXXX not right here - using constant 0x80 */
	1998	if (ch < 0x80) {
	1999	bytes = 0;
	2000	PUSHs(sv_2mortal(newSVuv(auv)));
	2001	len--;
	2002	auv = 0;
	2003	continue;
	2004	}
	2005	if (++bytes >= sizeof(UV)) { /* promote to string */
	2006	const char *t;
	2007
	2008	sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
	2009	while (s < strend) {
	2010	ch = SHIFT_BYTE(utf8, s, strend, datumtype);
	2011	sv = mul128(sv, (U8)(ch & 0x7f));
	2012	if (!(ch & 0x80)) {
	2013	bytes = 0;
	2014	break;
	2015	}
	2016	}
	2017	t = SvPV_nolen_const(sv);
	2018	while (*t == '0')
	2019	t++;
	2020	sv_chop(sv, t);
	2021	PUSHs(sv_2mortal(sv));
	2022	len--;
	2023	auv = 0;
	2024	}
	2025	}
	2026	if ((s >= strend) && bytes)
	2027	Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
	2028	}
	2029	break;
	2030	case 'P':
	2031	if (symptr->howlen == e_star)
	2032	Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
	2033	EXTEND(SP, 1);
	2034	if (sizeof(char*) <= strend - s) {
	2035	char *aptr;
	2036	SHIFT_VAR(utf8, s, strend, aptr, datumtype);
	2037	DO_BO_UNPACK_PC(aptr);
	2038	/* newSVpvn generates undef if aptr is NULL */
	2039	PUSHs(sv_2mortal(newSVpvn(aptr, len)));
	2040	}
	2041	break;
	2042	#ifdef HAS_QUAD
	2043	case 'q':
	2044	while (len-- > 0) {
	2045	Quad_t aquad;
	2046	SHIFT_VAR(utf8, s, strend, aquad, datumtype);
	2047	DO_BO_UNPACK(aquad, 64);
	2048	if (!checksum)
	2049	PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ?
	2050	newSViv((IV)aquad) : newSVnv((NV)aquad)));
	2051	else if (checksum > bits_in_uv)
	2052	cdouble += (NV)aquad;
	2053	else
	2054	cuv += aquad;
	2055	}
	2056	break;
	2057	case 'Q':
	2058	while (len-- > 0) {
	2059	Uquad_t auquad;
	2060	SHIFT_VAR(utf8, s, strend, auquad, datumtype);
	2061	DO_BO_UNPACK(auquad, 64);
	2062	if (!checksum)
	2063	PUSHs(sv_2mortal(auquad <= UV_MAX ?
	2064	newSVuv((UV)auquad):newSVnv((NV)auquad)));
	2065	else if (checksum > bits_in_uv)
	2066	cdouble += (NV)auquad;
	2067	else
	2068	cuv += auquad;
	2069	}
	2070	break;
	2071	#endif /* HAS_QUAD */
	2072	/* float and double added gnb@melba.bby.oz.au 22/11/89 */
	2073	case 'f':
	2074	while (len-- > 0) {
	2075	float afloat;
	2076	SHIFT_VAR(utf8, s, strend, afloat, datumtype);
	2077	DO_BO_UNPACK_N(afloat, float);
	2078	if (!checksum)
	2079	PUSHs(sv_2mortal(newSVnv((NV)afloat)));
	2080	else
	2081	cdouble += afloat;
	2082	}
	2083	break;
	2084	case 'd':
	2085	while (len-- > 0) {
	2086	double adouble;
	2087	SHIFT_VAR(utf8, s, strend, adouble, datumtype);
	2088	DO_BO_UNPACK_N(adouble, double);
	2089	if (!checksum)
	2090	PUSHs(sv_2mortal(newSVnv((NV)adouble)));
	2091	else
	2092	cdouble += adouble;
	2093	}
	2094	break;
	2095	case 'F':
	2096	while (len-- > 0) {
	2097	NV anv;
	2098	SHIFT_VAR(utf8, s, strend, anv, datumtype);
	2099	DO_BO_UNPACK_N(anv, NV);
	2100	if (!checksum)
	2101	PUSHs(sv_2mortal(newSVnv(anv)));
	2102	else
	2103	cdouble += anv;
	2104	}
	2105	break;
	2106	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
	2107	case 'D':
	2108	while (len-- > 0) {
	2109	long double aldouble;
	2110	SHIFT_VAR(utf8, s, strend, aldouble, datumtype);
	2111	DO_BO_UNPACK_N(aldouble, long double);
	2112	if (!checksum)
	2113	PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
	2114	else
	2115	cdouble += aldouble;
	2116	}
	2117	break;
	2118	#endif
	2119	case 'u':
	2120	/* MKS:
	2121	* Initialise the decode mapping. By using a table driven
	2122	* algorithm, the code will be character-set independent
	2123	* (and just as fast as doing character arithmetic)
	2124	*/
	2125	if (PL_uudmap['M'] == 0) {
	2126	int i;
	2127
	2128	for (i = 0; i < sizeof(PL_uuemap); i += 1)
	2129	PL_uudmap[(U8)PL_uuemap[i]] = i;
	2130	/*
	2131	* Because ' ' and '`' map to the same value,
	2132	* we need to decode them both the same.
	2133	*/
	2134	PL_uudmap[' '] = 0;
	2135	}
	2136	{
	2137	const STRLEN l = (STRLEN) (strend - s) * 3 / 4;
	2138	sv = sv_2mortal(NEWSV(42, l));
	2139	if (l) SvPOK_on(sv);
	2140	}
	2141	if (utf8) {
	2142	while (next_uni_uu(aTHX_ &s, strend, &len)) {
	2143	I32 a, b, c, d;
	2144	char hunk[4];
	2145
	2146	hunk[3] = '\0';
	2147	while (len > 0) {
	2148	next_uni_uu(aTHX_ &s, strend, &a);
	2149	next_uni_uu(aTHX_ &s, strend, &b);
	2150	next_uni_uu(aTHX_ &s, strend, &c);
	2151	next_uni_uu(aTHX_ &s, strend, &d);
	2152	hunk[0] = (char)((a << 2) \| (b >> 4));
	2153	hunk[1] = (char)((b << 4) \| (c >> 2));
	2154	hunk[2] = (char)((c << 6) \| d);
	2155	sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
	2156	len -= 3;
	2157	}
	2158	if (s < strend) {
	2159	if (*s == '\n') {
	2160	s++;
	2161	}
	2162	else {
	2163	/* possible checksum byte */
	2164	const char *skip = s+UTF8SKIP(s);
	2165	if (skip < strend && *skip == '\n')
	2166	s = skip+1;
	2167	}
	2168	}
	2169	}
	2170	} else {
	2171	while (s < strend && s > ' ' && ISUUCHAR(s)) {
	2172	I32 a, b, c, d;
	2173	char hunk[4];
	2174
	2175	hunk[3] = '\0';
	2176	len = PL_uudmap[(U8)s++] & 077;
	2177	while (len > 0) {
	2178	if (s < strend && ISUUCHAR(*s))
	2179	a = PL_uudmap[(U8)s++] & 077;
	2180	else
	2181	a = 0;
	2182	if (s < strend && ISUUCHAR(*s))
	2183	b = PL_uudmap[(U8)s++] & 077;
	2184	else
	2185	b = 0;
	2186	if (s < strend && ISUUCHAR(*s))
	2187	c = PL_uudmap[(U8)s++] & 077;
	2188	else
	2189	c = 0;
	2190	if (s < strend && ISUUCHAR(*s))
	2191	d = PL_uudmap[(U8)s++] & 077;
	2192	else
	2193	d = 0;
	2194	hunk[0] = (char)((a << 2) \| (b >> 4));
	2195	hunk[1] = (char)((b << 4) \| (c >> 2));
	2196	hunk[2] = (char)((c << 6) \| d);
	2197	sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
	2198	len -= 3;
	2199	}
	2200	if (*s == '\n')
	2201	s++;
	2202	else /* possible checksum byte */
	2203	if (s + 1 < strend && s[1] == '\n')
	2204	s += 2;
	2205	}
	2206	}
	2207	XPUSHs(sv);
	2208	break;
	2209	}
	2210
	2211	if (checksum) {
	2212	if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) \|\|
	2213	(checksum > bits_in_uv &&
	2214	strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
	2215	NV trouble, anv;
	2216
	2217	anv = (NV) (1 << (checksum & 15));
	2218	while (checksum >= 16) {
	2219	checksum -= 16;
	2220	anv *= 65536.0;
	2221	}
	2222	while (cdouble < 0.0)
	2223	cdouble += anv;
	2224	cdouble = Perl_modf(cdouble / anv, &trouble) * anv;
	2225	sv = newSVnv(cdouble);
	2226	}
	2227	else {
	2228	if (checksum < bits_in_uv) {
	2229	UV mask = ((UV)1 << checksum) - 1;
	2230	cuv &= mask;
	2231	}
	2232	sv = newSVuv(cuv);
	2233	}
	2234	XPUSHs(sv_2mortal(sv));
	2235	checksum = 0;
	2236	}
	2237
	2238	if (symptr->flags & FLAG_SLASH){
	2239	if (SP - PL_stack_base - start_sp_offset <= 0)
	2240	Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
	2241	if( next_symbol(symptr) ){
	2242	if( symptr->howlen == e_number )
	2243	Perl_croak(aTHX_ "Count after length/code in unpack" );
	2244	if( beyond ){
	2245	/* ...end of char buffer then no decent length available */
	2246	Perl_croak(aTHX_ "length/code after end of string in unpack" );
	2247	} else {
	2248	/* take top of stack (hope it's numeric) */
	2249	len = POPi;
	2250	if( len < 0 )
	2251	Perl_croak(aTHX_ "Negative '/' count in unpack" );
	2252	}
	2253	} else {
	2254	Perl_croak(aTHX_ "Code missing after '/' in unpack" );
	2255	}
	2256	datumtype = symptr->code;
	2257	explicit_length = FALSE;
	2258	goto redo_switch;
	2259	}
	2260	}
	2261
	2262	if (new_s)
	2263	*new_s = s;
	2264	PUTBACK;
	2265	return SP - PL_stack_base - start_sp_offset;
	2266	}
	2267
	2268	PP(pp_unpack)
	2269	{
	2270	dSP;
	2271	dPOPPOPssrl;
	2272	I32 gimme = GIMME_V;
	2273	STRLEN llen;
	2274	STRLEN rlen;
	2275	const char *pat = SvPV_const(left, llen);
	2276	const char *s = SvPV_const(right, rlen);
	2277	const char *strend = s + rlen;
	2278	const char *patend = pat + llen;
	2279	I32 cnt;
	2280
	2281	PUTBACK;
	2282	cnt = unpackstring(pat, patend, s, strend,
	2283	((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
	2284	\| (DO_UTF8(right) ? FLAG_DO_UTF8 : 0));
	2285
	2286	SPAGAIN;
	2287	if ( !cnt && gimme == G_SCALAR )
	2288	PUSHs(&PL_sv_undef);
	2289	RETURN;
	2290	}
	2291
	2292	STATIC U8 *
	2293	doencodes(U8 h, const char s, I32 len)
	2294	{
	2295	*h++ = PL_uuemap[len];
	2296	while (len > 2) {
	2297	*h++ = PL_uuemap[(077 & (s[0] >> 2))];
	2298	*h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) \| ((s[1] >> 4) & 017)))];
	2299	*h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) \| ((s[2] >> 6) & 03)))];
	2300	*h++ = PL_uuemap[(077 & (s[2] & 077))];
	2301	s += 3;
	2302	len -= 3;
	2303	}
	2304	if (len > 0) {
	2305	const char r = (len > 1 ? s[1] : '\0');
	2306	*h++ = PL_uuemap[(077 & (s[0] >> 2))];
	2307	*h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) \| ((r >> 4) & 017)))];
	2308	*h++ = PL_uuemap[(077 & ((r << 2) & 074))];
	2309	*h++ = PL_uuemap[0];
	2310	}
	2311	*h++ = '\n';
	2312	return h;
	2313	}
	2314
	2315	STATIC SV *
	2316	S_is_an_int(pTHX_ const char *s, STRLEN l)
	2317	{
	2318	SV *result = newSVpvn(s, l);
	2319	char const result_c = SvPV_nolen(result); / convenience */
	2320	char *out = result_c;
	2321	bool skip = 1;
	2322	bool ignore = 0;
	2323
	2324	while (*s) {
	2325	switch (*s) {
	2326	case ' ':
	2327	break;
	2328	case '+':
	2329	if (!skip) {
	2330	SvREFCNT_dec(result);
	2331	return (NULL);
	2332	}
	2333	break;
	2334	case '0':
	2335	case '1':
	2336	case '2':
	2337	case '3':
	2338	case '4':
	2339	case '5':
	2340	case '6':
	2341	case '7':
	2342	case '8':
	2343	case '9':
	2344	skip = 0;
	2345	if (!ignore) {
	2346	(out++) = s;
	2347	}
	2348	break;
	2349	case '.':
	2350	ignore = 1;
	2351	break;
	2352	default:
	2353	SvREFCNT_dec(result);
	2354	return (NULL);
	2355	}
	2356	s++;
	2357	}
	2358	*(out++) = '\0';
	2359	SvCUR_set(result, out - result_c);
	2360	return (result);
	2361	}
	2362
	2363	/* pnum must be '\0' terminated */
	2364	STATIC int
	2365	S_div128(pTHX_ SV pnum, bool done)
	2366	{
	2367	STRLEN len;
	2368	char * const s = SvPV(pnum, len);
	2369	char *t = s;
	2370	int m = 0;
	2371
	2372	*done = 1;
	2373	while (*t) {
	2374	const int i = m * 10 + (*t - '0');
	2375	const int r = (i >> 7); /* r < 10 */
	2376	m = i & 0x7F;
	2377	if (r) {
	2378	*done = 0;
	2379	}
	2380	*(t++) = '0' + r;
	2381	}
	2382	*(t++) = '\0';
	2383	SvCUR_set(pnum, (STRLEN) (t - s));
	2384	return (m);
	2385	}
	2386
	2387	/*
	2388	=for apidoc pack_cat
	2389
	2390	The engine implementing pack() Perl function. Note: parameters next_in_list and
	2391	flags are not used. This call should not be used; use packlist instead.
	2392
	2393	=cut */
	2394
	2395
	2396	void
	2397	Perl_pack_cat(pTHX_ SV cat, const char pat, const char patend, register SV beglist, SV endlist, SV **next_in_list, U32 flags)
	2398	{
	2399	tempsym_t sym;
	2400	PERL_UNUSED_ARG(next_in_list);
	2401	PERL_UNUSED_ARG(flags);
	2402
	2403	TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
	2404
	2405	(void)pack_rec( cat, &sym, beglist, endlist );
	2406	}
	2407
	2408
	2409	/*
	2410	=for apidoc packlist
	2411
	2412	The engine implementing pack() Perl function.
	2413
	2414	=cut */
	2415
	2416
	2417	void
	2418	Perl_packlist(pTHX_ SV cat, const char pat, const char patend, register SV beglist, SV *endlist )
	2419	{
	2420	STRLEN no_len;
	2421	tempsym_t sym;
	2422
	2423	TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK);
	2424
	2425	/* We're going to do changes through SvPVX(cat). Make sure it's valid.
	2426	Also make sure any UTF8 flag is loaded */
	2427	SvPV_force(cat, no_len);
	2428	if (DO_UTF8(cat)) sym.flags \|= FLAG_PARSE_UTF8 \| FLAG_DO_UTF8;
	2429
	2430	(void)pack_rec( cat, &sym, beglist, endlist );
	2431	}
	2432
	2433	/* like sv_utf8_upgrade, but also repoint the group start markers */
	2434	STATIC void
	2435	marked_upgrade(pTHX_ SV sv, tempsym_t sym_ptr) {
	2436	STRLEN len;
	2437	tempsym_t *group;
	2438	const char from_ptr, from_start, from_end, marks, *m;
	2439	char to_start, to_ptr;
	2440
	2441	if (SvUTF8(sv)) return;
	2442
	2443	from_start = SvPVX_const(sv);
	2444	from_end = from_start + SvCUR(sv);
	2445	for (from_ptr = from_start; from_ptr < from_end; from_ptr++)
	2446	if (!NATIVE_IS_INVARIANT(*from_ptr)) break;
	2447	if (from_ptr == from_end) {
	2448	/* Simple case: no character needs to be changed */
	2449	SvUTF8_on(sv);
	2450	return;
	2451	}
	2452
	2453	len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1;
	2454	Newx(to_start, len, char);
	2455	Copy(from_start, to_start, from_ptr-from_start, char);
	2456	to_ptr = to_start + (from_ptr-from_start);
	2457
	2458	Newx(marks, sym_ptr->level+2, const char *);
	2459	for (group=sym_ptr; group; group = group->previous)
	2460	marks[group->level] = from_start + group->strbeg;
	2461	marks[sym_ptr->level+1] = from_end+1;
	2462	for (m = marks; *m < from_ptr; m++)
	2463	m = to_start + (m-from_start);
	2464
	2465	for (;from_ptr < from_end; from_ptr++) {
	2466	while (m == from_ptr) m++ = to_ptr;
	2467	to_ptr = (char ) uvchr_to_utf8((U8 ) to_ptr, (U8 ) from_ptr);
	2468	}
	2469	*to_ptr = 0;
	2470
	2471	while (m == from_ptr) m++ = to_ptr;
	2472	if (m != marks + sym_ptr->level+1) {
	2473	Safefree(marks);
	2474	Safefree(to_start);
	2475	Perl_croak(aTHX_ "Assertion: marks beyond string end");
	2476	}
	2477	for (group=sym_ptr; group; group = group->previous)
	2478	group->strbeg = marks[group->level] - to_start;
	2479	Safefree(marks);
	2480
	2481	if (SvOOK(sv)) {
	2482	if (SvIVX(sv)) {
	2483	SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
	2484	from_start -= SvIVX(sv);
	2485	SvIV_set(sv, 0);
	2486	}
	2487	SvFLAGS(sv) &= ~SVf_OOK;
	2488	}
	2489	if (SvLEN(sv) != 0)
	2490	Safefree(from_start);
	2491	SvPV_set(sv, to_start);
	2492	SvCUR_set(sv, to_ptr - to_start);
	2493	SvLEN_set(sv, len);
	2494	SvUTF8_on(sv);
	2495	}
	2496
	2497	/* Exponential string grower. Makes string extension effectively O(n)
	2498	needed says how many extra bytes we need (not counting the final '\0')
	2499	Only grows the string if there is an actual lack of space
	2500	*/
	2501	STATIC char *
	2502	sv_exp_grow(pTHX_ SV *sv, STRLEN needed) {
	2503	const STRLEN cur = SvCUR(sv);
	2504	const STRLEN len = SvLEN(sv);
	2505	STRLEN extend;
	2506	if (len - cur > needed) return SvPVX(sv);
	2507	extend = needed > len ? needed : len;
	2508	return SvGROW(sv, len+extend+1);
	2509	}
	2510
	2511	STATIC
	2512	SV **
	2513	S_pack_rec(pTHX_ SV cat, tempsym_t symptr, SV beglist, SV endlist )
	2514	{
	2515	tempsym_t lookahead;
	2516	I32 items = endlist - beglist;
	2517	bool found = next_symbol(symptr);
	2518	bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0;
	2519	bool warn_utf8 = ckWARN(WARN_UTF8);
	2520
	2521	if (symptr->level == 0 && found && symptr->code == 'U') {
	2522	marked_upgrade(aTHX_ cat, symptr);
	2523	symptr->flags \|= FLAG_DO_UTF8;
	2524	utf8 = 0;
	2525	}
	2526	symptr->strbeg = SvCUR(cat);
	2527
	2528	while (found) {
	2529	SV *fromstr;
	2530	STRLEN fromlen;
	2531	I32 len;
	2532	SV *lengthcode = Nullsv;
	2533	I32 datumtype = symptr->code;
	2534	howlen_t howlen = symptr->howlen;
	2535	char *start = SvPVX(cat);
	2536	char *cur = start + SvCUR(cat);
	2537
	2538	#define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
	2539
	2540	switch (howlen) {
	2541	case e_star:
	2542	len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ?
	2543	0 : items;
	2544	break;
	2545	default:
	2546	/* e_no_len and e_number */
	2547	len = symptr->length;
	2548	break;
	2549	}
	2550
	2551	if (len) {
	2552	packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)];
	2553
	2554	if (props && !(props & PACK_SIZE_UNPREDICTABLE)) {
	2555	/* We can process this letter. */
	2556	STRLEN size = props & PACK_SIZE_MASK;
	2557	GROWING(utf8, cat, start, cur, (STRLEN) len * size);
	2558	}
	2559	}
	2560
	2561	/* Look ahead for next symbol. Do we have code/code? */
	2562	lookahead = *symptr;
	2563	found = next_symbol(&lookahead);
	2564	if (symptr->flags & FLAG_SLASH) {
	2565	IV count;
	2566	if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack");
	2567	if (strchr("aAZ", lookahead.code)) {
	2568	if (lookahead.howlen == e_number) count = lookahead.length;
	2569	else {
	2570	if (items > 0)
	2571	count = DO_UTF8(*beglist) ?
	2572	sv_len_utf8(beglist) : sv_len(beglist);
	2573	else count = 0;
	2574	if (lookahead.code == 'Z') count++;
	2575	}
	2576	} else {
	2577	if (lookahead.howlen == e_number && lookahead.length < items)
	2578	count = lookahead.length;
	2579	else count = items;
	2580	}
	2581	lookahead.howlen = e_number;
	2582	lookahead.length = count;
	2583	lengthcode = sv_2mortal(newSViv(count));
	2584	}
	2585
	2586	/* Code inside the switch must take care to properly update
	2587	cat (CUR length and '\0' termination) if it updated *cur and
	2588	doesn't simply leave using break */
	2589	switch(TYPE_NO_ENDIANNESS(datumtype)) {
	2590	default:
	2591	Perl_croak(aTHX_ "Invalid type '%c' in pack",
	2592	(int) TYPE_NO_MODIFIERS(datumtype));
	2593	case '%':
	2594	Perl_croak(aTHX_ "'%%' may not be used in pack");
	2595	{
	2596	char *from;
	2597	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	2598	case '.' \| TYPE_IS_SHRIEKING:
	2599	#endif
	2600	case '.':
	2601	if (howlen == e_star) from = start;
	2602	else if (len == 0) from = cur;
	2603	else {
	2604	tempsym_t *group = symptr;
	2605
	2606	while (--len && group) group = group->previous;
	2607	from = group ? start + group->strbeg : start;
	2608	}
	2609	fromstr = NEXTFROM;
	2610	len = SvIV(fromstr);
	2611	goto resize;
	2612	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	2613	case '@' \| TYPE_IS_SHRIEKING:
	2614	#endif
	2615	case '@':
	2616	from = start + symptr->strbeg;
	2617	resize:
	2618	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	2619	if (utf8 && !(datumtype & TYPE_IS_SHRIEKING))
	2620	#else /* PERL_PACK_CAN_SHRIEKSIGN */
	2621	if (utf8)
	2622	#endif
	2623	if (len >= 0) {
	2624	while (len && from < cur) {
	2625	from += UTF8SKIP(from);
	2626	len--;
	2627	}
	2628	if (from > cur)
	2629	Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
	2630	if (len) {
	2631	/* Here we know from == cur */
	2632	grow:
	2633	GROWING(0, cat, start, cur, len);
	2634	Zero(cur, len, char);
	2635	cur += len;
	2636	} else if (from < cur) {
	2637	len = cur - from;
	2638	goto shrink;
	2639	} else goto no_change;
	2640	} else {
	2641	cur = from;
	2642	len = -len;
	2643	goto utf8_shrink;
	2644	}
	2645	else {
	2646	len -= cur - from;
	2647	if (len > 0) goto grow;
	2648	if (len == 0) goto no_change;
	2649	len = -len;
	2650	goto shrink;
	2651	}
	2652	break;
	2653	}
	2654	case '(': {
	2655	tempsym_t savsym = *symptr;
	2656	U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
	2657	symptr->flags \|= group_modifiers;
	2658	symptr->patend = savsym.grpend;
	2659	symptr->level++;
	2660	symptr->previous = &lookahead;
	2661	while (len--) {
	2662	U32 was_utf8;
	2663	if (utf8) symptr->flags \|= FLAG_PARSE_UTF8;
	2664	else symptr->flags &= ~FLAG_PARSE_UTF8;
	2665	was_utf8 = SvUTF8(cat);
	2666	symptr->patptr = savsym.grpbeg;
	2667	beglist = pack_rec(cat, symptr, beglist, endlist);
	2668	if (SvUTF8(cat) != was_utf8)
	2669	/* This had better be an upgrade while in utf8==0 mode */
	2670	utf8 = 1;
	2671
	2672	if (savsym.howlen == e_star && beglist == endlist)
	2673	break; /* No way to continue */
	2674	}
	2675	lookahead.flags = symptr->flags & ~group_modifiers;
	2676	goto no_change;
	2677	}
	2678	case 'X' \| TYPE_IS_SHRIEKING:
	2679	if (!len) /* Avoid division by 0 */
	2680	len = 1;
	2681	if (utf8) {
	2682	char hop, last;
	2683	I32 l = len;
	2684	hop = last = start;
	2685	while (hop < cur) {
	2686	hop += UTF8SKIP(hop);
	2687	if (--l == 0) {
	2688	last = hop;
	2689	l = len;
	2690	}
	2691	}
	2692	if (last > cur)
	2693	Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
	2694	cur = last;
	2695	break;
	2696	}
	2697	len = (cur-start) % len;
	2698	/* FALL THROUGH */
	2699	case 'X':
	2700	if (utf8) {
	2701	if (len < 1) goto no_change;
	2702	utf8_shrink:
	2703	while (len > 0) {
	2704	if (cur <= start)
	2705	Perl_croak(aTHX_ "'%c' outside of string in pack",
	2706	(int) TYPE_NO_MODIFIERS(datumtype));
	2707	while (--cur, UTF8_IS_CONTINUATION(*cur)) {
	2708	if (cur <= start)
	2709	Perl_croak(aTHX_ "'%c' outside of string in pack",
	2710	(int) TYPE_NO_MODIFIERS(datumtype));
	2711	}
	2712	len--;
	2713	}
	2714	} else {
	2715	shrink:
	2716	if (cur - start < len)
	2717	Perl_croak(aTHX_ "'%c' outside of string in pack",
	2718	(int) TYPE_NO_MODIFIERS(datumtype));
	2719	cur -= len;
	2720	}
	2721	if (cur < start+symptr->strbeg) {
	2722	/* Make sure group starts don't point into the void */
	2723	tempsym_t *group;
	2724	const STRLEN length = cur-start;
	2725	for (group = symptr;
	2726	group && length < group->strbeg;
	2727	group = group->previous) group->strbeg = length;
	2728	lookahead.strbeg = length;
	2729	}
	2730	break;
	2731	case 'x' \| TYPE_IS_SHRIEKING: {
	2732	I32 ai32;
	2733	if (!len) /* Avoid division by 0 */
	2734	len = 1;
	2735	if (utf8) ai32 = utf8_length((U8 ) start, (U8 ) cur) % len;
	2736	else ai32 = (cur - start) % len;
	2737	if (ai32 == 0) goto no_change;
	2738	len -= ai32;
	2739	}
	2740	/* FALL THROUGH */
	2741	case 'x':
	2742	goto grow;
	2743	case 'A':
	2744	case 'Z':
	2745	case 'a': {
	2746	const char *aptr;
	2747
	2748	fromstr = NEXTFROM;
	2749	aptr = SvPV_const(fromstr, fromlen);
	2750	if (DO_UTF8(fromstr)) {
	2751	const char end, s;
	2752
	2753	if (!utf8 && !SvUTF8(cat)) {
	2754	marked_upgrade(aTHX_ cat, symptr);
	2755	lookahead.flags \|= FLAG_DO_UTF8;
	2756	lookahead.strbeg = symptr->strbeg;
	2757	utf8 = 1;
	2758	start = SvPVX(cat);
	2759	cur = start + SvCUR(cat);
	2760	}
	2761	if (howlen == e_star) {
	2762	if (utf8) goto string_copy;
	2763	len = fromlen+1;
	2764	}
	2765	s = aptr;
	2766	end = aptr + fromlen;
	2767	fromlen = datumtype == 'Z' ? len-1 : len;
	2768	while ((I32) fromlen > 0 && s < end) {
	2769	s += UTF8SKIP(s);
	2770	fromlen--;
	2771	}
	2772	if (s > end)
	2773	Perl_croak(aTHX_ "Malformed UTF-8 string in pack");
	2774	if (utf8) {
	2775	len = fromlen;
	2776	if (datumtype == 'Z') len++;
	2777	fromlen = s-aptr;
	2778	len += fromlen;
	2779
	2780	goto string_copy;
	2781	}
	2782	fromlen = len - fromlen;
	2783	if (datumtype == 'Z') fromlen--;
	2784	if (howlen == e_star) {
	2785	len = fromlen;
	2786	if (datumtype == 'Z') len++;
	2787	}
	2788	GROWING(0, cat, start, cur, len);
	2789	if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
	2790	datumtype \| TYPE_IS_PACK))
	2791	Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available");
	2792	cur += fromlen;
	2793	len -= fromlen;
	2794	} else if (utf8) {
	2795	if (howlen == e_star) {
	2796	len = fromlen;
	2797	if (datumtype == 'Z') len++;
	2798	}
	2799	if (len <= (I32) fromlen) {
	2800	fromlen = len;
	2801	if (datumtype == 'Z' && fromlen > 0) fromlen--;
	2802	}
	2803	/* assumes a byte expands to at most UTF8_EXPAND bytes on
	2804	upgrade, so:
	2805	expected_length <= from_lenUTF8_EXPAND + (len-from_len) /
	2806	GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len);
	2807	len -= fromlen;
	2808	while (fromlen > 0) {
	2809	cur = (char ) uvchr_to_utf8((U8 ) cur, * (U8 *) aptr);
	2810	aptr++;
	2811	fromlen--;
	2812	}
	2813	} else {
	2814	string_copy:
	2815	if (howlen == e_star) {
	2816	len = fromlen;
	2817	if (datumtype == 'Z') len++;
	2818	}
	2819	if (len <= (I32) fromlen) {
	2820	fromlen = len;
	2821	if (datumtype == 'Z' && fromlen > 0) fromlen--;
	2822	}
	2823	GROWING(0, cat, start, cur, len);
	2824	Copy(aptr, cur, fromlen, char);
	2825	cur += fromlen;
	2826	len -= fromlen;
	2827	}
	2828	memset(cur, datumtype == 'A' ? ' ' : '\0', len);
	2829	cur += len;
	2830	break;
	2831	}
	2832	case 'B':
	2833	case 'b': {
	2834	const char str, end;
	2835	I32 l, field_len;
	2836	U8 bits;
	2837	bool utf8_source;
	2838	U32 utf8_flags;
	2839
	2840	fromstr = NEXTFROM;
	2841	str = SvPV_const(fromstr, fromlen);
	2842	end = str + fromlen;
	2843	if (DO_UTF8(fromstr)) {
	2844	utf8_source = TRUE;
	2845	utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
	2846	} else {
	2847	utf8_source = FALSE;
	2848	utf8_flags = 0; /* Unused, but keep compilers happy */
	2849	}
	2850	if (howlen == e_star) len = fromlen;
	2851	field_len = (len+7)/8;
	2852	GROWING(utf8, cat, start, cur, field_len);
	2853	if (len > (I32)fromlen) len = fromlen;
	2854	bits = 0;
	2855	l = 0;
	2856	if (datumtype == 'B')
	2857	while (l++ < len) {
	2858	if (utf8_source) {
	2859	UV val;
	2860	NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
	2861	bits \|= val & 1;
	2862	} else bits \|= *str++ & 1;
	2863	if (l & 7) bits <<= 1;
	2864	else {
	2865	PUSH_BYTE(utf8, cur, bits);
	2866	bits = 0;
	2867	}
	2868	}
	2869	else
	2870	/* datumtype == 'b' */
	2871	while (l++ < len) {
	2872	if (utf8_source) {
	2873	UV val;
	2874	NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
	2875	if (val & 1) bits \|= 0x80;
	2876	} else if (*str++ & 1)
	2877	bits \|= 0x80;
	2878	if (l & 7) bits >>= 1;
	2879	else {
	2880	PUSH_BYTE(utf8, cur, bits);
	2881	bits = 0;
	2882	}
	2883	}
	2884	l--;
	2885	if (l & 7) {
	2886	if (datumtype == 'B')
	2887	bits <<= 7 - (l & 7);
	2888	else
	2889	bits >>= 7 - (l & 7);
	2890	PUSH_BYTE(utf8, cur, bits);
	2891	l += 7;
	2892	}
	2893	/* Determine how many chars are left in the requested field */
	2894	l /= 8;
	2895	if (howlen == e_star) field_len = 0;
	2896	else field_len -= l;
	2897	Zero(cur, field_len, char);
	2898	cur += field_len;
	2899	break;
	2900	}
	2901	case 'H':
	2902	case 'h': {
	2903	const char str, end;
	2904	I32 l, field_len;
	2905	U8 bits;
	2906	bool utf8_source;
	2907	U32 utf8_flags;
	2908
	2909	fromstr = NEXTFROM;
	2910	str = SvPV_const(fromstr, fromlen);
	2911	end = str + fromlen;
	2912	if (DO_UTF8(fromstr)) {
	2913	utf8_source = TRUE;
	2914	utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY;
	2915	} else {
	2916	utf8_source = FALSE;
	2917	utf8_flags = 0; /* Unused, but keep compilers happy */
	2918	}
	2919	if (howlen == e_star) len = fromlen;
	2920	field_len = (len+1)/2;
	2921	GROWING(utf8, cat, start, cur, field_len);
	2922	if (!utf8 && len > (I32)fromlen) len = fromlen;
	2923	bits = 0;
	2924	l = 0;
	2925	if (datumtype == 'H')
	2926	while (l++ < len) {
	2927	if (utf8_source) {
	2928	UV val;
	2929	NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
	2930	if (val < 256 && isALPHA(val))
	2931	bits \|= (val + 9) & 0xf;
	2932	else
	2933	bits \|= val & 0xf;
	2934	} else if (isALPHA(*str))
	2935	bits \|= (*str++ + 9) & 0xf;
	2936	else
	2937	bits \|= *str++ & 0xf;
	2938	if (l & 1) bits <<= 4;
	2939	else {
	2940	PUSH_BYTE(utf8, cur, bits);
	2941	bits = 0;
	2942	}
	2943	}
	2944	else
	2945	while (l++ < len) {
	2946	if (utf8_source) {
	2947	UV val;
	2948	NEXT_UNI_VAL(val, cur, str, end, utf8_flags);
	2949	if (val < 256 && isALPHA(val))
	2950	bits \|= ((val + 9) & 0xf) << 4;
	2951	else
	2952	bits \|= (val & 0xf) << 4;
	2953	} else if (isALPHA(*str))
	2954	bits \|= ((*str++ + 9) & 0xf) << 4;
	2955	else
	2956	bits \|= (*str++ & 0xf) << 4;
	2957	if (l & 1) bits >>= 4;
	2958	else {
	2959	PUSH_BYTE(utf8, cur, bits);
	2960	bits = 0;
	2961	}
	2962	}
	2963	l--;
	2964	if (l & 1) {
	2965	PUSH_BYTE(utf8, cur, bits);
	2966	l++;
	2967	}
	2968	/* Determine how many chars are left in the requested field */
	2969	l /= 2;
	2970	if (howlen == e_star) field_len = 0;
	2971	else field_len -= l;
	2972	Zero(cur, field_len, char);
	2973	cur += field_len;
	2974	break;
	2975	}
	2976	case 'c':
	2977	while (len-- > 0) {
	2978	IV aiv;
	2979	fromstr = NEXTFROM;
	2980	aiv = SvIV(fromstr);
	2981	if ((-128 > aiv \|\| aiv > 127) &&
	2982	ckWARN(WARN_PACK))
	2983	Perl_warner(aTHX_ packWARN(WARN_PACK),
	2984	"Character in 'c' format wrapped in pack");
	2985	PUSH_BYTE(utf8, cur, aiv & 0xff);
	2986	}
	2987	break;
	2988	case 'C':
	2989	if (len == 0) {
	2990	utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0;
	2991	break;
	2992	}
	2993	GROWING(0, cat, start, cur, len);
	2994	while (len-- > 0) {
	2995	IV aiv;
	2996	fromstr = NEXTFROM;
	2997	aiv = SvIV(fromstr);
	2998	if ((0 > aiv \|\| aiv > 0xff) &&
	2999	ckWARN(WARN_PACK))
	3000	Perl_warner(aTHX_ packWARN(WARN_PACK),
	3001	"Character in 'C' format wrapped in pack");
	3002	*cur++ = aiv & 0xff;
	3003	}
	3004	break;
	3005	case 'W': {
	3006	char *end;
	3007	U8 in_bytes = IN_BYTES;
	3008
	3009	end = start+SvLEN(cat)-1;
	3010	if (utf8) end -= UTF8_MAXLEN-1;
	3011	while (len-- > 0) {
	3012	UV auv;
	3013	fromstr = NEXTFROM;
	3014	auv = SvUV(fromstr);
	3015	if (in_bytes) auv = auv % 0x100;
	3016	if (utf8) {
	3017	W_utf8:
	3018	if (cur > end) {
	3019	*cur = '\0';
	3020	SvCUR_set(cat, cur - start);
	3021
	3022	GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
	3023	end = start+SvLEN(cat)-UTF8_MAXLEN;
	3024	}
	3025	cur = (char ) uvuni_to_utf8_flags((U8 ) cur,
	3026	NATIVE_TO_UNI(auv),
	3027	warn_utf8 ?
	3028	0 : UNICODE_ALLOW_ANY);
	3029	} else {
	3030	if (auv >= 0x100) {
	3031	if (!SvUTF8(cat)) {
	3032	*cur = '\0';
	3033	SvCUR_set(cat, cur - start);
	3034	marked_upgrade(aTHX_ cat, symptr);
	3035	lookahead.flags \|= FLAG_DO_UTF8;
	3036	lookahead.strbeg = symptr->strbeg;
	3037	utf8 = 1;
	3038	start = SvPVX(cat);
	3039	cur = start + SvCUR(cat);
	3040	end = start+SvLEN(cat)-UTF8_MAXLEN;
	3041	goto W_utf8;
	3042	}
	3043	if (ckWARN(WARN_PACK))
	3044	Perl_warner(aTHX_ packWARN(WARN_PACK),
	3045	"Character in 'W' format wrapped in pack");
	3046	auv &= 0xff;
	3047	}
	3048	if (cur >= end) {
	3049	*cur = '\0';
	3050	SvCUR_set(cat, cur - start);
	3051	GROWING(0, cat, start, cur, len+1);
	3052	end = start+SvLEN(cat)-1;
	3053	}
	3054	(U8 ) cur++ = (U8)auv;
	3055	}
	3056	}
	3057	break;
	3058	}
	3059	case 'U': {
	3060	char *end;
	3061
	3062	if (len == 0) {
	3063	if (!(symptr->flags & FLAG_DO_UTF8)) {
	3064	marked_upgrade(aTHX_ cat, symptr);
	3065	lookahead.flags \|= FLAG_DO_UTF8;
	3066	lookahead.strbeg = symptr->strbeg;
	3067	}
	3068	utf8 = 0;
	3069	goto no_change;
	3070	}
	3071
	3072	end = start+SvLEN(cat);
	3073	if (!utf8) end -= UTF8_MAXLEN;
	3074	while (len-- > 0) {
	3075	UV auv;
	3076	fromstr = NEXTFROM;
	3077	auv = SvUV(fromstr);
	3078	if (utf8) {
	3079	U8 buffer[UTF8_MAXLEN], *endb;
	3080	endb = uvuni_to_utf8_flags(buffer, auv,
	3081	warn_utf8 ?
	3082	0 : UNICODE_ALLOW_ANY);
	3083	if (cur+(endb-buffer)*UTF8_EXPAND >= end) {
	3084	*cur = '\0';
	3085	SvCUR_set(cat, cur - start);
	3086	GROWING(0, cat, start, cur,
	3087	len+(endb-buffer)*UTF8_EXPAND);
	3088	end = start+SvLEN(cat);
	3089	}
	3090	bytes_to_uni(aTHX_ buffer, endb-buffer, &cur);
	3091	} else {
	3092	if (cur >= end) {
	3093	*cur = '\0';
	3094	SvCUR_set(cat, cur - start);
	3095	GROWING(0, cat, start, cur, len+UTF8_MAXLEN);
	3096	end = start+SvLEN(cat)-UTF8_MAXLEN;
	3097	}
	3098	cur = (char ) uvuni_to_utf8_flags((U8 ) cur, auv,
	3099	warn_utf8 ?
	3100	0 : UNICODE_ALLOW_ANY);
	3101	}
	3102	}
	3103	break;
	3104	}
	3105	/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
	3106	case 'f':
	3107	while (len-- > 0) {
	3108	float afloat;
	3109	NV anv;
	3110	fromstr = NEXTFROM;
	3111	anv = SvNV(fromstr);
	3112	#ifdef __VOS__
	3113	/* VOS does not automatically map a floating-point overflow
	3114	during conversion from double to float into infinity, so we
	3115	do it by hand. This code should either be generalized for
	3116	any OS that needs it, or removed if and when VOS implements
	3117	posix-976 (suggestion to support mapping to infinity).
	3118	Paul.Green@stratus.com 02-04-02. */
	3119	if (anv > FLT_MAX)
	3120	afloat = _float_constants[0]; /* single prec. inf. */
	3121	else if (anv < -FLT_MAX)
	3122	afloat = _float_constants[0]; /* single prec. inf. */
	3123	else afloat = (float) anv;
	3124	#else /* __VOS__ */
	3125	# if defined(VMS) && !defined(__IEEE_FP)
	3126	/* IEEE fp overflow shenanigans are unavailable on VAX and optional
	3127	* on Alpha; fake it if we don't have them.
	3128	*/
	3129	if (anv > FLT_MAX)
	3130	afloat = FLT_MAX;
	3131	else if (anv < -FLT_MAX)
	3132	afloat = -FLT_MAX;
	3133	else afloat = (float)anv;
	3134	# else
	3135	afloat = (float)anv;
	3136	# endif
	3137	#endif /* __VOS__ */
	3138	DO_BO_PACK_N(afloat, float);
	3139	PUSH_VAR(utf8, cur, afloat);
	3140	}
	3141	break;
	3142	case 'd':
	3143	while (len-- > 0) {
	3144	double adouble;
	3145	NV anv;
	3146	fromstr = NEXTFROM;
	3147	anv = SvNV(fromstr);
	3148	#ifdef __VOS__
	3149	/* VOS does not automatically map a floating-point overflow
	3150	during conversion from long double to double into infinity,
	3151	so we do it by hand. This code should either be generalized
	3152	for any OS that needs it, or removed if and when VOS
	3153	implements posix-976 (suggestion to support mapping to
	3154	infinity). Paul.Green@stratus.com 02-04-02. */
	3155	if (anv > DBL_MAX)
	3156	adouble = _double_constants[0]; /* double prec. inf. */
	3157	else if (anv < -DBL_MAX)
	3158	adouble = _double_constants[0]; /* double prec. inf. */
	3159	else adouble = (double) anv;
	3160	#else /* __VOS__ */
	3161	# if defined(VMS) && !defined(__IEEE_FP)
	3162	/* IEEE fp overflow shenanigans are unavailable on VAX and optional
	3163	* on Alpha; fake it if we don't have them.
	3164	*/
	3165	if (anv > DBL_MAX)
	3166	adouble = DBL_MAX;
	3167	else if (anv < -DBL_MAX)
	3168	adouble = -DBL_MAX;
	3169	else adouble = (double)anv;
	3170	# else
	3171	adouble = (double)anv;
	3172	# endif
	3173	#endif /* __VOS__ */
	3174	DO_BO_PACK_N(adouble, double);
	3175	PUSH_VAR(utf8, cur, adouble);
	3176	}
	3177	break;
	3178	case 'F': {
	3179	NV anv;
	3180	Zero(&anv, 1, NV); /* can be long double with unused bits */
	3181	while (len-- > 0) {
	3182	fromstr = NEXTFROM;
	3183	anv = SvNV(fromstr);
	3184	DO_BO_PACK_N(anv, NV);
	3185	PUSH_VAR(utf8, cur, anv);
	3186	}
	3187	break;
	3188	}
	3189	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
	3190	case 'D': {
	3191	long double aldouble;
	3192	/* long doubles can have unused bits, which may be nonzero */
	3193	Zero(&aldouble, 1, long double);
	3194	while (len-- > 0) {
	3195	fromstr = NEXTFROM;
	3196	aldouble = (long double)SvNV(fromstr);
	3197	DO_BO_PACK_N(aldouble, long double);
	3198	PUSH_VAR(utf8, cur, aldouble);
	3199	}
	3200	break;
	3201	}
	3202	#endif
	3203	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	3204	case 'n' \| TYPE_IS_SHRIEKING:
	3205	#endif
	3206	case 'n':
	3207	while (len-- > 0) {
	3208	I16 ai16;
	3209	fromstr = NEXTFROM;
	3210	ai16 = (I16)SvIV(fromstr);
	3211	#ifdef HAS_HTONS
	3212	ai16 = PerlSock_htons(ai16);
	3213	#endif
	3214	PUSH16(utf8, cur, &ai16);
	3215	}
	3216	break;
	3217	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	3218	case 'v' \| TYPE_IS_SHRIEKING:
	3219	#endif
	3220	case 'v':
	3221	while (len-- > 0) {
	3222	I16 ai16;
	3223	fromstr = NEXTFROM;
	3224	ai16 = (I16)SvIV(fromstr);
	3225	#ifdef HAS_HTOVS
	3226	ai16 = htovs(ai16);
	3227	#endif
	3228	PUSH16(utf8, cur, &ai16);
	3229	}
	3230	break;
	3231	case 'S' \| TYPE_IS_SHRIEKING:
	3232	#if SHORTSIZE != SIZE16
	3233	while (len-- > 0) {
	3234	unsigned short aushort;
	3235	fromstr = NEXTFROM;
	3236	aushort = SvUV(fromstr);
	3237	DO_BO_PACK(aushort, s);
	3238	PUSH_VAR(utf8, cur, aushort);
	3239	}
	3240	break;
	3241	#else
	3242	/* Fall through! */
	3243	#endif
	3244	case 'S':
	3245	while (len-- > 0) {
	3246	U16 au16;
	3247	fromstr = NEXTFROM;
	3248	au16 = (U16)SvUV(fromstr);
	3249	DO_BO_PACK(au16, 16);
	3250	PUSH16(utf8, cur, &au16);
	3251	}
	3252	break;
	3253	case 's' \| TYPE_IS_SHRIEKING:
	3254	#if SHORTSIZE != SIZE16
	3255	while (len-- > 0) {
	3256	short ashort;
	3257	fromstr = NEXTFROM;
	3258	ashort = SvIV(fromstr);
	3259	DO_BO_PACK(ashort, s);
	3260	PUSH_VAR(utf8, cur, ashort);
	3261	}
	3262	break;
	3263	#else
	3264	/* Fall through! */
	3265	#endif
	3266	case 's':
	3267	while (len-- > 0) {
	3268	I16 ai16;
	3269	fromstr = NEXTFROM;
	3270	ai16 = (I16)SvIV(fromstr);
	3271	DO_BO_PACK(ai16, 16);
	3272	PUSH16(utf8, cur, &ai16);
	3273	}
	3274	break;
	3275	case 'I':
	3276	case 'I' \| TYPE_IS_SHRIEKING:
	3277	while (len-- > 0) {
	3278	unsigned int auint;
	3279	fromstr = NEXTFROM;
	3280	auint = SvUV(fromstr);
	3281	DO_BO_PACK(auint, i);
	3282	PUSH_VAR(utf8, cur, auint);
	3283	}
	3284	break;
	3285	case 'j':
	3286	while (len-- > 0) {
	3287	IV aiv;
	3288	fromstr = NEXTFROM;
	3289	aiv = SvIV(fromstr);
	3290	#if IVSIZE == INTSIZE
	3291	DO_BO_PACK(aiv, i);
	3292	#elif IVSIZE == LONGSIZE
	3293	DO_BO_PACK(aiv, l);
	3294	#elif defined(HAS_QUAD) && IVSIZE == U64SIZE
	3295	DO_BO_PACK(aiv, 64);
	3296	#else
	3297	Perl_croak(aTHX_ "'j' not supported on this platform");
	3298	#endif
	3299	PUSH_VAR(utf8, cur, aiv);
	3300	}
	3301	break;
	3302	case 'J':
	3303	while (len-- > 0) {
	3304	UV auv;
	3305	fromstr = NEXTFROM;
	3306	auv = SvUV(fromstr);
	3307	#if UVSIZE == INTSIZE
	3308	DO_BO_PACK(auv, i);
	3309	#elif UVSIZE == LONGSIZE
	3310	DO_BO_PACK(auv, l);
	3311	#elif defined(HAS_QUAD) && UVSIZE == U64SIZE
	3312	DO_BO_PACK(auv, 64);
	3313	#else
	3314	Perl_croak(aTHX_ "'J' not supported on this platform");
	3315	#endif
	3316	PUSH_VAR(utf8, cur, auv);
	3317	}
	3318	break;
	3319	case 'w':
	3320	while (len-- > 0) {
	3321	NV anv;
	3322	fromstr = NEXTFROM;
	3323	anv = SvNV(fromstr);
	3324
	3325	if (anv < 0) {
	3326	*cur = '\0';
	3327	SvCUR_set(cat, cur - start);
	3328	Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
	3329	}
	3330
	3331	/* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
	3332	which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
	3333	any negative IVs will have already been got by the croak()
	3334	above. IOK is untrue for fractions, so we test them
	3335	against UV_MAX_P1. */
	3336	if (SvIOK(fromstr) \|\| anv < UV_MAX_P1) {
	3337	char buf[(sizeof(UV)*CHAR_BIT)/7+1];
	3338	char *in = buf + sizeof(buf);
	3339	UV auv = SvUV(fromstr);
	3340
	3341	do {
	3342	*--in = (char)((auv & 0x7f) \| 0x80);
	3343	auv >>= 7;
	3344	} while (auv);
	3345	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
	3346	PUSH_GROWING_BYTES(utf8, cat, start, cur,
	3347	in, (buf + sizeof(buf)) - in);
	3348	} else if (SvPOKp(fromstr))
	3349	goto w_string;
	3350	else if (SvNOKp(fromstr)) {
	3351	/* 10**NV_MAX_10_EXP is the largest power of 10
	3352	so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
	3353	given 10(NV_MAX_10_EXP+1) == 128 x solve for x:
	3354	x = (NV_MAX_10_EXP+1) * log (10) / log (128)
	3355	And with that many bytes only Inf can overflow.
	3356	Some C compilers are strict about integral constant
	3357	expressions so we conservatively divide by a slightly
	3358	smaller integer instead of multiplying by the exact
	3359	floating-point value.
	3360	*/
	3361	#ifdef NV_MAX_10_EXP
	3362	/* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
	3363	char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
	3364	#else
	3365	/* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
	3366	char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
	3367	#endif
	3368	char *in = buf + sizeof(buf);
	3369
	3370	anv = Perl_floor(anv);
	3371	do {
	3372	const NV next = Perl_floor(anv / 128);
	3373	if (in <= buf) /* this cannot happen ;-) */
	3374	Perl_croak(aTHX_ "Cannot compress integer in pack");
	3375	--in = (unsigned char)(anv - (next 128)) \| 0x80;
	3376	anv = next;
	3377	} while (anv > 0);
	3378	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
	3379	PUSH_GROWING_BYTES(utf8, cat, start, cur,
	3380	in, (buf + sizeof(buf)) - in);
	3381	} else {
	3382	const char *from;
	3383	char result, in;
	3384	SV *norm;
	3385	STRLEN len;
	3386	bool done;
	3387
	3388	w_string:
	3389	/* Copy string and check for compliance */
	3390	from = SvPV_const(fromstr, len);
	3391	if ((norm = is_an_int(from, len)) == NULL)
	3392	Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
	3393
	3394	Newx(result, len, char);
	3395	in = result + len;
	3396	done = FALSE;
	3397	while (!done) *--in = div128(norm, &done) \| 0x80;
	3398	result[len - 1] &= 0x7F; /* clear continue bit */
	3399	PUSH_GROWING_BYTES(utf8, cat, start, cur,
	3400	in, (result + len) - in);
	3401	Safefree(result);
	3402	SvREFCNT_dec(norm); /* free norm */
	3403	}
	3404	}
	3405	break;
	3406	case 'i':
	3407	case 'i' \| TYPE_IS_SHRIEKING:
	3408	while (len-- > 0) {
	3409	int aint;
	3410	fromstr = NEXTFROM;
	3411	aint = SvIV(fromstr);
	3412	DO_BO_PACK(aint, i);
	3413	PUSH_VAR(utf8, cur, aint);
	3414	}
	3415	break;
	3416	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	3417	case 'N' \| TYPE_IS_SHRIEKING:
	3418	#endif
	3419	case 'N':
	3420	while (len-- > 0) {
	3421	U32 au32;
	3422	fromstr = NEXTFROM;
	3423	au32 = SvUV(fromstr);
	3424	#ifdef HAS_HTONL
	3425	au32 = PerlSock_htonl(au32);
	3426	#endif
	3427	PUSH32(utf8, cur, &au32);
	3428	}
	3429	break;
	3430	#ifdef PERL_PACK_CAN_SHRIEKSIGN
	3431	case 'V' \| TYPE_IS_SHRIEKING:
	3432	#endif
	3433	case 'V':
	3434	while (len-- > 0) {
	3435	U32 au32;
	3436	fromstr = NEXTFROM;
	3437	au32 = SvUV(fromstr);
	3438	#ifdef HAS_HTOVL
	3439	au32 = htovl(au32);
	3440	#endif
	3441	PUSH32(utf8, cur, &au32);
	3442	}
	3443	break;
	3444	case 'L' \| TYPE_IS_SHRIEKING:
	3445	#if LONGSIZE != SIZE32
	3446	while (len-- > 0) {
	3447	unsigned long aulong;
	3448	fromstr = NEXTFROM;
	3449	aulong = SvUV(fromstr);
	3450	DO_BO_PACK(aulong, l);
	3451	PUSH_VAR(utf8, cur, aulong);
	3452	}
	3453	break;
	3454	#else
	3455	/* Fall though! */
	3456	#endif
	3457	case 'L':
	3458	while (len-- > 0) {
	3459	U32 au32;
	3460	fromstr = NEXTFROM;
	3461	au32 = SvUV(fromstr);
	3462	DO_BO_PACK(au32, 32);
	3463	PUSH32(utf8, cur, &au32);
	3464	}
	3465	break;
	3466	case 'l' \| TYPE_IS_SHRIEKING:
	3467	#if LONGSIZE != SIZE32
	3468	while (len-- > 0) {
	3469	long along;
	3470	fromstr = NEXTFROM;
	3471	along = SvIV(fromstr);
	3472	DO_BO_PACK(along, l);
	3473	PUSH_VAR(utf8, cur, along);
	3474	}
	3475	break;
	3476	#else
	3477	/* Fall though! */
	3478	#endif
	3479	case 'l':
	3480	while (len-- > 0) {
	3481	I32 ai32;
	3482	fromstr = NEXTFROM;
	3483	ai32 = SvIV(fromstr);
	3484	DO_BO_PACK(ai32, 32);
	3485	PUSH32(utf8, cur, &ai32);
	3486	}
	3487	break;
	3488	#ifdef HAS_QUAD
	3489	case 'Q':
	3490	while (len-- > 0) {
	3491	Uquad_t auquad;
	3492	fromstr = NEXTFROM;
	3493	auquad = (Uquad_t) SvUV(fromstr);
	3494	DO_BO_PACK(auquad, 64);
	3495	PUSH_VAR(utf8, cur, auquad);
	3496	}
	3497	break;
	3498	case 'q':
	3499	while (len-- > 0) {
	3500	Quad_t aquad;
	3501	fromstr = NEXTFROM;
	3502	aquad = (Quad_t)SvIV(fromstr);
	3503	DO_BO_PACK(aquad, 64);
	3504	PUSH_VAR(utf8, cur, aquad);
	3505	}
	3506	break;
	3507	#endif /* HAS_QUAD */
	3508	case 'P':
	3509	len = 1; /* assume SV is correct length */
	3510	GROWING(utf8, cat, start, cur, sizeof(char *));
	3511	/* Fall through! */
	3512	case 'p':
	3513	while (len-- > 0) {
	3514	const char *aptr;
	3515
	3516	fromstr = NEXTFROM;
	3517	SvGETMAGIC(fromstr);
	3518	if (!SvOK(fromstr)) aptr = NULL;
	3519	else {
	3520	STRLEN n_a;
	3521	/* XXX better yet, could spirit away the string to
	3522	* a safe spot and hang on to it until the result
	3523	* of pack() (and all copies of the result) are
	3524	* gone.
	3525	*/
	3526	if ((SvTEMP(fromstr) \|\| (SvPADTMP(fromstr) &&
	3527	!SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) {
	3528	Perl_warner(aTHX_ packWARN(WARN_PACK),
	3529	"Attempt to pack pointer to temporary value");
	3530	}
	3531	if (SvPOK(fromstr) \|\| SvNIOK(fromstr))
	3532	aptr = SvPV_nomg_const(fromstr, n_a);
	3533	else
	3534	aptr = SvPV_force_flags(fromstr, n_a, 0);
	3535	}
	3536	DO_BO_PACK_PC(aptr);
	3537	PUSH_VAR(utf8, cur, aptr);
	3538	}
	3539	break;
	3540	case 'u': {
	3541	const char aptr, aend;
	3542	bool from_utf8;
	3543
	3544	fromstr = NEXTFROM;
	3545	if (len <= 2) len = 45;
	3546	else len = len / 3 * 3;
	3547	if (len >= 64) {
	3548	Perl_warner(aTHX_ packWARN(WARN_PACK),
	3549	"Field too wide in 'u' format in pack");
	3550	len = 63;
	3551	}
	3552	aptr = SvPV_const(fromstr, fromlen);
	3553	from_utf8 = DO_UTF8(fromstr);
	3554	if (from_utf8) {
	3555	aend = aptr + fromlen;
	3556	fromlen = sv_len_utf8(fromstr);
	3557	} else aend = NULL; /* Unused, but keep compilers happy */
	3558	GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2);
	3559	while (fromlen > 0) {
	3560	U8 *end;
	3561	I32 todo;
	3562	U8 hunk[1+63/3*4+1];
	3563
	3564	if ((I32)fromlen > len)
	3565	todo = len;
	3566	else
	3567	todo = fromlen;
	3568	if (from_utf8) {
	3569	char buffer[64];
	3570	if (!uni_to_bytes(aTHX_ &aptr, aend, buffer, todo,
	3571	'u' \| TYPE_IS_PACK)) {
	3572	*cur = '\0';
	3573	SvCUR_set(cat, cur - start);
	3574	Perl_croak(aTHX_ "Assertion: string is shorter than advertised");
	3575	}
	3576	end = doencodes(hunk, buffer, todo);
	3577	} else {
	3578	end = doencodes(hunk, aptr, todo);
	3579	aptr += todo;
	3580	}
	3581	PUSH_BYTES(utf8, cur, hunk, end-hunk);
	3582	fromlen -= todo;
	3583	}
	3584	break;
	3585	}
	3586	}
	3587	*cur = '\0';
	3588	SvCUR_set(cat, cur - start);
	3589	no_change:
	3590	*symptr = lookahead;
	3591	}
	3592	return beglist;
	3593	}
	3594	#undef NEXTFROM
	3595
	3596
	3597	PP(pp_pack)
	3598	{
	3599	dSP; dMARK; dORIGMARK; dTARGET;
	3600	register SV *cat = TARG;
	3601	STRLEN fromlen;
	3602	SV pat_sv = ++MARK;
	3603	register const char *pat = SvPV_const(pat_sv, fromlen);
	3604	register const char *patend = pat + fromlen;
	3605
	3606	MARK++;
	3607	sv_setpvn(cat, "", 0);
	3608	SvUTF8_off(cat);
	3609
	3610	packlist(cat, pat, patend, MARK, SP + 1);
	3611
	3612	SvSETMAGIC(cat);
	3613	SP = ORIGMARK;
	3614	PUSHs(cat);
	3615	RETURN;
	3616	}
	3617
	3618	/*
	3619	* Local variables:
	3620	* c-indentation-style: bsd
	3621	* c-basic-offset: 4
	3622	* indent-tabs-mode: t
	3623	* End:
	3624	*
	3625	* ex: set ts=8 sts=4 sw=4 noet:
	3626	*/