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