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