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