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