Context Navigation

pp_pack.c @ 20075

Visit:

Revision 20075, 62.6 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.

Line
1	/* pp_pack.c
2	*
3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4	* 2000, 2001, 2002, 2003, 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	#include "EXTERN.h"
20	#define PERL_IN_PP_PACK_C
21	#include "perl.h"
22
23	/*
24	* The compiler on Concurrent CX/UX systems has a subtle bug which only
25	* seems to show up when compiling pp.c - it generates the wrong double
26	* precision constant value for (double)UV_MAX when used inline in the body
27	* of the code below, so this makes a static variable up front (which the
28	* compiler seems to get correct) and uses it in place of UV_MAX below.
29	*/
30	#ifdef CXUX_BROKEN_CONSTANT_CONVERT
31	static double UV_MAX_cxux = ((double)UV_MAX);
32	#endif
33
34	/*
35	* Offset for integer pack/unpack.
36	*
37	* On architectures where I16 and I32 aren't really 16 and 32 bits,
38	* which for now are all Crays, pack and unpack have to play games.
39	*/
40
41	/*
42	* These values are required for portability of pack() output.
43	* If they're not right on your machine, then pack() and unpack()
44	* wouldn't work right anyway; you'll need to apply the Cray hack.
45	* (I'd like to check them with #if, but you can't use sizeof() in
46	* the preprocessor.) --???
47	*/
48	/*
49	The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
50	defines are now in config.h. --Andy Dougherty April 1998
51	*/
52	#define SIZE16 2
53	#define SIZE32 4
54
55	/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
56	--jhi Feb 1999 */
57
58	#if SHORTSIZE != SIZE16 \|\| LONGSIZE != SIZE32
59	# define PERL_NATINT_PACK
60	#endif
61
62	#if LONGSIZE > 4 && defined(_CRAY)
63	# if BYTEORDER == 0x12345678
64	# define OFF16(p) (char*)(p)
65	# define OFF32(p) (char*)(p)
66	# else
67	# if BYTEORDER == 0x87654321
68	# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
69	# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
70	# else
71	}}}} bad cray byte order
72	# endif
73	# endif
74	# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
75	# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
76	# define COPYNN(s,p,n) ((p) = 0, Copy(s, (char )(p), n, char))
77	# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
78	# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
79	#else
80	# define COPY16(s,p) Copy(s, p, SIZE16, char)
81	# define COPY32(s,p) Copy(s, p, SIZE32, char)
82	# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
83	# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
84	# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
85	#endif
86
87	/* Avoid stack overflow due to pathological templates. 100 should be plenty. */
88	#define MAX_SUB_TEMPLATE_LEVEL 100
89
90	/* flags */
91	#define FLAG_UNPACK_ONLY_ONE 0x10
92	#define FLAG_UNPACK_DO_UTF8 0x08
93	#define FLAG_SLASH 0x04
94	#define FLAG_COMMA 0x02
95	#define FLAG_PACK 0x01
96
97	STATIC SV *
98	S_mul128(pTHX_ SV *sv, U8 m)
99	{
100	STRLEN len;
101	char *s = SvPV(sv, len);
102	char *t;
103	U32 i = 0;
104
105	if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
106	SV *tmpNew = newSVpvn("0000000000", 10);
107
108	sv_catsv(tmpNew, sv);
109	SvREFCNT_dec(sv); /* free old sv */
110	sv = tmpNew;
111	s = SvPV(sv, len);
112	}
113	t = s + len - 1;
114	while (!t) / trailing '\0'? */
115	t--;
116	while (t > s) {
117	i = ((*t - '0') << 7) + m;
118	*(t--) = '0' + (char)(i % 10);
119	m = (char)(i / 10);
120	}
121	return (sv);
122	}
123
124	/* Explosives and implosives. */
125
126	#if 'I' == 73 && 'J' == 74
127	/* On an ASCII/ISO kind of system */
128	#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
129	#else
130	/*
131	Some other sort of character set - use memchr() so we don't match
132	the null byte.
133	*/
134	#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) \|\| (ch) == ' ')
135	#endif
136
137	#define TYPE_IS_SHRIEKING 0x100
138
139	/* Returns the sizeof() struct described by pat */
140	STATIC I32
141	S_measure_struct(pTHX_ register tempsym_t* symptr)
142	{
143	register I32 len = 0;
144	register I32 total = 0;
145	int star;
146
147	register int size;
148
149	while (next_symbol(symptr)) {
150
151	switch( symptr->howlen ){
152	case e_no_len:
153	case e_number:
154	len = symptr->length;
155	break;
156	case e_star:
157	Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
158	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
159	break;
160	}
161
162	switch(symptr->code) {
163	default:
164	Perl_croak(aTHX_ "Invalid type '%c' in %s",
165	(int)symptr->code,
166	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
167	case '@':
168	case '/':
169	case 'U': /* XXXX Is it correct? */
170	case 'w':
171	case 'u':
172	Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
173	(int)symptr->code,
174	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
175	case '%':
176	size = 0;
177	break;
178	case '(':
179	{
180	tempsym_t savsym = *symptr;
181	symptr->patptr = savsym.grpbeg;
182	symptr->patend = savsym.grpend;
183	/* XXXX Theoretically, we need to measure many times at different
184	positions, since the subexpression may contain
185	alignment commands, but be not of aligned length.
186	Need to detect this and croak(). */
187	size = measure_struct(symptr);
188	*symptr = savsym;
189	break;
190	}
191	case 'X' \| TYPE_IS_SHRIEKING:
192	/* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
193	if (!len) /* Avoid division by 0 */
194	len = 1;
195	len = total % len; /* Assumed: the start is aligned. */
196	/* FALL THROUGH */
197	case 'X':
198	size = -1;
199	if (total < len)
200	Perl_croak(aTHX_ "'X' outside of string in %s",
201	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
202	break;
203	case 'x' \| TYPE_IS_SHRIEKING:
204	if (!len) /* Avoid division by 0 */
205	len = 1;
206	star = total % len; /* Assumed: the start is aligned. */
207	if (star) /* Other portable ways? */
208	len = len - star;
209	else
210	len = 0;
211	/* FALL THROUGH */
212	case 'x':
213	case 'A':
214	case 'Z':
215	case 'a':
216	case 'c':
217	case 'C':
218	size = 1;
219	break;
220	case 'B':
221	case 'b':
222	len = (len + 7)/8;
223	size = 1;
224	break;
225	case 'H':
226	case 'h':
227	len = (len + 1)/2;
228	size = 1;
229	break;
230	case 's' \| TYPE_IS_SHRIEKING:
231	#if SHORTSIZE != SIZE16
232	size = sizeof(short);
233	break;
234	#else
235	/* FALL THROUGH */
236	#endif
237	case 's':
238	size = SIZE16;
239	break;
240	case 'S' \| TYPE_IS_SHRIEKING:
241	#if SHORTSIZE != SIZE16
242	size = sizeof(unsigned short);
243	break;
244	#else
245	/* FALL THROUGH */
246	#endif
247	case 'v':
248	case 'n':
249	case 'S':
250	size = SIZE16;
251	break;
252	case 'i' \| TYPE_IS_SHRIEKING:
253	case 'i':
254	size = sizeof(int);
255	break;
256	case 'I' \| TYPE_IS_SHRIEKING:
257	case 'I':
258	size = sizeof(unsigned int);
259	break;
260	case 'j':
261	size = IVSIZE;
262	break;
263	case 'J':
264	size = UVSIZE;
265	break;
266	case 'l' \| TYPE_IS_SHRIEKING:
267	#if LONGSIZE != SIZE32
268	size = sizeof(long);
269	break;
270	#else
271	/* FALL THROUGH */
272	#endif
273	case 'l':
274	size = SIZE32;
275	break;
276	case 'L' \| TYPE_IS_SHRIEKING:
277	#if LONGSIZE != SIZE32
278	size = sizeof(unsigned long);
279	break;
280	#else
281	/* FALL THROUGH */
282	#endif
283	case 'V':
284	case 'N':
285	case 'L':
286	size = SIZE32;
287	break;
288	case 'P':
289	len = 1;
290	/* FALL THROUGH */
291	case 'p':
292	size = sizeof(char*);
293	break;
294	#ifdef HAS_QUAD
295	case 'q':
296	size = sizeof(Quad_t);
297	break;
298	case 'Q':
299	size = sizeof(Uquad_t);
300	break;
301	#endif
302	case 'f':
303	size = sizeof(float);
304	break;
305	case 'd':
306	size = sizeof(double);
307	break;
308	case 'F':
309	size = NVSIZE;
310	break;
311	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
312	case 'D':
313	size = LONG_DOUBLESIZE;
314	break;
315	#endif
316	}
317	total += len * size;
318	}
319	return total;
320	}
321
322
323	/* locate matching closing parenthesis or bracket
324	* returns char pointer to char after match, or NULL
325	*/
326	STATIC char *
327	S_group_end(pTHX_ register char patptr, register char patend, char ender)
328	{
329	while (patptr < patend) {
330	char c = *patptr++;
331
332	if (isSPACE(c))
333	continue;
334	else if (c == ender)
335	return patptr-1;
336	else if (c == '#') {
337	while (patptr < patend && *patptr != '\n')
338	patptr++;
339	continue;
340	} else if (c == '(')
341	patptr = group_end(patptr, patend, ')') + 1;
342	else if (c == '[')
343	patptr = group_end(patptr, patend, ']') + 1;
344	}
345	Perl_croak(aTHX_ "No group ending character '%c' found in template",
346	ender);
347	return 0;
348	}
349
350
351	/* Convert unsigned decimal number to binary.
352	* Expects a pointer to the first digit and address of length variable
353	* Advances char pointer to 1st non-digit char and returns number
354	*/
355	STATIC char *
356	S_get_num(pTHX_ register char patptr, I32 lenptr )
357	{
358	I32 len = *patptr++ - '0';
359	while (isDIGIT(*patptr)) {
360	if (len >= 0x7FFFFFFF/10)
361	Perl_croak(aTHX_ "pack/unpack repeat count overflow");
362	len = (len * 10) + (*patptr++ - '0');
363	}
364	*lenptr = len;
365	return patptr;
366	}
367
368	/* The marvellous template parsing routine: Using state stored in *symptr,
369	* locates next template code and count
370	*/
371	STATIC bool
372	S_next_symbol(pTHX_ register tempsym_t* symptr )
373	{
374	register char* patptr = symptr->patptr;
375	register char* patend = symptr->patend;
376
377	symptr->flags &= ~FLAG_SLASH;
378
379	while (patptr < patend) {
380	if (isSPACE(*patptr))
381	patptr++;
382	else if (*patptr == '#') {
383	patptr++;
384	while (patptr < patend && *patptr != '\n')
385	patptr++;
386	if (patptr < patend)
387	patptr++;
388	} else {
389	/* We should have found a template code */
390	I32 code = *patptr++ & 0xFF;
391
392	if (code == ','){ /* grandfather in commas but with a warning */
393	if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
394	symptr->flags \|= FLAG_COMMA;
395	Perl_warner(aTHX_ packWARN(WARN_UNPACK),
396	"Invalid type ',' in %s",
397	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
398	}
399	continue;
400	}
401
402	/* for '(', skip to ')' */
403	if (code == '(') {
404	if( isDIGIT(patptr) \|\| patptr == '' \|\| patptr == '[' )
405	Perl_croak(aTHX_ "()-group starts with a count in %s",
406	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
407	symptr->grpbeg = patptr;
408	patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
409	if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
410	Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
411	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
412	}
413
414	/* test for '!' modifier */
415	if (patptr < patend && *patptr == '!') {
416	static const char natstr[] = "sSiIlLxX";
417	patptr++;
418	if (strchr(natstr, code))
419	code \|= TYPE_IS_SHRIEKING;
420	else
421	Perl_croak(aTHX_ "'!' allowed only after types %s in %s",
422	natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
423	}
424
425	/* look for count and/or / */
426	if (patptr < patend) {
427	if (isDIGIT(*patptr)) {
428	patptr = get_num( patptr, &symptr->length );
429	symptr->howlen = e_number;
430
431	} else if (patptr == '') {
432	patptr++;
433	symptr->howlen = e_star;
434
435	} else if (*patptr == '[') {
436	char* lenptr = ++patptr;
437	symptr->howlen = e_number;
438	patptr = group_end( patptr, patend, ']' ) + 1;
439	/* what kind of [] is it? */
440	if (isDIGIT(*lenptr)) {
441	lenptr = get_num( lenptr, &symptr->length );
442	if( *lenptr != ']' )
443	Perl_croak(aTHX_ "Malformed integer in [] in %s",
444	symptr->flags & FLAG_PACK ? "pack" : "unpack");
445	} else {
446	tempsym_t savsym = *symptr;
447	symptr->patend = patptr-1;
448	symptr->patptr = lenptr;
449	savsym.length = measure_struct(symptr);
450	*symptr = savsym;
451	}
452	} else {
453	symptr->howlen = e_no_len;
454	symptr->length = 1;
455	}
456
457	/* try to find / */
458	while (patptr < patend) {
459	if (isSPACE(*patptr))
460	patptr++;
461	else if (*patptr == '#') {
462	patptr++;
463	while (patptr < patend && *patptr != '\n')
464	patptr++;
465	if (patptr < patend)
466	patptr++;
467	} else {
468	if( *patptr == '/' ){
469	symptr->flags \|= FLAG_SLASH;
470	patptr++;
471	if( patptr < patend &&
472	(isDIGIT(patptr) \|\| patptr == '' \|\| patptr == '[') )
473	Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
474	symptr->flags & FLAG_PACK ? "pack" : "unpack" );
475	}
476	break;
477	}
478	}
479	} else {
480	/* at end - no count, no / */
481	symptr->howlen = e_no_len;
482	symptr->length = 1;
483	}
484
485	symptr->code = code;
486	symptr->patptr = patptr;
487	return TRUE;
488	}
489	}
490	symptr->patptr = patptr;
491	return FALSE;
492	}
493
494	/*
495	=for apidoc unpack_str
496
497	The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
498	and ocnt are not used. This call should not be used, use unpackstring instead.
499
500	=cut */
501
502	I32
503	Perl_unpack_str(pTHX_ char pat, register char patend, register char s, char strbeg, char strend, char *new_s, I32 ocnt, U32 flags)
504	{
505	tempsym_t sym = { 0 };
506	sym.patptr = pat;
507	sym.patend = patend;
508	sym.flags = flags;
509
510	return unpack_rec(&sym, s, s, strend, NULL );
511	}
512
513	/*
514	=for apidoc unpackstring
515
516	The engine implementing unpack() Perl function. C<unpackstring> puts the
517	extracted list items on the stack and returns the number of elements.
518	Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
519
520	=cut */
521
522	I32
523	Perl_unpackstring(pTHX_ char pat, register char patend, register char s, char strend, U32 flags)
524	{
525	tempsym_t sym = { 0 };
526	sym.patptr = pat;
527	sym.patend = patend;
528	sym.flags = flags;
529
530	return unpack_rec(&sym, s, s, strend, NULL );
531	}
532
533	STATIC
534	I32
535	S_unpack_rec(pTHX_ register tempsym_t* symptr, register char s, char strbeg, char strend, char *new_s )
536	{
537	dSP;
538	I32 datumtype;
539	register I32 len = 0;
540	register I32 bits = 0;
541	register char *str;
542	SV *sv;
543	I32 start_sp_offset = SP - PL_stack_base;
544	howlen_t howlen;
545
546	/* These must not be in registers: */
547	short ashort;
548	int aint;
549	long along;
550	#ifdef HAS_QUAD
551	Quad_t aquad;
552	#endif
553	U16 aushort;
554	unsigned int auint;
555	U32 aulong;
556	#ifdef HAS_QUAD
557	Uquad_t auquad;
558	#endif
559	char *aptr;
560	float afloat;
561	double adouble;
562	I32 checksum = 0;
563	UV cuv = 0;
564	NV cdouble = 0.0;
565	const int bits_in_uv = 8 * sizeof(cuv);
566	char* strrelbeg = s;
567	bool beyond = FALSE;
568	bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
569
570	IV aiv;
571	UV auv;
572	NV anv;
573	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
574	long double aldouble;
575	#endif
576
577	while (next_symbol(symptr)) {
578	datumtype = symptr->code;
579	/* do first one only unless in list context
580	/ is implemented by unpacking the count, then poping it from the
581	stack, so must check that we're not in the middle of a / */
582	if ( unpack_only_one
583	&& (SP - PL_stack_base == start_sp_offset + 1)
584	&& (datumtype != '/') ) /* XXX can this be omitted */
585	break;
586
587	switch( howlen = symptr->howlen ){
588	case e_no_len:
589	case e_number:
590	len = symptr->length;
591	break;
592	case e_star:
593	len = strend - strbeg; /* long enough */
594	break;
595	}
596
597	redo_switch:
598	beyond = s >= strend;
599	switch(datumtype) {
600	default:
601	Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype );
602
603	case '%':
604	if (howlen == e_no_len)
605	len = 16; /* len is not specified */
606	checksum = len;
607	cuv = 0;
608	cdouble = 0;
609	continue;
610	break;
611	case '(':
612	{
613	char ss = s; / Move from register */
614	tempsym_t savsym = *symptr;
615	symptr->patend = savsym.grpend;
616	symptr->level++;
617	PUTBACK;
618	while (len--) {
619	symptr->patptr = savsym.grpbeg;
620	unpack_rec(symptr, ss, strbeg, strend, &ss );
621	if (ss == strend && savsym.howlen == e_star)
622	break; /* No way to continue */
623	}
624	SPAGAIN;
625	s = ss;
626	savsym.flags = symptr->flags;
627	*symptr = savsym;
628	break;
629	}
630	case '@':
631	if (len > strend - strrelbeg)
632	Perl_croak(aTHX_ "'@' outside of string in unpack");
633	s = strrelbeg + len;
634	break;
635	case 'X' \| TYPE_IS_SHRIEKING:
636	if (!len) /* Avoid division by 0 */
637	len = 1;
638	len = (s - strbeg) % len;
639	/* FALL THROUGH */
640	case 'X':
641	if (len > s - strbeg)
642	Perl_croak(aTHX_ "'X' outside of string in unpack" );
643	s -= len;
644	break;
645	case 'x' \| TYPE_IS_SHRIEKING:
646	if (!len) /* Avoid division by 0 */
647	len = 1;
648	aint = (s - strbeg) % len;
649	if (aint) /* Other portable ways? */
650	len = len - aint;
651	else
652	len = 0;
653	/* FALL THROUGH */
654	case 'x':
655	if (len > strend - s)
656	Perl_croak(aTHX_ "'x' outside of string in unpack");
657	s += len;
658	break;
659	case '/':
660	Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
661	break;
662	case 'A':
663	case 'Z':
664	case 'a':
665	if (len > strend - s)
666	len = strend - s;
667	if (checksum)
668	goto uchar_checksum;
669	sv = NEWSV(35, len);
670	sv_setpvn(sv, s, len);
671	if (len > 0 && (datumtype == 'A' \|\| datumtype == 'Z')) {
672	aptr = s; /* borrow register */
673	if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
674	s = SvPVX(sv);
675	while (*s)
676	s++;
677	if (howlen == e_star) /* exact for 'Z' /
678	len = s - SvPVX(sv) + 1;
679	}
680	else { /* 'A' strips both nulls and spaces */
681	s = SvPVX(sv) + len - 1;
682	while (s >= SvPVX(sv) && (!s \|\| isSPACE(s)))
683	s--;
684	*++s = '\0';
685	}
686	SvCUR_set(sv, s - SvPVX(sv));
687	s = aptr; /* unborrow register */
688	}
689	s += len;
690	XPUSHs(sv_2mortal(sv));
691	break;
692	case 'B':
693	case 'b':
694	if (howlen == e_star \|\| len > (strend - s) * 8)
695	len = (strend - s) * 8;
696	if (checksum) {
697	if (!PL_bitcount) {
698	Newz(601, PL_bitcount, 256, char);
699	for (bits = 1; bits < 256; bits++) {
700	if (bits & 1) PL_bitcount[bits]++;
701	if (bits & 2) PL_bitcount[bits]++;
702	if (bits & 4) PL_bitcount[bits]++;
703	if (bits & 8) PL_bitcount[bits]++;
704	if (bits & 16) PL_bitcount[bits]++;
705	if (bits & 32) PL_bitcount[bits]++;
706	if (bits & 64) PL_bitcount[bits]++;
707	if (bits & 128) PL_bitcount[bits]++;
708	}
709	}
710	while (len >= 8) {
711	cuv += PL_bitcount[(unsigned char)s++];
712	len -= 8;
713	}
714	if (len) {
715	bits = *s;
716	if (datumtype == 'b') {
717	while (len-- > 0) {
718	if (bits & 1) cuv++;
719	bits >>= 1;
720	}
721	}
722	else {
723	while (len-- > 0) {
724	if (bits & 128) cuv++;
725	bits <<= 1;
726	}
727	}
728	}
729	break;
730	}
731	sv = NEWSV(35, len + 1);
732	SvCUR_set(sv, len);
733	SvPOK_on(sv);
734	str = SvPVX(sv);
735	if (datumtype == 'b') {
736	aint = len;
737	for (len = 0; len < aint; len++) {
738	if (len & 7) /SUPPRESS 595/
739	bits >>= 1;
740	else
741	bits = *s++;
742	*str++ = '0' + (bits & 1);
743	}
744	}
745	else {
746	aint = len;
747	for (len = 0; len < aint; len++) {
748	if (len & 7)
749	bits <<= 1;
750	else
751	bits = *s++;
752	*str++ = '0' + ((bits & 128) != 0);
753	}
754	}
755	*str = '\0';
756	XPUSHs(sv_2mortal(sv));
757	break;
758	case 'H':
759	case 'h':
760	if (howlen == e_star \|\| len > (strend - s) * 2)
761	len = (strend - s) * 2;
762	sv = NEWSV(35, len + 1);
763	SvCUR_set(sv, len);
764	SvPOK_on(sv);
765	str = SvPVX(sv);
766	if (datumtype == 'h') {
767	aint = len;
768	for (len = 0; len < aint; len++) {
769	if (len & 1)
770	bits >>= 4;
771	else
772	bits = *s++;
773	*str++ = PL_hexdigit[bits & 15];
774	}
775	}
776	else {
777	aint = len;
778	for (len = 0; len < aint; len++) {
779	if (len & 1)
780	bits <<= 4;
781	else
782	bits = *s++;
783	*str++ = PL_hexdigit[(bits >> 4) & 15];
784	}
785	}
786	*str = '\0';
787	XPUSHs(sv_2mortal(sv));
788	break;
789	case 'c':
790	if (len > strend - s)
791	len = strend - s;
792	if (checksum) {
793	while (len-- > 0) {
794	aint = *s++;
795	if (aint >= 128) /* fake up signed chars */
796	aint -= 256;
797	if (checksum > bits_in_uv)
798	cdouble += (NV)aint;
799	else
800	cuv += aint;
801	}
802	}
803	else {
804	if (len && unpack_only_one)
805	len = 1;
806	EXTEND(SP, len);
807	EXTEND_MORTAL(len);
808	while (len-- > 0) {
809	aint = *s++;
810	if (aint >= 128) /* fake up signed chars */
811	aint -= 256;
812	sv = NEWSV(36, 0);
813	sv_setiv(sv, (IV)aint);
814	PUSHs(sv_2mortal(sv));
815	}
816	}
817	break;
818	case 'C':
819	unpack_C: /* unpack U will jump here if not UTF-8 */
820	if (len == 0) {
821	symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
822	break;
823	}
824	if (len > strend - s)
825	len = strend - s;
826	if (checksum) {
827	uchar_checksum:
828	while (len-- > 0) {
829	auint = *s++ & 255;
830	cuv += auint;
831	}
832	}
833	else {
834	if (len && unpack_only_one)
835	len = 1;
836	EXTEND(SP, len);
837	EXTEND_MORTAL(len);
838	while (len-- > 0) {
839	auint = *s++ & 255;
840	sv = NEWSV(37, 0);
841	sv_setiv(sv, (IV)auint);
842	PUSHs(sv_2mortal(sv));
843	}
844	}
845	break;
846	case 'U':
847	if (len == 0) {
848	symptr->flags \|= FLAG_UNPACK_DO_UTF8;
849	break;
850	}
851	if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
852	goto unpack_C;
853	if (len > strend - s)
854	len = strend - s;
855	if (checksum) {
856	while (len-- > 0 && s < strend) {
857	STRLEN alen;
858	auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
859	along = alen;
860	s += along;
861	if (checksum > bits_in_uv)
862	cdouble += (NV)auint;
863	else
864	cuv += auint;
865	}
866	}
867	else {
868	if (len && unpack_only_one)
869	len = 1;
870	EXTEND(SP, len);
871	EXTEND_MORTAL(len);
872	while (len-- > 0 && s < strend) {
873	STRLEN alen;
874	auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
875	along = alen;
876	s += along;
877	sv = NEWSV(37, 0);
878	sv_setuv(sv, (UV)auint);
879	PUSHs(sv_2mortal(sv));
880	}
881	}
882	break;
883	case 's' \| TYPE_IS_SHRIEKING:
884	#if SHORTSIZE != SIZE16
885	along = (strend - s) / sizeof(short);
886	if (len > along)
887	len = along;
888	if (checksum) {
889	short ashort;
890	while (len-- > 0) {
891	COPYNN(s, &ashort, sizeof(short));
892	s += sizeof(short);
893	if (checksum > bits_in_uv)
894	cdouble += (NV)ashort;
895	else
896	cuv += ashort;
897
898	}
899	}
900	else {
901	short ashort;
902	if (len && unpack_only_one)
903	len = 1;
904	EXTEND(SP, len);
905	EXTEND_MORTAL(len);
906	while (len-- > 0) {
907	COPYNN(s, &ashort, sizeof(short));
908	s += sizeof(short);
909	sv = NEWSV(38, 0);
910	sv_setiv(sv, (IV)ashort);
911	PUSHs(sv_2mortal(sv));
912	}
913	}
914	break;
915	#else
916	/* Fallthrough! */
917	#endif
918	case 's':
919	along = (strend - s) / SIZE16;
920	if (len > along)
921	len = along;
922	if (checksum) {
923	while (len-- > 0) {
924	COPY16(s, &ashort);
925	#if SHORTSIZE > SIZE16
926	if (ashort > 32767)
927	ashort -= 65536;
928	#endif
929	s += SIZE16;
930	if (checksum > bits_in_uv)
931	cdouble += (NV)ashort;
932	else
933	cuv += ashort;
934	}
935	}
936	else {
937	if (len && unpack_only_one)
938	len = 1;
939	EXTEND(SP, len);
940	EXTEND_MORTAL(len);
941
942	while (len-- > 0) {
943	COPY16(s, &ashort);
944	#if SHORTSIZE > SIZE16
945	if (ashort > 32767)
946	ashort -= 65536;
947	#endif
948	s += SIZE16;
949	sv = NEWSV(38, 0);
950	sv_setiv(sv, (IV)ashort);
951	PUSHs(sv_2mortal(sv));
952	}
953	}
954	break;
955	case 'S' \| TYPE_IS_SHRIEKING:
956	#if SHORTSIZE != SIZE16
957	along = (strend - s) / sizeof(unsigned short);
958	if (len > along)
959	len = along;
960	if (checksum) {
961	unsigned short aushort;
962	while (len-- > 0) {
963	COPYNN(s, &aushort, sizeof(unsigned short));
964	s += sizeof(unsigned short);
965	if (checksum > bits_in_uv)
966	cdouble += (NV)aushort;
967	else
968	cuv += aushort;
969	}
970	}
971	else {
972	if (len && unpack_only_one)
973	len = 1;
974	EXTEND(SP, len);
975	EXTEND_MORTAL(len);
976	while (len-- > 0) {
977	unsigned short aushort;
978	COPYNN(s, &aushort, sizeof(unsigned short));
979	s += sizeof(unsigned short);
980	sv = NEWSV(39, 0);
981	sv_setiv(sv, (UV)aushort);
982	PUSHs(sv_2mortal(sv));
983	}
984	}
985	break;
986	#else
987	/* Fallhrough! */
988	#endif
989	case 'v':
990	case 'n':
991	case 'S':
992	along = (strend - s) / SIZE16;
993	if (len > along)
994	len = along;
995	if (checksum) {
996	while (len-- > 0) {
997	COPY16(s, &aushort);
998	s += SIZE16;
999	#ifdef HAS_NTOHS
1000	if (datumtype == 'n')
1001	aushort = PerlSock_ntohs(aushort);
1002	#endif
1003	#ifdef HAS_VTOHS
1004	if (datumtype == 'v')
1005	aushort = vtohs(aushort);
1006	#endif
1007	if (checksum > bits_in_uv)
1008	cdouble += (NV)aushort;
1009	else
1010	cuv += aushort;
1011	}
1012	}
1013	else {
1014	if (len && unpack_only_one)
1015	len = 1;
1016	EXTEND(SP, len);
1017	EXTEND_MORTAL(len);
1018	while (len-- > 0) {
1019	COPY16(s, &aushort);
1020	s += SIZE16;
1021	sv = NEWSV(39, 0);
1022	#ifdef HAS_NTOHS
1023	if (datumtype == 'n')
1024	aushort = PerlSock_ntohs(aushort);
1025	#endif
1026	#ifdef HAS_VTOHS
1027	if (datumtype == 'v')
1028	aushort = vtohs(aushort);
1029	#endif
1030	sv_setiv(sv, (UV)aushort);
1031	PUSHs(sv_2mortal(sv));
1032	}
1033	}
1034	break;
1035	case 'i':
1036	case 'i' \| TYPE_IS_SHRIEKING:
1037	along = (strend - s) / sizeof(int);
1038	if (len > along)
1039	len = along;
1040	if (checksum) {
1041	while (len-- > 0) {
1042	Copy(s, &aint, 1, int);
1043	s += sizeof(int);
1044	if (checksum > bits_in_uv)
1045	cdouble += (NV)aint;
1046	else
1047	cuv += aint;
1048	}
1049	}
1050	else {
1051	if (len && unpack_only_one)
1052	len = 1;
1053	EXTEND(SP, len);
1054	EXTEND_MORTAL(len);
1055	while (len-- > 0) {
1056	Copy(s, &aint, 1, int);
1057	s += sizeof(int);
1058	sv = NEWSV(40, 0);
1059	#ifdef __osf__
1060	/* Without the dummy below unpack("i", pack("i",-1))
1061	* return 0xFFffFFff instead of -1 for Digital Unix V4.0
1062	* cc with optimization turned on.
1063	*
1064	* The bug was detected in
1065	* DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1066	* with optimization (-O4) turned on.
1067	* DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1068	* does not have this problem even with -O4.
1069	*
1070	* This bug was reported as DECC_BUGS 1431
1071	* and tracked internally as GEM_BUGS 7775.
1072	*
1073	* The bug is fixed in
1074	* Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1075	* UNIX V4.0F support: DEC C V5.9-006 or later
1076	* UNIX V4.0E support: DEC C V5.8-011 or later
1077	* and also in DTK.
1078	*
1079	* See also few lines later for the same bug.
1080	*/
1081	(aint) ?
1082	sv_setiv(sv, (IV)aint) :
1083	#endif
1084	sv_setiv(sv, (IV)aint);
1085	PUSHs(sv_2mortal(sv));
1086	}
1087	}
1088	break;
1089	case 'I':
1090	case 'I' \| TYPE_IS_SHRIEKING:
1091	along = (strend - s) / sizeof(unsigned int);
1092	if (len > along)
1093	len = along;
1094	if (checksum) {
1095	while (len-- > 0) {
1096	Copy(s, &auint, 1, unsigned int);
1097	s += sizeof(unsigned int);
1098	if (checksum > bits_in_uv)
1099	cdouble += (NV)auint;
1100	else
1101	cuv += auint;
1102	}
1103	}
1104	else {
1105	if (len && unpack_only_one)
1106	len = 1;
1107	EXTEND(SP, len);
1108	EXTEND_MORTAL(len);
1109	while (len-- > 0) {
1110	Copy(s, &auint, 1, unsigned int);
1111	s += sizeof(unsigned int);
1112	sv = NEWSV(41, 0);
1113	#ifdef __osf__
1114	/* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1115	* returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1116	* See details few lines earlier. */
1117	(auint) ?
1118	sv_setuv(sv, (UV)auint) :
1119	#endif
1120	sv_setuv(sv, (UV)auint);
1121	PUSHs(sv_2mortal(sv));
1122	}
1123	}
1124	break;
1125	case 'j':
1126	along = (strend - s) / IVSIZE;
1127	if (len > along)
1128	len = along;
1129	if (checksum) {
1130	while (len-- > 0) {
1131	Copy(s, &aiv, 1, IV);
1132	s += IVSIZE;
1133	if (checksum > bits_in_uv)
1134	cdouble += (NV)aiv;
1135	else
1136	cuv += aiv;
1137	}
1138	}
1139	else {
1140	if (len && unpack_only_one)
1141	len = 1;
1142	EXTEND(SP, len);
1143	EXTEND_MORTAL(len);
1144	while (len-- > 0) {
1145	Copy(s, &aiv, 1, IV);
1146	s += IVSIZE;
1147	sv = NEWSV(40, 0);
1148	sv_setiv(sv, aiv);
1149	PUSHs(sv_2mortal(sv));
1150	}
1151	}
1152	break;
1153	case 'J':
1154	along = (strend - s) / UVSIZE;
1155	if (len > along)
1156	len = along;
1157	if (checksum) {
1158	while (len-- > 0) {
1159	Copy(s, &auv, 1, UV);
1160	s += UVSIZE;
1161	if (checksum > bits_in_uv)
1162	cdouble += (NV)auv;
1163	else
1164	cuv += auv;
1165	}
1166	}
1167	else {
1168	if (len && unpack_only_one)
1169	len = 1;
1170	EXTEND(SP, len);
1171	EXTEND_MORTAL(len);
1172	while (len-- > 0) {
1173	Copy(s, &auv, 1, UV);
1174	s += UVSIZE;
1175	sv = NEWSV(41, 0);
1176	sv_setuv(sv, auv);
1177	PUSHs(sv_2mortal(sv));
1178	}
1179	}
1180	break;
1181	case 'l' \| TYPE_IS_SHRIEKING:
1182	#if LONGSIZE != SIZE32
1183	along = (strend - s) / sizeof(long);
1184	if (len > along)
1185	len = along;
1186	if (checksum) {
1187	while (len-- > 0) {
1188	COPYNN(s, &along, sizeof(long));
1189	s += sizeof(long);
1190	if (checksum > bits_in_uv)
1191	cdouble += (NV)along;
1192	else
1193	cuv += along;
1194	}
1195	}
1196	else {
1197	if (len && unpack_only_one)
1198	len = 1;
1199	EXTEND(SP, len);
1200	EXTEND_MORTAL(len);
1201	while (len-- > 0) {
1202	COPYNN(s, &along, sizeof(long));
1203	s += sizeof(long);
1204	sv = NEWSV(42, 0);
1205	sv_setiv(sv, (IV)along);
1206	PUSHs(sv_2mortal(sv));
1207	}
1208	}
1209	break;
1210	#else
1211	/* Fallthrough! */
1212	#endif
1213	case 'l':
1214	along = (strend - s) / SIZE32;
1215	if (len > along)
1216	len = along;
1217	if (checksum) {
1218	while (len-- > 0) {
1219	#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1220	I32 along;
1221	#endif
1222	COPY32(s, &along);
1223	#if LONGSIZE > SIZE32
1224	if (along > 2147483647)
1225	along -= 4294967296;
1226	#endif
1227	s += SIZE32;
1228	if (checksum > bits_in_uv)
1229	cdouble += (NV)along;
1230	else
1231	cuv += along;
1232	}
1233	}
1234	else {
1235	if (len && unpack_only_one)
1236	len = 1;
1237	EXTEND(SP, len);
1238	EXTEND_MORTAL(len);
1239	while (len-- > 0) {
1240	#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1241	I32 along;
1242	#endif
1243	COPY32(s, &along);
1244	#if LONGSIZE > SIZE32
1245	if (along > 2147483647)
1246	along -= 4294967296;
1247	#endif
1248	s += SIZE32;
1249	sv = NEWSV(42, 0);
1250	sv_setiv(sv, (IV)along);
1251	PUSHs(sv_2mortal(sv));
1252	}
1253	}
1254	break;
1255	case 'L' \| TYPE_IS_SHRIEKING:
1256	#if LONGSIZE != SIZE32
1257	along = (strend - s) / sizeof(unsigned long);
1258	if (len > along)
1259	len = along;
1260	if (checksum) {
1261	while (len-- > 0) {
1262	unsigned long aulong;
1263	COPYNN(s, &aulong, sizeof(unsigned long));
1264	s += sizeof(unsigned long);
1265	if (checksum > bits_in_uv)
1266	cdouble += (NV)aulong;
1267	else
1268	cuv += aulong;
1269	}
1270	}
1271	else {
1272	if (len && unpack_only_one)
1273	len = 1;
1274	EXTEND(SP, len);
1275	EXTEND_MORTAL(len);
1276	while (len-- > 0) {
1277	unsigned long aulong;
1278	COPYNN(s, &aulong, sizeof(unsigned long));
1279	s += sizeof(unsigned long);
1280	sv = NEWSV(43, 0);
1281	sv_setuv(sv, (UV)aulong);
1282	PUSHs(sv_2mortal(sv));
1283	}
1284	}
1285	break;
1286	#else
1287	/* Fall through! */
1288	#endif
1289	case 'V':
1290	case 'N':
1291	case 'L':
1292	along = (strend - s) / SIZE32;
1293	if (len > along)
1294	len = along;
1295	if (checksum) {
1296	while (len-- > 0) {
1297	COPY32(s, &aulong);
1298	s += SIZE32;
1299	#ifdef HAS_NTOHL
1300	if (datumtype == 'N')
1301	aulong = PerlSock_ntohl(aulong);
1302	#endif
1303	#ifdef HAS_VTOHL
1304	if (datumtype == 'V')
1305	aulong = vtohl(aulong);
1306	#endif
1307	if (checksum > bits_in_uv)
1308	cdouble += (NV)aulong;
1309	else
1310	cuv += aulong;
1311	}
1312	}
1313	else {
1314	if (len && unpack_only_one)
1315	len = 1;
1316	EXTEND(SP, len);
1317	EXTEND_MORTAL(len);
1318	while (len-- > 0) {
1319	COPY32(s, &aulong);
1320	s += SIZE32;
1321	#ifdef HAS_NTOHL
1322	if (datumtype == 'N')
1323	aulong = PerlSock_ntohl(aulong);
1324	#endif
1325	#ifdef HAS_VTOHL
1326	if (datumtype == 'V')
1327	aulong = vtohl(aulong);
1328	#endif
1329	sv = NEWSV(43, 0);
1330	sv_setuv(sv, (UV)aulong);
1331	PUSHs(sv_2mortal(sv));
1332	}
1333	}
1334	break;
1335	case 'p':
1336	along = (strend - s) / sizeof(char*);
1337	if (len > along)
1338	len = along;
1339	EXTEND(SP, len);
1340	EXTEND_MORTAL(len);
1341	while (len-- > 0) {
1342	if (sizeof(char*) > strend - s)
1343	break;
1344	else {
1345	Copy(s, &aptr, 1, char*);
1346	s += sizeof(char*);
1347	}
1348	sv = NEWSV(44, 0);
1349	if (aptr)
1350	sv_setpv(sv, aptr);
1351	PUSHs(sv_2mortal(sv));
1352	}
1353	break;
1354	case 'w':
1355	if (len && unpack_only_one)
1356	len = 1;
1357	EXTEND(SP, len);
1358	EXTEND_MORTAL(len);
1359	{
1360	UV auv = 0;
1361	U32 bytes = 0;
1362
1363	while ((len > 0) && (s < strend)) {
1364	auv = (auv << 7) \| (*s & 0x7f);
1365	/* UTF8_IS_XXXXX not right here - using constant 0x80 */
1366	if ((U8)(*s++) < 0x80) {
1367	bytes = 0;
1368	sv = NEWSV(40, 0);
1369	sv_setuv(sv, auv);
1370	PUSHs(sv_2mortal(sv));
1371	len--;
1372	auv = 0;
1373	}
1374	else if (++bytes >= sizeof(UV)) { /* promote to string */
1375	char *t;
1376	STRLEN n_a;
1377
1378	sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1379	while (s < strend) {
1380	sv = mul128(sv, (U8)(*s & 0x7f));
1381	if (!(*s++ & 0x80)) {
1382	bytes = 0;
1383	break;
1384	}
1385	}
1386	t = SvPV(sv, n_a);
1387	while (*t == '0')
1388	t++;
1389	sv_chop(sv, t);
1390	PUSHs(sv_2mortal(sv));
1391	len--;
1392	auv = 0;
1393	}
1394	}
1395	if ((s >= strend) && bytes)
1396	Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1397	}
1398	break;
1399	case 'P':
1400	if (symptr->howlen == e_star)
1401	Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1402	EXTEND(SP, 1);
1403	if (sizeof(char*) > strend - s)
1404	break;
1405	else {
1406	Copy(s, &aptr, 1, char*);
1407	s += sizeof(char*);
1408	}
1409	sv = NEWSV(44, 0);
1410	if (aptr)
1411	sv_setpvn(sv, aptr, len);
1412	PUSHs(sv_2mortal(sv));
1413	break;
1414	#ifdef HAS_QUAD
1415	case 'q':
1416	along = (strend - s) / sizeof(Quad_t);
1417	if (len > along)
1418	len = along;
1419	if (checksum) {
1420	while (len-- > 0) {
1421	Copy(s, &aquad, 1, Quad_t);
1422	s += sizeof(Quad_t);
1423	if (checksum > bits_in_uv)
1424	cdouble += (NV)aquad;
1425	else
1426	cuv += aquad;
1427	}
1428	}
1429	else {
1430	if (len && unpack_only_one)
1431	len = 1;
1432	EXTEND(SP, len);
1433	EXTEND_MORTAL(len);
1434	while (len-- > 0) {
1435	if (s + sizeof(Quad_t) > strend)
1436	aquad = 0;
1437	else {
1438	Copy(s, &aquad, 1, Quad_t);
1439	s += sizeof(Quad_t);
1440	}
1441	sv = NEWSV(42, 0);
1442	if (aquad >= IV_MIN && aquad <= IV_MAX)
1443	sv_setiv(sv, (IV)aquad);
1444	else
1445	sv_setnv(sv, (NV)aquad);
1446	PUSHs(sv_2mortal(sv));
1447	}
1448	}
1449	break;
1450	case 'Q':
1451	along = (strend - s) / sizeof(Uquad_t);
1452	if (len > along)
1453	len = along;
1454	if (checksum) {
1455	while (len-- > 0) {
1456	Copy(s, &auquad, 1, Uquad_t);
1457	s += sizeof(Uquad_t);
1458	if (checksum > bits_in_uv)
1459	cdouble += (NV)auquad;
1460	else
1461	cuv += auquad;
1462	}
1463	}
1464	else {
1465	if (len && unpack_only_one)
1466	len = 1;
1467	EXTEND(SP, len);
1468	EXTEND_MORTAL(len);
1469	while (len-- > 0) {
1470	if (s + sizeof(Uquad_t) > strend)
1471	auquad = 0;
1472	else {
1473	Copy(s, &auquad, 1, Uquad_t);
1474	s += sizeof(Uquad_t);
1475	}
1476	sv = NEWSV(43, 0);
1477	if (auquad <= UV_MAX)
1478	sv_setuv(sv, (UV)auquad);
1479	else
1480	sv_setnv(sv, (NV)auquad);
1481	PUSHs(sv_2mortal(sv));
1482	}
1483	}
1484	break;
1485	#endif
1486	/* float and double added gnb@melba.bby.oz.au 22/11/89 */
1487	case 'f':
1488	along = (strend - s) / sizeof(float);
1489	if (len > along)
1490	len = along;
1491	if (checksum) {
1492	while (len-- > 0) {
1493	Copy(s, &afloat, 1, float);
1494	s += sizeof(float);
1495	cdouble += afloat;
1496	}
1497	}
1498	else {
1499	if (len && unpack_only_one)
1500	len = 1;
1501	EXTEND(SP, len);
1502	EXTEND_MORTAL(len);
1503	while (len-- > 0) {
1504	Copy(s, &afloat, 1, float);
1505	s += sizeof(float);
1506	sv = NEWSV(47, 0);
1507	sv_setnv(sv, (NV)afloat);
1508	PUSHs(sv_2mortal(sv));
1509	}
1510	}
1511	break;
1512	case 'd':
1513	along = (strend - s) / sizeof(double);
1514	if (len > along)
1515	len = along;
1516	if (checksum) {
1517	while (len-- > 0) {
1518	Copy(s, &adouble, 1, double);
1519	s += sizeof(double);
1520	cdouble += adouble;
1521	}
1522	}
1523	else {
1524	if (len && unpack_only_one)
1525	len = 1;
1526	EXTEND(SP, len);
1527	EXTEND_MORTAL(len);
1528	while (len-- > 0) {
1529	Copy(s, &adouble, 1, double);
1530	s += sizeof(double);
1531	sv = NEWSV(48, 0);
1532	sv_setnv(sv, (NV)adouble);
1533	PUSHs(sv_2mortal(sv));
1534	}
1535	}
1536	break;
1537	case 'F':
1538	along = (strend - s) / NVSIZE;
1539	if (len > along)
1540	len = along;
1541	if (checksum) {
1542	while (len-- > 0) {
1543	Copy(s, &anv, 1, NV);
1544	s += NVSIZE;
1545	cdouble += anv;
1546	}
1547	}
1548	else {
1549	if (len && unpack_only_one)
1550	len = 1;
1551	EXTEND(SP, len);
1552	EXTEND_MORTAL(len);
1553	while (len-- > 0) {
1554	Copy(s, &anv, 1, NV);
1555	s += NVSIZE;
1556	sv = NEWSV(48, 0);
1557	sv_setnv(sv, anv);
1558	PUSHs(sv_2mortal(sv));
1559	}
1560	}
1561	break;
1562	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1563	case 'D':
1564	along = (strend - s) / LONG_DOUBLESIZE;
1565	if (len > along)
1566	len = along;
1567	if (checksum) {
1568	while (len-- > 0) {
1569	Copy(s, &aldouble, 1, long double);
1570	s += LONG_DOUBLESIZE;
1571	cdouble += aldouble;
1572	}
1573	}
1574	else {
1575	if (len && unpack_only_one)
1576	len = 1;
1577	EXTEND(SP, len);
1578	EXTEND_MORTAL(len);
1579	while (len-- > 0) {
1580	Copy(s, &aldouble, 1, long double);
1581	s += LONG_DOUBLESIZE;
1582	sv = NEWSV(48, 0);
1583	sv_setnv(sv, (NV)aldouble);
1584	PUSHs(sv_2mortal(sv));
1585	}
1586	}
1587	break;
1588	#endif
1589	case 'u':
1590	/* MKS:
1591	* Initialise the decode mapping. By using a table driven
1592	* algorithm, the code will be character-set independent
1593	* (and just as fast as doing character arithmetic)
1594	*/
1595	if (PL_uudmap['M'] == 0) {
1596	int i;
1597
1598	for (i = 0; i < sizeof(PL_uuemap); i += 1)
1599	PL_uudmap[(U8)PL_uuemap[i]] = i;
1600	/*
1601	* Because ' ' and '`' map to the same value,
1602	* we need to decode them both the same.
1603	*/
1604	PL_uudmap[' '] = 0;
1605	}
1606
1607	along = (strend - s) * 3 / 4;
1608	sv = NEWSV(42, along);
1609	if (along)
1610	SvPOK_on(sv);
1611	while (s < strend && s > ' ' && ISUUCHAR(s)) {
1612	I32 a, b, c, d;
1613	char hunk[4];
1614
1615	hunk[3] = '\0';
1616	len = PL_uudmap[(U8)s++] & 077;
1617	while (len > 0) {
1618	if (s < strend && ISUUCHAR(*s))
1619	a = PL_uudmap[(U8)s++] & 077;
1620	else
1621	a = 0;
1622	if (s < strend && ISUUCHAR(*s))
1623	b = PL_uudmap[(U8)s++] & 077;
1624	else
1625	b = 0;
1626	if (s < strend && ISUUCHAR(*s))
1627	c = PL_uudmap[(U8)s++] & 077;
1628	else
1629	c = 0;
1630	if (s < strend && ISUUCHAR(*s))
1631	d = PL_uudmap[(U8)s++] & 077;
1632	else
1633	d = 0;
1634	hunk[0] = (char)((a << 2) \| (b >> 4));
1635	hunk[1] = (char)((b << 4) \| (c >> 2));
1636	hunk[2] = (char)((c << 6) \| d);
1637	sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1638	len -= 3;
1639	}
1640	if (*s == '\n')
1641	s++;
1642	else /* possible checksum byte */
1643	if (s + 1 < strend && s[1] == '\n')
1644	s += 2;
1645	}
1646	XPUSHs(sv_2mortal(sv));
1647	break;
1648	}
1649
1650	if (checksum) {
1651	sv = NEWSV(42, 0);
1652	if (strchr("fFdD", datumtype) \|\|
1653	(checksum > bits_in_uv &&
1654	strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
1655	NV trouble;
1656
1657	adouble = (NV) (1 << (checksum & 15));
1658	while (checksum >= 16) {
1659	checksum -= 16;
1660	adouble *= 65536.0;
1661	}
1662	while (cdouble < 0.0)
1663	cdouble += adouble;
1664	cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1665	sv_setnv(sv, cdouble);
1666	}
1667	else {
1668	if (checksum < bits_in_uv) {
1669	UV mask = ((UV)1 << checksum) - 1;
1670	cuv &= mask;
1671	}
1672	sv_setuv(sv, cuv);
1673	}
1674	XPUSHs(sv_2mortal(sv));
1675	checksum = 0;
1676	}
1677
1678	if (symptr->flags & FLAG_SLASH){
1679	if (SP - PL_stack_base - start_sp_offset <= 0)
1680	Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1681	if( next_symbol(symptr) ){
1682	if( symptr->howlen == e_number )
1683	Perl_croak(aTHX_ "Count after length/code in unpack" );
1684	if( beyond ){
1685	/* ...end of char buffer then no decent length available */
1686	Perl_croak(aTHX_ "length/code after end of string in unpack" );
1687	} else {
1688	/* take top of stack (hope it's numeric) */
1689	len = POPi;
1690	if( len < 0 )
1691	Perl_croak(aTHX_ "Negative '/' count in unpack" );
1692	}
1693	} else {
1694	Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1695	}
1696	datumtype = symptr->code;
1697	goto redo_switch;
1698	}
1699	}
1700
1701	if (new_s)
1702	*new_s = s;
1703	PUTBACK;
1704	return SP - PL_stack_base - start_sp_offset;
1705	}
1706
1707	PP(pp_unpack)
1708	{
1709	dSP;
1710	dPOPPOPssrl;
1711	I32 gimme = GIMME_V;
1712	STRLEN llen;
1713	STRLEN rlen;
1714	register char *pat = SvPV(left, llen);
1715	#ifdef PACKED_IS_OCTETS
1716	/* Packed side is assumed to be octets - so force downgrade if it
1717	has been UTF-8 encoded by accident
1718	*/
1719	register char *s = SvPVbyte(right, rlen);
1720	#else
1721	register char *s = SvPV(right, rlen);
1722	#endif
1723	char *strend = s + rlen;
1724	register char *patend = pat + llen;
1725	register I32 cnt;
1726
1727	PUTBACK;
1728	cnt = unpackstring(pat, patend, s, strend,
1729	((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1730	\| (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1731
1732	SPAGAIN;
1733	if ( !cnt && gimme == G_SCALAR )
1734	PUSHs(&PL_sv_undef);
1735	RETURN;
1736	}
1737
1738	STATIC void
1739	S_doencodes(pTHX_ register SV sv, register char s, register I32 len)
1740	{
1741	char hunk[5];
1742
1743	*hunk = PL_uuemap[len];
1744	sv_catpvn(sv, hunk, 1);
1745	hunk[4] = '\0';
1746	while (len > 2) {
1747	hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1748	hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) \| ((s[1] >> 4) & 017)))];
1749	hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) \| ((s[2] >> 6) & 03)))];
1750	hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1751	sv_catpvn(sv, hunk, 4);
1752	s += 3;
1753	len -= 3;
1754	}
1755	if (len > 0) {
1756	char r = (len > 1 ? s[1] : '\0');
1757	hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1758	hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) \| ((r >> 4) & 017)))];
1759	hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1760	hunk[3] = PL_uuemap[0];
1761	sv_catpvn(sv, hunk, 4);
1762	}
1763	sv_catpvn(sv, "\n", 1);
1764	}
1765
1766	STATIC SV *
1767	S_is_an_int(pTHX_ char *s, STRLEN l)
1768	{
1769	STRLEN n_a;
1770	SV *result = newSVpvn(s, l);
1771	char result_c = SvPV(result, n_a); / convenience */
1772	char *out = result_c;
1773	bool skip = 1;
1774	bool ignore = 0;
1775
1776	while (*s) {
1777	switch (*s) {
1778	case ' ':
1779	break;
1780	case '+':
1781	if (!skip) {
1782	SvREFCNT_dec(result);
1783	return (NULL);
1784	}
1785	break;
1786	case '0':
1787	case '1':
1788	case '2':
1789	case '3':
1790	case '4':
1791	case '5':
1792	case '6':
1793	case '7':
1794	case '8':
1795	case '9':
1796	skip = 0;
1797	if (!ignore) {
1798	(out++) = s;
1799	}
1800	break;
1801	case '.':
1802	ignore = 1;
1803	break;
1804	default:
1805	SvREFCNT_dec(result);
1806	return (NULL);
1807	}
1808	s++;
1809	}
1810	*(out++) = '\0';
1811	SvCUR_set(result, out - result_c);
1812	return (result);
1813	}
1814
1815	/* pnum must be '\0' terminated */
1816	STATIC int
1817	S_div128(pTHX_ SV pnum, bool done)
1818	{
1819	STRLEN len;
1820	char *s = SvPV(pnum, len);
1821	int m = 0;
1822	int r = 0;
1823	char *t = s;
1824
1825	*done = 1;
1826	while (*t) {
1827	int i;
1828
1829	i = m * 10 + (*t - '0');
1830	m = i & 0x7F;
1831	r = (i >> 7); /* r < 10 */
1832	if (r) {
1833	*done = 0;
1834	}
1835	*(t++) = '0' + r;
1836	}
1837	*(t++) = '\0';
1838	SvCUR_set(pnum, (STRLEN) (t - s));
1839	return (m);
1840	}
1841
1842
1843
1844	/*
1845	=for apidoc pack_cat
1846
1847	The engine implementing pack() Perl function. Note: parameters next_in_list and
1848	flags are not used. This call should not be used; use packlist instead.
1849
1850	=cut */
1851
1852
1853	void
1854	Perl_pack_cat(pTHX_ SV cat, char pat, register char patend, register SV beglist, SV endlist, SV **next_in_list, U32 flags)
1855	{
1856	tempsym_t sym = { 0 };
1857	sym.patptr = pat;
1858	sym.patend = patend;
1859	sym.flags = FLAG_PACK;
1860
1861	(void)pack_rec( cat, &sym, beglist, endlist );
1862	}
1863
1864
1865	/*
1866	=for apidoc packlist
1867
1868	The engine implementing pack() Perl function.
1869
1870	=cut */
1871
1872
1873	void
1874	Perl_packlist(pTHX_ SV cat, char pat, register char patend, register SV beglist, SV *endlist )
1875	{
1876	tempsym_t sym = { 0 };
1877	sym.patptr = pat;
1878	sym.patend = patend;
1879	sym.flags = FLAG_PACK;
1880
1881	(void)pack_rec( cat, &sym, beglist, endlist );
1882	}
1883
1884
1885	STATIC
1886	SV **
1887	S_pack_rec(pTHX_ SV cat, register tempsym_t symptr, register SV beglist, SV endlist )
1888	{
1889	register I32 items;
1890	STRLEN fromlen;
1891	register I32 len = 0;
1892	SV *fromstr;
1893	/SUPPRESS 442/
1894	static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1895	static char *space10 = " ";
1896	bool found;
1897
1898	/* These must not be in registers: */
1899	char achar;
1900	I16 ashort;
1901	int aint;
1902	unsigned int auint;
1903	I32 along;
1904	U32 aulong;
1905	IV aiv;
1906	UV auv;
1907	NV anv;
1908	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1909	long double aldouble;
1910	#endif
1911	#ifdef HAS_QUAD
1912	Quad_t aquad;
1913	Uquad_t auquad;
1914	#endif
1915	char *aptr;
1916	float afloat;
1917	double adouble;
1918	int strrelbeg = SvCUR(cat);
1919	tempsym_t lookahead;
1920
1921	items = endlist - beglist;
1922	found = next_symbol( symptr );
1923
1924	#ifndef PACKED_IS_OCTETS
1925	if (symptr->level == 0 && found && symptr->code == 'U' ){
1926	SvUTF8_on(cat);
1927	}
1928	#endif
1929
1930	while (found) {
1931	SV *lengthcode = Nullsv;
1932	#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1933
1934	I32 datumtype = symptr->code;
1935	howlen_t howlen;
1936
1937	switch( howlen = symptr->howlen ){
1938	case e_no_len:
1939	case e_number:
1940	len = symptr->length;
1941	break;
1942	case e_star:
1943	len = strchr("@Xxu", datumtype) ? 0 : items;
1944	break;
1945	}
1946
1947	/* Look ahead for next symbol. Do we have code/code? */
1948	lookahead = *symptr;
1949	found = next_symbol(&lookahead);
1950	if ( symptr->flags & FLAG_SLASH ) {
1951	if (found){
1952	if ( 0 == strchr( "aAZ", lookahead.code ) \|\|
1953	e_star != lookahead.howlen )
1954	Perl_croak(aTHX_ "'/' must be followed by 'a', 'A' or 'Z*' in pack");
1955	lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1956	? *beglist : &PL_sv_no)
1957	+ (lookahead.code == 'Z' ? 1 : 0)));
1958	} else {
1959	Perl_croak(aTHX_ "Code missing after '/' in pack");
1960	}
1961	}
1962
1963	switch(datumtype) {
1964	default:
1965	Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype);
1966	case '%':
1967	Perl_croak(aTHX_ "'%%' may not be used in pack");
1968	case '@':
1969	len += strrelbeg - SvCUR(cat);
1970	if (len > 0)
1971	goto grow;
1972	len = -len;
1973	if (len > 0)
1974	goto shrink;
1975	break;
1976	case '(':
1977	{
1978	tempsym_t savsym = *symptr;
1979	symptr->patend = savsym.grpend;
1980	symptr->level++;
1981	while (len--) {
1982	symptr->patptr = savsym.grpbeg;
1983	beglist = pack_rec(cat, symptr, beglist, endlist );
1984	if (savsym.howlen == e_star && beglist == endlist)
1985	break; /* No way to continue */
1986	}
1987	lookahead.flags = symptr->flags;
1988	*symptr = savsym;
1989	break;
1990	}
1991	case 'X' \| TYPE_IS_SHRIEKING:
1992	if (!len) /* Avoid division by 0 */
1993	len = 1;
1994	len = (SvCUR(cat)) % len;
1995	/* FALL THROUGH */
1996	case 'X':
1997	shrink:
1998	if ((I32)SvCUR(cat) < len)
1999	Perl_croak(aTHX_ "'X' outside of string in pack");
2000	SvCUR(cat) -= len;
2001	*SvEND(cat) = '\0';
2002	break;
2003	case 'x' \| TYPE_IS_SHRIEKING:
2004	if (!len) /* Avoid division by 0 */
2005	len = 1;
2006	aint = (SvCUR(cat)) % len;
2007	if (aint) /* Other portable ways? */
2008	len = len - aint;
2009	else
2010	len = 0;
2011	/* FALL THROUGH */
2012
2013	case 'x':
2014	grow:
2015	while (len >= 10) {
2016	sv_catpvn(cat, null10, 10);
2017	len -= 10;
2018	}
2019	sv_catpvn(cat, null10, len);
2020	break;
2021	case 'A':
2022	case 'Z':
2023	case 'a':
2024	fromstr = NEXTFROM;
2025	aptr = SvPV(fromstr, fromlen);
2026	if (howlen == e_star) {
2027	len = fromlen;
2028	if (datumtype == 'Z')
2029	++len;
2030	}
2031	if ((I32)fromlen >= len) {
2032	sv_catpvn(cat, aptr, len);
2033	if (datumtype == 'Z')
2034	*(SvEND(cat)-1) = '\0';
2035	}
2036	else {
2037	sv_catpvn(cat, aptr, fromlen);
2038	len -= fromlen;
2039	if (datumtype == 'A') {
2040	while (len >= 10) {
2041	sv_catpvn(cat, space10, 10);
2042	len -= 10;
2043	}
2044	sv_catpvn(cat, space10, len);
2045	}
2046	else {
2047	while (len >= 10) {
2048	sv_catpvn(cat, null10, 10);
2049	len -= 10;
2050	}
2051	sv_catpvn(cat, null10, len);
2052	}
2053	}
2054	break;
2055	case 'B':
2056	case 'b':
2057	{
2058	register char *str;
2059	I32 saveitems;
2060
2061	fromstr = NEXTFROM;
2062	saveitems = items;
2063	str = SvPV(fromstr, fromlen);
2064	if (howlen == e_star)
2065	len = fromlen;
2066	aint = SvCUR(cat);
2067	SvCUR(cat) += (len+7)/8;
2068	SvGROW(cat, SvCUR(cat) + 1);
2069	aptr = SvPVX(cat) + aint;
2070	if (len > (I32)fromlen)
2071	len = fromlen;
2072	aint = len;
2073	items = 0;
2074	if (datumtype == 'B') {
2075	for (len = 0; len++ < aint;) {
2076	items \|= *str++ & 1;
2077	if (len & 7)
2078	items <<= 1;
2079	else {
2080	*aptr++ = items & 0xff;
2081	items = 0;
2082	}
2083	}
2084	}
2085	else {
2086	for (len = 0; len++ < aint;) {
2087	if (*str++ & 1)
2088	items \|= 128;
2089	if (len & 7)
2090	items >>= 1;
2091	else {
2092	*aptr++ = items & 0xff;
2093	items = 0;
2094	}
2095	}
2096	}
2097	if (aint & 7) {
2098	if (datumtype == 'B')
2099	items <<= 7 - (aint & 7);
2100	else
2101	items >>= 7 - (aint & 7);
2102	*aptr++ = items & 0xff;
2103	}
2104	str = SvPVX(cat) + SvCUR(cat);
2105	while (aptr <= str)
2106	*aptr++ = '\0';
2107
2108	items = saveitems;
2109	}
2110	break;
2111	case 'H':
2112	case 'h':
2113	{
2114	register char *str;
2115	I32 saveitems;
2116
2117	fromstr = NEXTFROM;
2118	saveitems = items;
2119	str = SvPV(fromstr, fromlen);
2120	if (howlen == e_star)
2121	len = fromlen;
2122	aint = SvCUR(cat);
2123	SvCUR(cat) += (len+1)/2;
2124	SvGROW(cat, SvCUR(cat) + 1);
2125	aptr = SvPVX(cat) + aint;
2126	if (len > (I32)fromlen)
2127	len = fromlen;
2128	aint = len;
2129	items = 0;
2130	if (datumtype == 'H') {
2131	for (len = 0; len++ < aint;) {
2132	if (isALPHA(*str))
2133	items \|= ((*str++ & 15) + 9) & 15;
2134	else
2135	items \|= *str++ & 15;
2136	if (len & 1)
2137	items <<= 4;
2138	else {
2139	*aptr++ = items & 0xff;
2140	items = 0;
2141	}
2142	}
2143	}
2144	else {
2145	for (len = 0; len++ < aint;) {
2146	if (isALPHA(*str))
2147	items \|= (((*str++ & 15) + 9) & 15) << 4;
2148	else
2149	items \|= (*str++ & 15) << 4;
2150	if (len & 1)
2151	items >>= 4;
2152	else {
2153	*aptr++ = items & 0xff;
2154	items = 0;
2155	}
2156	}
2157	}
2158	if (aint & 1)
2159	*aptr++ = items & 0xff;
2160	str = SvPVX(cat) + SvCUR(cat);
2161	while (aptr <= str)
2162	*aptr++ = '\0';
2163
2164	items = saveitems;
2165	}
2166	break;
2167	case 'C':
2168	case 'c':
2169	while (len-- > 0) {
2170	fromstr = NEXTFROM;
2171	switch (datumtype) {
2172	case 'C':
2173	aint = SvIV(fromstr);
2174	if ((aint < 0 \|\| aint > 255) &&
2175	ckWARN(WARN_PACK))
2176	Perl_warner(aTHX_ packWARN(WARN_PACK),
2177	"Character in 'C' format wrapped in pack");
2178	achar = aint & 255;
2179	sv_catpvn(cat, &achar, sizeof(char));
2180	break;
2181	case 'c':
2182	aint = SvIV(fromstr);
2183	if ((aint < -128 \|\| aint > 127) &&
2184	ckWARN(WARN_PACK))
2185	Perl_warner(aTHX_ packWARN(WARN_PACK),
2186	"Character in 'c' format wrapped in pack" );
2187	achar = aint & 255;
2188	sv_catpvn(cat, &achar, sizeof(char));
2189	break;
2190	}
2191	}
2192	break;
2193	case 'U':
2194	while (len-- > 0) {
2195	fromstr = NEXTFROM;
2196	auint = UNI_TO_NATIVE(SvUV(fromstr));
2197	SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2198	SvCUR_set(cat,
2199	(char)uvchr_to_utf8_flags((U8)SvEND(cat),
2200	auint,
2201	ckWARN(WARN_UTF8) ?
2202	0 : UNICODE_ALLOW_ANY)
2203	- SvPVX(cat));
2204	}
2205	*SvEND(cat) = '\0';
2206	break;
2207	/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2208	case 'f':
2209	while (len-- > 0) {
2210	fromstr = NEXTFROM;
2211	#ifdef __VOS__
2212	/* VOS does not automatically map a floating-point overflow
2213	during conversion from double to float into infinity, so we
2214	do it by hand. This code should either be generalized for
2215	any OS that needs it, or removed if and when VOS implements
2216	posix-976 (suggestion to support mapping to infinity).
2217	Paul.Green@stratus.com 02-04-02. */
2218	if (SvNV(fromstr) > FLT_MAX)
2219	afloat = _float_constants[0]; /* single prec. inf. */
2220	else if (SvNV(fromstr) < -FLT_MAX)
2221	afloat = _float_constants[0]; /* single prec. inf. */
2222	else afloat = (float)SvNV(fromstr);
2223	#else
2224	# if defined(VMS) && !defined(__IEEE_FP)
2225	/* IEEE fp overflow shenanigans are unavailable on VAX and optional
2226	* on Alpha; fake it if we don't have them.
2227	*/
2228	if (SvNV(fromstr) > FLT_MAX)
2229	afloat = FLT_MAX;
2230	else if (SvNV(fromstr) < -FLT_MAX)
2231	afloat = -FLT_MAX;
2232	else afloat = (float)SvNV(fromstr);
2233	# else
2234	afloat = (float)SvNV(fromstr);
2235	# endif
2236	#endif
2237	sv_catpvn(cat, (char *)&afloat, sizeof (float));
2238	}
2239	break;
2240	case 'd':
2241	while (len-- > 0) {
2242	fromstr = NEXTFROM;
2243	#ifdef __VOS__
2244	/* VOS does not automatically map a floating-point overflow
2245	during conversion from long double to double into infinity,
2246	so we do it by hand. This code should either be generalized
2247	for any OS that needs it, or removed if and when VOS
2248	implements posix-976 (suggestion to support mapping to
2249	infinity). Paul.Green@stratus.com 02-04-02. */
2250	if (SvNV(fromstr) > DBL_MAX)
2251	adouble = _double_constants[0]; /* double prec. inf. */
2252	else if (SvNV(fromstr) < -DBL_MAX)
2253	adouble = _double_constants[0]; /* double prec. inf. */
2254	else adouble = (double)SvNV(fromstr);
2255	#else
2256	# if defined(VMS) && !defined(__IEEE_FP)
2257	/* IEEE fp overflow shenanigans are unavailable on VAX and optional
2258	* on Alpha; fake it if we don't have them.
2259	*/
2260	if (SvNV(fromstr) > DBL_MAX)
2261	adouble = DBL_MAX;
2262	else if (SvNV(fromstr) < -DBL_MAX)
2263	adouble = -DBL_MAX;
2264	else adouble = (double)SvNV(fromstr);
2265	# else
2266	adouble = (double)SvNV(fromstr);
2267	# endif
2268	#endif
2269	sv_catpvn(cat, (char *)&adouble, sizeof (double));
2270	}
2271	break;
2272	case 'F':
2273	while (len-- > 0) {
2274	fromstr = NEXTFROM;
2275	anv = SvNV(fromstr);
2276	sv_catpvn(cat, (char *)&anv, NVSIZE);
2277	}
2278	break;
2279	#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2280	case 'D':
2281	while (len-- > 0) {
2282	fromstr = NEXTFROM;
2283	aldouble = (long double)SvNV(fromstr);
2284	sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2285	}
2286	break;
2287	#endif
2288	case 'n':
2289	while (len-- > 0) {
2290	fromstr = NEXTFROM;
2291	ashort = (I16)SvIV(fromstr);
2292	#ifdef HAS_HTONS
2293	ashort = PerlSock_htons(ashort);
2294	#endif
2295	CAT16(cat, &ashort);
2296	}
2297	break;
2298	case 'v':
2299	while (len-- > 0) {
2300	fromstr = NEXTFROM;
2301	ashort = (I16)SvIV(fromstr);
2302	#ifdef HAS_HTOVS
2303	ashort = htovs(ashort);
2304	#endif
2305	CAT16(cat, &ashort);
2306	}
2307	break;
2308	case 'S' \| TYPE_IS_SHRIEKING:
2309	#if SHORTSIZE != SIZE16
2310	{
2311	unsigned short aushort;
2312
2313	while (len-- > 0) {
2314	fromstr = NEXTFROM;
2315	aushort = SvUV(fromstr);
2316	sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2317	}
2318	}
2319	break;
2320	#else
2321	/* Fall through! */
2322	#endif
2323	case 'S':
2324	{
2325	U16 aushort;
2326
2327	while (len-- > 0) {
2328	fromstr = NEXTFROM;
2329	aushort = (U16)SvUV(fromstr);
2330	CAT16(cat, &aushort);
2331	}
2332
2333	}
2334	break;
2335	case 's' \| TYPE_IS_SHRIEKING:
2336	#if SHORTSIZE != SIZE16
2337	{
2338	short ashort;
2339
2340	while (len-- > 0) {
2341	fromstr = NEXTFROM;
2342	ashort = SvIV(fromstr);
2343	sv_catpvn(cat, (char *)&ashort, sizeof(short));
2344	}
2345	}
2346	break;
2347	#else
2348	/* Fall through! */
2349	#endif
2350	case 's':
2351	while (len-- > 0) {
2352	fromstr = NEXTFROM;
2353	ashort = (I16)SvIV(fromstr);
2354	CAT16(cat, &ashort);
2355	}
2356	break;
2357	case 'I':
2358	case 'I' \| TYPE_IS_SHRIEKING:
2359	while (len-- > 0) {
2360	fromstr = NEXTFROM;
2361	auint = SvUV(fromstr);
2362	sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2363	}
2364	break;
2365	case 'j':
2366	while (len-- > 0) {
2367	fromstr = NEXTFROM;
2368	aiv = SvIV(fromstr);
2369	sv_catpvn(cat, (char*)&aiv, IVSIZE);
2370	}
2371	break;
2372	case 'J':
2373	while (len-- > 0) {
2374	fromstr = NEXTFROM;
2375	auv = SvUV(fromstr);
2376	sv_catpvn(cat, (char*)&auv, UVSIZE);
2377	}
2378	break;
2379	case 'w':
2380	while (len-- > 0) {
2381	fromstr = NEXTFROM;
2382	anv = SvNV(fromstr);
2383
2384	if (anv < 0)
2385	Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2386
2387	/* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2388	which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2389	any negative IVs will have already been got by the croak()
2390	above. IOK is untrue for fractions, so we test them
2391	against UV_MAX_P1. */
2392	if (SvIOK(fromstr) \|\| anv < UV_MAX_P1)
2393	{
2394	char buf[(sizeof(UV)*8)/7+1];
2395	char *in = buf + sizeof(buf);
2396	UV auv = SvUV(fromstr);
2397
2398	do {
2399	*--in = (char)((auv & 0x7f) \| 0x80);
2400	auv >>= 7;
2401	} while (auv);
2402	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2403	sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2404	}
2405	else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2406	char from, result, *in;
2407	SV *norm;
2408	STRLEN len;
2409	bool done;
2410
2411	/* Copy string and check for compliance */
2412	from = SvPV(fromstr, len);
2413	if ((norm = is_an_int(from, len)) == NULL)
2414	Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2415
2416	New('w', result, len, char);
2417	in = result + len;
2418	done = FALSE;
2419	while (!done)
2420	*--in = div128(norm, &done) \| 0x80;
2421	result[len - 1] &= 0x7F; /* clear continue bit */
2422	sv_catpvn(cat, in, (result + len) - in);
2423	Safefree(result);
2424	SvREFCNT_dec(norm); /* free norm */
2425	}
2426	else if (SvNOKp(fromstr)) {
2427	/* 10**NV_MAX_10_EXP is the largest power of 10
2428	so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2429	given 10(NV_MAX_10_EXP+1) == 128 x solve for x:
2430	x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2431	And with that many bytes only Inf can overflow.
2432	*/
2433	#ifdef NV_MAX_10_EXP
2434	char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)];
2435	#else
2436	char buf[1 + (int)((308 + 1) * 0.47456)];
2437	#endif
2438	char *in = buf + sizeof(buf);
2439
2440	anv = Perl_floor(anv);
2441	do {
2442	NV next = Perl_floor(anv / 128);
2443	if (in <= buf) /* this cannot happen ;-) */
2444	Perl_croak(aTHX_ "Cannot compress integer in pack");
2445	--in = (unsigned char)(anv - (next 128)) \| 0x80;
2446	anv = next;
2447	} while (anv > 0);
2448	buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2449	sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2450	}
2451	else {
2452	char from, result, *in;
2453	SV *norm;
2454	STRLEN len;
2455	bool done;
2456
2457	/* Copy string and check for compliance */
2458	from = SvPV(fromstr, len);
2459	if ((norm = is_an_int(from, len)) == NULL)
2460	Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2461
2462	New('w', result, len, char);
2463	in = result + len;
2464	done = FALSE;
2465	while (!done)
2466	*--in = div128(norm, &done) \| 0x80;
2467	result[len - 1] &= 0x7F; /* clear continue bit */
2468	sv_catpvn(cat, in, (result + len) - in);
2469	Safefree(result);
2470	SvREFCNT_dec(norm); /* free norm */
2471	}
2472	}
2473	break;
2474	case 'i':
2475	case 'i' \| TYPE_IS_SHRIEKING:
2476	while (len-- > 0) {
2477	fromstr = NEXTFROM;
2478	aint = SvIV(fromstr);
2479	sv_catpvn(cat, (char*)&aint, sizeof(int));
2480	}
2481	break;
2482	case 'N':
2483	while (len-- > 0) {
2484	fromstr = NEXTFROM;
2485	aulong = SvUV(fromstr);
2486	#ifdef HAS_HTONL
2487	aulong = PerlSock_htonl(aulong);
2488	#endif
2489	CAT32(cat, &aulong);
2490	}
2491	break;
2492	case 'V':
2493	while (len-- > 0) {
2494	fromstr = NEXTFROM;
2495	aulong = SvUV(fromstr);
2496	#ifdef HAS_HTOVL
2497	aulong = htovl(aulong);
2498	#endif
2499	CAT32(cat, &aulong);
2500	}
2501	break;
2502	case 'L' \| TYPE_IS_SHRIEKING:
2503	#if LONGSIZE != SIZE32
2504	{
2505	unsigned long aulong;
2506
2507	while (len-- > 0) {
2508	fromstr = NEXTFROM;
2509	aulong = SvUV(fromstr);
2510	sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2511	}
2512	}
2513	break;
2514	#else
2515	/* Fall though! */
2516	#endif
2517	case 'L':
2518	{
2519	while (len-- > 0) {
2520	fromstr = NEXTFROM;
2521	aulong = SvUV(fromstr);
2522	CAT32(cat, &aulong);
2523	}
2524	}
2525	break;
2526	case 'l' \| TYPE_IS_SHRIEKING:
2527	#if LONGSIZE != SIZE32
2528	{
2529	long along;
2530
2531	while (len-- > 0) {
2532	fromstr = NEXTFROM;
2533	along = SvIV(fromstr);
2534	sv_catpvn(cat, (char *)&along, sizeof(long));
2535	}
2536	}
2537	break;
2538	#else
2539	/* Fall though! */
2540	#endif
2541	case 'l':
2542	while (len-- > 0) {
2543	fromstr = NEXTFROM;
2544	along = SvIV(fromstr);
2545	CAT32(cat, &along);
2546	}
2547	break;
2548	#ifdef HAS_QUAD
2549	case 'Q':
2550	while (len-- > 0) {
2551	fromstr = NEXTFROM;
2552	auquad = (Uquad_t)SvUV(fromstr);
2553	sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2554	}
2555	break;
2556	case 'q':
2557	while (len-- > 0) {
2558	fromstr = NEXTFROM;
2559	aquad = (Quad_t)SvIV(fromstr);
2560	sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2561	}
2562	break;
2563	#endif
2564	case 'P':
2565	len = 1; /* assume SV is correct length */
2566	/* Fall through! */
2567	case 'p':
2568	while (len-- > 0) {
2569	fromstr = NEXTFROM;
2570	if (fromstr == &PL_sv_undef)
2571	aptr = NULL;
2572	else {
2573	STRLEN n_a;
2574	/* XXX better yet, could spirit away the string to
2575	* a safe spot and hang on to it until the result
2576	* of pack() (and all copies of the result) are
2577	* gone.
2578	*/
2579	if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2580	\|\| (SvPADTMP(fromstr)
2581	&& !SvREADONLY(fromstr))))
2582	{
2583	Perl_warner(aTHX_ packWARN(WARN_PACK),
2584	"Attempt to pack pointer to temporary value");
2585	}
2586	if (SvPOK(fromstr) \|\| SvNIOK(fromstr))
2587	aptr = SvPV(fromstr,n_a);
2588	else
2589	aptr = SvPV_force(fromstr,n_a);
2590	}
2591	sv_catpvn(cat, (char)&aptr, sizeof(char));
2592	}
2593	break;
2594	case 'u':
2595	fromstr = NEXTFROM;
2596	aptr = SvPV(fromstr, fromlen);
2597	SvGROW(cat, fromlen * 4 / 3);
2598	if (len <= 2)
2599	len = 45;
2600	else
2601	len = len / 3 * 3;
2602	while (fromlen > 0) {
2603	I32 todo;
2604
2605	if ((I32)fromlen > len)
2606	todo = len;
2607	else
2608	todo = fromlen;
2609	doencodes(cat, aptr, todo);
2610	fromlen -= todo;
2611	aptr += todo;
2612	}
2613	break;
2614	}
2615	*symptr = lookahead;
2616	}
2617	return beglist;
2618	}
2619	#undef NEXTFROM
2620
2621
2622	PP(pp_pack)
2623	{
2624	dSP; dMARK; dORIGMARK; dTARGET;
2625	register SV *cat = TARG;
2626	STRLEN fromlen;
2627	register char pat = SvPVx(++MARK, fromlen);
2628	register char *patend = pat + fromlen;
2629
2630	MARK++;
2631	sv_setpvn(cat, "", 0);
2632
2633	packlist(cat, pat, patend, MARK, SP + 1);
2634
2635	SvSETMAGIC(cat);
2636	SP = ORIGMARK;
2637	PUSHs(cat);
2638	RETURN;
2639	}
2640

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/third/perl/pp_pack.c @ 20075

Download in other formats: