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