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

... / ...

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