This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactor all the unpack checksum-or-not logic to avoid massive
[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;
834 sv = NEWSV(35, len);
835 sv_setpvn(sv, s, len);
49704364 836 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
a6ec74c1
JH
837 aptr = s; /* borrow register */
838 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
839 s = SvPVX(sv);
840 while (*s)
841 s++;
49704364 842 if (howlen == e_star) /* exact for 'Z*' */
d50dd4e4 843 len = s - SvPVX(sv) + 1;
a6ec74c1
JH
844 }
845 else { /* 'A' strips both nulls and spaces */
846 s = SvPVX(sv) + len - 1;
847 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
848 s--;
849 *++s = '\0';
850 }
851 SvCUR_set(sv, s - SvPVX(sv));
852 s = aptr; /* unborrow register */
853 }
d50dd4e4 854 s += len;
a6ec74c1
JH
855 XPUSHs(sv_2mortal(sv));
856 break;
857 case 'B':
858 case 'b':
49704364 859 if (howlen == e_star || len > (strend - s) * 8)
a6ec74c1
JH
860 len = (strend - s) * 8;
861 if (checksum) {
862 if (!PL_bitcount) {
863 Newz(601, PL_bitcount, 256, char);
864 for (bits = 1; bits < 256; bits++) {
865 if (bits & 1) PL_bitcount[bits]++;
866 if (bits & 2) PL_bitcount[bits]++;
867 if (bits & 4) PL_bitcount[bits]++;
868 if (bits & 8) PL_bitcount[bits]++;
869 if (bits & 16) PL_bitcount[bits]++;
870 if (bits & 32) PL_bitcount[bits]++;
871 if (bits & 64) PL_bitcount[bits]++;
872 if (bits & 128) PL_bitcount[bits]++;
873 }
874 }
875 while (len >= 8) {
92d41999 876 cuv += PL_bitcount[*(unsigned char*)s++];
a6ec74c1
JH
877 len -= 8;
878 }
879 if (len) {
880 bits = *s;
881 if (datumtype == 'b') {
882 while (len-- > 0) {
92d41999 883 if (bits & 1) cuv++;
a6ec74c1
JH
884 bits >>= 1;
885 }
886 }
887 else {
888 while (len-- > 0) {
92d41999 889 if (bits & 128) cuv++;
a6ec74c1
JH
890 bits <<= 1;
891 }
892 }
893 }
894 break;
895 }
896 sv = NEWSV(35, len + 1);
897 SvCUR_set(sv, len);
898 SvPOK_on(sv);
899 str = SvPVX(sv);
900 if (datumtype == 'b') {
901 aint = len;
902 for (len = 0; len < aint; len++) {
903 if (len & 7) /*SUPPRESS 595*/
904 bits >>= 1;
905 else
906 bits = *s++;
907 *str++ = '0' + (bits & 1);
908 }
909 }
910 else {
911 aint = len;
912 for (len = 0; len < aint; len++) {
913 if (len & 7)
914 bits <<= 1;
915 else
916 bits = *s++;
917 *str++ = '0' + ((bits & 128) != 0);
918 }
919 }
920 *str = '\0';
921 XPUSHs(sv_2mortal(sv));
922 break;
923 case 'H':
924 case 'h':
49704364 925 if (howlen == e_star || len > (strend - s) * 2)
a6ec74c1
JH
926 len = (strend - s) * 2;
927 sv = NEWSV(35, len + 1);
928 SvCUR_set(sv, len);
929 SvPOK_on(sv);
930 str = SvPVX(sv);
931 if (datumtype == 'h') {
932 aint = len;
933 for (len = 0; len < aint; len++) {
934 if (len & 1)
935 bits >>= 4;
936 else
937 bits = *s++;
938 *str++ = PL_hexdigit[bits & 15];
939 }
940 }
941 else {
942 aint = len;
943 for (len = 0; len < aint; len++) {
944 if (len & 1)
945 bits <<= 4;
946 else
947 bits = *s++;
948 *str++ = PL_hexdigit[(bits >> 4) & 15];
949 }
950 }
951 *str = '\0';
952 XPUSHs(sv_2mortal(sv));
953 break;
954 case 'c':
955 if (len > strend - s)
956 len = strend - s;
73cb7263 957 if (!checksum) {
49704364 958 if (len && unpack_only_one)
c8f824eb 959 len = 1;
a6ec74c1
JH
960 EXTEND(SP, len);
961 EXTEND_MORTAL(len);
73cb7263
NC
962 }
963 while (len-- > 0) {
964 aint = *s++;
965 if (aint >= 128) /* fake up signed chars */
966 aint -= 256;
967 if (!checksum) {
a6ec74c1
JH
968 sv = NEWSV(36, 0);
969 sv_setiv(sv, (IV)aint);
970 PUSHs(sv_2mortal(sv));
971 }
73cb7263
NC
972 else if (checksum > bits_in_uv)
973 cdouble += (NV)aint;
974 else
975 cuv += aint;
a6ec74c1
JH
976 }
977 break;
978 case 'C':
35bcd338
JH
979 unpack_C: /* unpack U will jump here if not UTF-8 */
980 if (len == 0) {
49704364 981 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
35bcd338
JH
982 break;
983 }
a6ec74c1
JH
984 if (len > strend - s)
985 len = strend - s;
986 if (checksum) {
987 uchar_checksum:
988 while (len-- > 0) {
989 auint = *s++ & 255;
92d41999 990 cuv += auint;
a6ec74c1
JH
991 }
992 }
993 else {
49704364 994 if (len && unpack_only_one)
c8f824eb 995 len = 1;
a6ec74c1
JH
996 EXTEND(SP, len);
997 EXTEND_MORTAL(len);
998 while (len-- > 0) {
999 auint = *s++ & 255;
1000 sv = NEWSV(37, 0);
1001 sv_setiv(sv, (IV)auint);
1002 PUSHs(sv_2mortal(sv));
1003 }
1004 }
1005 break;
1006 case 'U':
35bcd338 1007 if (len == 0) {
49704364 1008 symptr->flags |= FLAG_UNPACK_DO_UTF8;
35bcd338
JH
1009 break;
1010 }
49704364 1011 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
35bcd338 1012 goto unpack_C;
a6ec74c1
JH
1013 if (len > strend - s)
1014 len = strend - s;
73cb7263
NC
1015 if (!checksum) {
1016 if (len && unpack_only_one)
c8f824eb 1017 len = 1;
a6ec74c1
JH
1018 EXTEND(SP, len);
1019 EXTEND_MORTAL(len);
73cb7263
NC
1020 }
1021 while (len-- > 0 && s < strend) {
1022 STRLEN alen;
1023 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1024 along = alen;
1025 s += along;
1026 if (!checksum) {
a6ec74c1
JH
1027 sv = NEWSV(37, 0);
1028 sv_setuv(sv, (UV)auint);
1029 PUSHs(sv_2mortal(sv));
1030 }
73cb7263
NC
1031 else if (checksum > bits_in_uv)
1032 cdouble += (NV)auint;
1033 else
1034 cuv += auint;
a6ec74c1
JH
1035 }
1036 break;
49704364
LW
1037 case 's' | TYPE_IS_SHRIEKING:
1038#if SHORTSIZE != SIZE16
1039 along = (strend - s) / sizeof(short);
a6ec74c1
JH
1040 if (len > along)
1041 len = along;
73cb7263 1042 if (!checksum) {
49704364
LW
1043 if (len && unpack_only_one)
1044 len = 1;
1045 EXTEND(SP, len);
1046 EXTEND_MORTAL(len);
73cb7263
NC
1047 }
1048 while (len-- > 0) {
1049 COPYNN(s, &ashort, sizeof(short));
1050 DO_BO_UNPACK(ashort, s);
1051 s += sizeof(short);
1052 if (!checksum) {
49704364
LW
1053 sv = NEWSV(38, 0);
1054 sv_setiv(sv, (IV)ashort);
1055 PUSHs(sv_2mortal(sv));
1056 }
73cb7263
NC
1057 else if (checksum > bits_in_uv)
1058 cdouble += (NV)ashort;
1059 else
1060 cuv += ashort;
49704364
LW
1061 }
1062 break;
1063#else
1064 /* Fallthrough! */
a6ec74c1 1065#endif
49704364
LW
1066 case 's':
1067 along = (strend - s) / SIZE16;
1068 if (len > along)
1069 len = along;
73cb7263 1070 if (!checksum) {
49704364 1071 if (len && unpack_only_one)
c8f824eb 1072 len = 1;
a6ec74c1
JH
1073 EXTEND(SP, len);
1074 EXTEND_MORTAL(len);
73cb7263
NC
1075 }
1076 while (len-- > 0) {
1077 COPY16(s, &ai16);
1078 DO_BO_UNPACK(ai16, 16);
1109a392 1079#if U16SIZE > SIZE16
73cb7263
NC
1080 if (ai16 > 32767)
1081 ai16 -= 65536;
a6ec74c1 1082#endif
73cb7263
NC
1083 s += SIZE16;
1084 if (!checksum) {
49704364 1085 sv = NEWSV(38, 0);
ef108786 1086 sv_setiv(sv, (IV)ai16);
49704364 1087 PUSHs(sv_2mortal(sv));
a6ec74c1 1088 }
73cb7263
NC
1089 else if (checksum > bits_in_uv)
1090 cdouble += (NV)ai16;
1091 else
1092 cuv += ai16;
a6ec74c1
JH
1093 }
1094 break;
49704364
LW
1095 case 'S' | TYPE_IS_SHRIEKING:
1096#if SHORTSIZE != SIZE16
7accc089 1097 along = (strend - s) / sizeof(unsigned short);
49704364
LW
1098 if (len > along)
1099 len = along;
73cb7263
NC
1100 if (!checksum) {
1101 if (len && unpack_only_one)
49704364
LW
1102 len = 1;
1103 EXTEND(SP, len);
1104 EXTEND_MORTAL(len);
73cb7263
NC
1105 }
1106 while (len-- > 0) {
1107 COPYNN(s, &aushort, sizeof(unsigned short));
1108 DO_BO_UNPACK(aushort, s);
1109 s += sizeof(unsigned short);
1110 if (!checksum) {
49704364
LW
1111 sv = NEWSV(39, 0);
1112 sv_setiv(sv, (UV)aushort);
1113 PUSHs(sv_2mortal(sv));
1114 }
73cb7263
NC
1115 else if (checksum > bits_in_uv)
1116 cdouble += (NV)aushort;
1117 else
1118 cuv += aushort;
49704364
LW
1119 }
1120 break;
1121#else
1122 /* Fallhrough! */
1123#endif
a6ec74c1
JH
1124 case 'v':
1125 case 'n':
1126 case 'S':
a6ec74c1 1127 along = (strend - s) / SIZE16;
a6ec74c1
JH
1128 if (len > along)
1129 len = along;
73cb7263 1130 if (!checksum) {
49704364 1131 if (len && unpack_only_one)
c8f824eb 1132 len = 1;
a6ec74c1
JH
1133 EXTEND(SP, len);
1134 EXTEND_MORTAL(len);
73cb7263
NC
1135 }
1136 while (len-- > 0) {
1137 COPY16(s, &au16);
1138 DO_BO_UNPACK(au16, 16);
1139 s += SIZE16;
a6ec74c1 1140#ifdef HAS_NTOHS
73cb7263
NC
1141 if (datumtype == 'n')
1142 au16 = PerlSock_ntohs(au16);
a6ec74c1
JH
1143#endif
1144#ifdef HAS_VTOHS
73cb7263
NC
1145 if (datumtype == 'v')
1146 au16 = vtohs(au16);
a6ec74c1 1147#endif
73cb7263
NC
1148 if (!checksum) {
1149 sv = NEWSV(39, 0);
ef108786 1150 sv_setiv(sv, (UV)au16);
49704364 1151 PUSHs(sv_2mortal(sv));
a6ec74c1 1152 }
73cb7263
NC
1153 else if (checksum > bits_in_uv)
1154 cdouble += (NV)au16;
1155 else
1156 cuv += au16;
a6ec74c1
JH
1157 }
1158 break;
068bd2e7
MHM
1159 case 'v' | TYPE_IS_SHRIEKING:
1160 case 'n' | TYPE_IS_SHRIEKING:
1161 along = (strend - s) / SIZE16;
1162 if (len > along)
1163 len = along;
73cb7263 1164 if (!checksum) {
068bd2e7
MHM
1165 if (len && unpack_only_one)
1166 len = 1;
1167 EXTEND(SP, len);
1168 EXTEND_MORTAL(len);
73cb7263
NC
1169 }
1170 while (len-- > 0) {
1171 COPY16(s, &ai16);
1172 s += SIZE16;
068bd2e7 1173#ifdef HAS_NTOHS
73cb7263
NC
1174 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1175 ai16 = (I16)PerlSock_ntohs((U16)ai16);
068bd2e7
MHM
1176#endif
1177#ifdef HAS_VTOHS
73cb7263
NC
1178 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1179 ai16 = (I16)vtohs((U16)ai16);
068bd2e7 1180#endif
73cb7263 1181 if (!checksum) {
068bd2e7 1182 sv = NEWSV(39, 0);
ef108786 1183 sv_setiv(sv, (IV)ai16);
068bd2e7
MHM
1184 PUSHs(sv_2mortal(sv));
1185 }
73cb7263
NC
1186 else if (checksum > bits_in_uv)
1187 cdouble += (NV)ai16;
1188 else
1189 cuv += ai16;
068bd2e7
MHM
1190 }
1191 break;
a6ec74c1 1192 case 'i':
49704364 1193 case 'i' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
1194 along = (strend - s) / sizeof(int);
1195 if (len > along)
1196 len = along;
73cb7263 1197 if (!checksum) {
49704364 1198 if (len && unpack_only_one)
c8f824eb 1199 len = 1;
a6ec74c1
JH
1200 EXTEND(SP, len);
1201 EXTEND_MORTAL(len);
73cb7263
NC
1202 }
1203 while (len-- > 0) {
1204 Copy(s, &aint, 1, int);
1205 DO_BO_UNPACK(aint, i);
1206 s += sizeof(int);
1207 if (!checksum) {
a6ec74c1
JH
1208 sv = NEWSV(40, 0);
1209#ifdef __osf__
1210 /* Without the dummy below unpack("i", pack("i",-1))
1211 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1212 * cc with optimization turned on.
1213 *
1214 * The bug was detected in
1215 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1216 * with optimization (-O4) turned on.
1217 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1218 * does not have this problem even with -O4.
1219 *
1220 * This bug was reported as DECC_BUGS 1431
1221 * and tracked internally as GEM_BUGS 7775.
1222 *
1223 * The bug is fixed in
1224 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1225 * UNIX V4.0F support: DEC C V5.9-006 or later
1226 * UNIX V4.0E support: DEC C V5.8-011 or later
1227 * and also in DTK.
1228 *
1229 * See also few lines later for the same bug.
1230 */
1231 (aint) ?
1232 sv_setiv(sv, (IV)aint) :
1233#endif
73cb7263 1234 sv_setiv(sv, (IV)aint);
a6ec74c1
JH
1235 PUSHs(sv_2mortal(sv));
1236 }
73cb7263
NC
1237 else if (checksum > bits_in_uv)
1238 cdouble += (NV)aint;
1239 else
1240 cuv += aint;
a6ec74c1
JH
1241 }
1242 break;
1243 case 'I':
49704364 1244 case 'I' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
1245 along = (strend - s) / sizeof(unsigned int);
1246 if (len > along)
1247 len = along;
73cb7263 1248 if (!checksum) {
49704364 1249 if (len && unpack_only_one)
c8f824eb 1250 len = 1;
a6ec74c1
JH
1251 EXTEND(SP, len);
1252 EXTEND_MORTAL(len);
73cb7263
NC
1253 }
1254 while (len-- > 0) {
1255 Copy(s, &auint, 1, unsigned int);
1256 DO_BO_UNPACK(auint, i);
1257 s += sizeof(unsigned int);
1258 if (!checksum) {
a6ec74c1
JH
1259 sv = NEWSV(41, 0);
1260#ifdef __osf__
1261 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1262 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1263 * See details few lines earlier. */
1264 (auint) ?
1265 sv_setuv(sv, (UV)auint) :
1266#endif
1267 sv_setuv(sv, (UV)auint);
1268 PUSHs(sv_2mortal(sv));
1269 }
73cb7263
NC
1270 else if (checksum > bits_in_uv)
1271 cdouble += (NV)auint;
1272 else
1273 cuv += auint;
a6ec74c1
JH
1274 }
1275 break;
92d41999
JH
1276 case 'j':
1277 along = (strend - s) / IVSIZE;
1278 if (len > along)
1279 len = along;
73cb7263 1280 if (!checksum) {
49704364 1281 if (len && unpack_only_one)
c8f824eb 1282 len = 1;
92d41999
JH
1283 EXTEND(SP, len);
1284 EXTEND_MORTAL(len);
73cb7263
NC
1285 }
1286 while (len-- > 0) {
1287 Copy(s, &aiv, 1, IV);
1109a392 1288#if IVSIZE == INTSIZE
73cb7263 1289 DO_BO_UNPACK(aiv, i);
1109a392 1290#elif IVSIZE == LONGSIZE
73cb7263 1291 DO_BO_UNPACK(aiv, l);
1109a392 1292#elif defined(HAS_QUAD) && IVSIZE == U64SIZE
73cb7263 1293 DO_BO_UNPACK(aiv, 64);
1109a392 1294#endif
73cb7263
NC
1295 s += IVSIZE;
1296 if (!checksum) {
92d41999
JH
1297 sv = NEWSV(40, 0);
1298 sv_setiv(sv, aiv);
1299 PUSHs(sv_2mortal(sv));
1300 }
73cb7263
NC
1301 else if (checksum > bits_in_uv)
1302 cdouble += (NV)aiv;
1303 else
1304 cuv += aiv;
92d41999
JH
1305 }
1306 break;
1307 case 'J':
1308 along = (strend - s) / UVSIZE;
1309 if (len > along)
1310 len = along;
73cb7263 1311 if (!checksum) {
49704364 1312 if (len && unpack_only_one)
c8f824eb 1313 len = 1;
92d41999
JH
1314 EXTEND(SP, len);
1315 EXTEND_MORTAL(len);
73cb7263
NC
1316 }
1317 while (len-- > 0) {
1318 Copy(s, &auv, 1, UV);
1109a392 1319#if UVSIZE == INTSIZE
73cb7263 1320 DO_BO_UNPACK(auv, i);
1109a392 1321#elif UVSIZE == LONGSIZE
73cb7263 1322 DO_BO_UNPACK(auv, l);
1109a392 1323#elif defined(HAS_QUAD) && UVSIZE == U64SIZE
73cb7263 1324 DO_BO_UNPACK(auv, 64);
1109a392 1325#endif
73cb7263
NC
1326 s += UVSIZE;
1327 if (!checksum) {
92d41999
JH
1328 sv = NEWSV(41, 0);
1329 sv_setuv(sv, auv);
1330 PUSHs(sv_2mortal(sv));
1331 }
73cb7263
NC
1332 else if (checksum > bits_in_uv)
1333 cdouble += (NV)auv;
1334 else
1335 cuv += auv;
92d41999
JH
1336 }
1337 break;
49704364
LW
1338 case 'l' | TYPE_IS_SHRIEKING:
1339#if LONGSIZE != SIZE32
1340 along = (strend - s) / sizeof(long);
a6ec74c1
JH
1341 if (len > along)
1342 len = along;
73cb7263 1343 if (!checksum) {
49704364
LW
1344 if (len && unpack_only_one)
1345 len = 1;
1346 EXTEND(SP, len);
1347 EXTEND_MORTAL(len);
73cb7263
NC
1348 }
1349 while (len-- > 0) {
1350 COPYNN(s, &along, sizeof(long));
1351 DO_BO_UNPACK(along, l);
1352 s += sizeof(long);
1353 if (!checksum) {
49704364
LW
1354 sv = NEWSV(42, 0);
1355 sv_setiv(sv, (IV)along);
1356 PUSHs(sv_2mortal(sv));
1357 }
73cb7263
NC
1358 else if (checksum > bits_in_uv)
1359 cdouble += (NV)along;
1360 else
1361 cuv += along;
49704364
LW
1362 }
1363 break;
1364#else
1365 /* Fallthrough! */
a6ec74c1 1366#endif
49704364
LW
1367 case 'l':
1368 along = (strend - s) / SIZE32;
1369 if (len > along)
1370 len = along;
73cb7263 1371 if (!checksum) {
49704364 1372 if (len && unpack_only_one)
c8f824eb 1373 len = 1;
a6ec74c1
JH
1374 EXTEND(SP, len);
1375 EXTEND_MORTAL(len);
73cb7263
NC
1376 }
1377 while (len-- > 0) {
1378 COPY32(s, &ai32);
1379 DO_BO_UNPACK(ai32, 32);
25a9bd2a 1380#if U32SIZE > SIZE32
73cb7263
NC
1381 if (ai32 > 2147483647)
1382 ai32 -= 4294967296;
a6ec74c1 1383#endif
73cb7263
NC
1384 s += SIZE32;
1385 if (!checksum) {
49704364 1386 sv = NEWSV(42, 0);
25a9bd2a 1387 sv_setiv(sv, (IV)ai32);
49704364 1388 PUSHs(sv_2mortal(sv));
a6ec74c1 1389 }
73cb7263
NC
1390 else if (checksum > bits_in_uv)
1391 cdouble += (NV)ai32;
1392 else
1393 cuv += ai32;
a6ec74c1
JH
1394 }
1395 break;
49704364
LW
1396 case 'L' | TYPE_IS_SHRIEKING:
1397#if LONGSIZE != SIZE32
1398 along = (strend - s) / sizeof(unsigned long);
1399 if (len > along)
1400 len = along;
73cb7263 1401 if (!checksum) {
49704364
LW
1402 if (len && unpack_only_one)
1403 len = 1;
1404 EXTEND(SP, len);
1405 EXTEND_MORTAL(len);
73cb7263
NC
1406 }
1407 while (len-- > 0) {
1408 COPYNN(s, &aulong, sizeof(unsigned long));
1409 DO_BO_UNPACK(aulong, l);
1410 s += sizeof(unsigned long);
1411 if (!checksum) {
49704364
LW
1412 sv = NEWSV(43, 0);
1413 sv_setuv(sv, (UV)aulong);
1414 PUSHs(sv_2mortal(sv));
1415 }
73cb7263
NC
1416 else if (checksum > bits_in_uv)
1417 cdouble += (NV)aulong;
1418 else
1419 cuv += aulong;
49704364
LW
1420 }
1421 break;
1422#else
1423 /* Fall through! */
1424#endif
a6ec74c1
JH
1425 case 'V':
1426 case 'N':
1427 case 'L':
a6ec74c1 1428 along = (strend - s) / SIZE32;
a6ec74c1
JH
1429 if (len > along)
1430 len = along;
73cb7263 1431 if (!checksum) {
49704364 1432 if (len && unpack_only_one)
c8f824eb 1433 len = 1;
a6ec74c1
JH
1434 EXTEND(SP, len);
1435 EXTEND_MORTAL(len);
73cb7263
NC
1436 }
1437 while (len-- > 0) {
1438 COPY32(s, &au32);
1439 DO_BO_UNPACK(au32, 32);
1440 s += SIZE32;
a6ec74c1 1441#ifdef HAS_NTOHL
73cb7263
NC
1442 if (datumtype == 'N')
1443 au32 = PerlSock_ntohl(au32);
a6ec74c1
JH
1444#endif
1445#ifdef HAS_VTOHL
73cb7263
NC
1446 if (datumtype == 'V')
1447 au32 = vtohl(au32);
a6ec74c1 1448#endif
73cb7263
NC
1449 if (!checksum) {
1450 sv = NEWSV(43, 0);
1451 sv_setuv(sv, (UV)au32);
1452 PUSHs(sv_2mortal(sv));
1453 }
1454 else if (checksum > bits_in_uv)
1455 cdouble += (NV)au32;
1456 else
1457 cuv += au32;
a6ec74c1
JH
1458 }
1459 break;
068bd2e7
MHM
1460 case 'V' | TYPE_IS_SHRIEKING:
1461 case 'N' | TYPE_IS_SHRIEKING:
1462 along = (strend - s) / SIZE32;
1463 if (len > along)
1464 len = along;
73cb7263 1465 if (!checksum) {
068bd2e7
MHM
1466 if (len && unpack_only_one)
1467 len = 1;
1468 EXTEND(SP, len);
1469 EXTEND_MORTAL(len);
73cb7263
NC
1470 }
1471 while (len-- > 0) {
1472 COPY32(s, &ai32);
1473 s += SIZE32;
068bd2e7 1474#ifdef HAS_NTOHL
73cb7263
NC
1475 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1476 ai32 = (I32)PerlSock_ntohl((U32)ai32);
068bd2e7
MHM
1477#endif
1478#ifdef HAS_VTOHL
73cb7263
NC
1479 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1480 ai32 = (I32)vtohl((U32)ai32);
068bd2e7 1481#endif
73cb7263 1482 if (!checksum) {
068bd2e7 1483 sv = NEWSV(43, 0);
ef108786 1484 sv_setiv(sv, (IV)ai32);
068bd2e7
MHM
1485 PUSHs(sv_2mortal(sv));
1486 }
73cb7263
NC
1487 else if (checksum > bits_in_uv)
1488 cdouble += (NV)ai32;
1489 else
1490 cuv += ai32;
068bd2e7
MHM
1491 }
1492 break;
a6ec74c1
JH
1493 case 'p':
1494 along = (strend - s) / sizeof(char*);
1495 if (len > along)
1496 len = along;
1497 EXTEND(SP, len);
1498 EXTEND_MORTAL(len);
1499 while (len-- > 0) {
1500 if (sizeof(char*) > strend - s)
1501 break;
1502 else {
1503 Copy(s, &aptr, 1, char*);
1109a392 1504 DO_BO_UNPACK_P(aptr);
a6ec74c1
JH
1505 s += sizeof(char*);
1506 }
1507 sv = NEWSV(44, 0);
1508 if (aptr)
1509 sv_setpv(sv, aptr);
1510 PUSHs(sv_2mortal(sv));
1511 }
1512 break;
1513 case 'w':
49704364 1514 if (len && unpack_only_one)
c8f824eb 1515 len = 1;
a6ec74c1
JH
1516 EXTEND(SP, len);
1517 EXTEND_MORTAL(len);
1518 {
1519 UV auv = 0;
1520 U32 bytes = 0;
1521
1522 while ((len > 0) && (s < strend)) {
1523 auv = (auv << 7) | (*s & 0x7f);
1524 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1525 if ((U8)(*s++) < 0x80) {
1526 bytes = 0;
1527 sv = NEWSV(40, 0);
1528 sv_setuv(sv, auv);
1529 PUSHs(sv_2mortal(sv));
1530 len--;
1531 auv = 0;
1532 }
1533 else if (++bytes >= sizeof(UV)) { /* promote to string */
1534 char *t;
1535 STRLEN n_a;
1536
1537 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1538 while (s < strend) {
eb160463 1539 sv = mul128(sv, (U8)(*s & 0x7f));
a6ec74c1
JH
1540 if (!(*s++ & 0x80)) {
1541 bytes = 0;
1542 break;
1543 }
1544 }
1545 t = SvPV(sv, n_a);
1546 while (*t == '0')
1547 t++;
1548 sv_chop(sv, t);
1549 PUSHs(sv_2mortal(sv));
1550 len--;
1551 auv = 0;
1552 }
1553 }
1554 if ((s >= strend) && bytes)
49704364 1555 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
a6ec74c1
JH
1556 }
1557 break;
1558 case 'P':
49704364
LW
1559 if (symptr->howlen == e_star)
1560 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
a6ec74c1
JH
1561 EXTEND(SP, 1);
1562 if (sizeof(char*) > strend - s)
1563 break;
1564 else {
1565 Copy(s, &aptr, 1, char*);
1109a392 1566 DO_BO_UNPACK_P(aptr);
a6ec74c1
JH
1567 s += sizeof(char*);
1568 }
1569 sv = NEWSV(44, 0);
1570 if (aptr)
1571 sv_setpvn(sv, aptr, len);
1572 PUSHs(sv_2mortal(sv));
1573 break;
1574#ifdef HAS_QUAD
1575 case 'q':
1576 along = (strend - s) / sizeof(Quad_t);
1577 if (len > along)
1578 len = along;
73cb7263 1579 if (!checksum) {
49704364 1580 if (len && unpack_only_one)
c8f824eb 1581 len = 1;
fa8ec7c1
NC
1582 EXTEND(SP, len);
1583 EXTEND_MORTAL(len);
73cb7263
NC
1584 }
1585 while (len-- > 0) {
1586 if (s + sizeof(Quad_t) > strend) {
1587 /* Surely this should never happen? NWC */
1588 aquad = 0;
1589 }
1590 else {
1591 Copy(s, &aquad, 1, Quad_t);
1592 DO_BO_UNPACK(aquad, 64);
1593 s += sizeof(Quad_t);
1594 }
1595 if (!checksum) {
fa8ec7c1
NC
1596 sv = NEWSV(42, 0);
1597 if (aquad >= IV_MIN && aquad <= IV_MAX)
92d41999 1598 sv_setiv(sv, (IV)aquad);
fa8ec7c1
NC
1599 else
1600 sv_setnv(sv, (NV)aquad);
1601 PUSHs(sv_2mortal(sv));
1602 }
73cb7263
NC
1603 else if (checksum > bits_in_uv)
1604 cdouble += (NV)aquad;
1605 else
1606 cuv += aquad;
1607 }
a6ec74c1
JH
1608 break;
1609 case 'Q':
206947d2 1610 along = (strend - s) / sizeof(Uquad_t);
a6ec74c1
JH
1611 if (len > along)
1612 len = along;
73cb7263
NC
1613 if (!checksum) {
1614 if (len && unpack_only_one)
1615 len = 1;
1616 EXTEND(SP, len);
1617 EXTEND_MORTAL(len);
1618 }
1619 while (len-- > 0) {
1620 if (s + sizeof(Uquad_t) > strend)
1621 auquad = 0;
1622 else {
a6ec74c1 1623 Copy(s, &auquad, 1, Uquad_t);
1109a392 1624 DO_BO_UNPACK(auquad, 64);
a6ec74c1 1625 s += sizeof(Uquad_t);
73cb7263
NC
1626 }
1627 if (!checksum) {
1628 sv = NEWSV(43, 0);
1629 if (auquad <= UV_MAX)
1630 sv_setuv(sv, (UV)auquad);
fa8ec7c1 1631 else
73cb7263
NC
1632 sv_setnv(sv, (NV)auquad);
1633 PUSHs(sv_2mortal(sv));
a6ec74c1 1634 }
73cb7263
NC
1635 else if (checksum > bits_in_uv)
1636 cdouble += (NV)auquad;
1637 else
1638 cuv += auquad;
a6ec74c1
JH
1639 }
1640 break;
1641#endif
1642 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1643 case 'f':
a6ec74c1
JH
1644 along = (strend - s) / sizeof(float);
1645 if (len > along)
1646 len = along;
73cb7263 1647 if (!checksum) {
49704364 1648 if (len && unpack_only_one)
c8f824eb 1649 len = 1;
a6ec74c1
JH
1650 EXTEND(SP, len);
1651 EXTEND_MORTAL(len);
73cb7263
NC
1652 }
1653 while (len-- > 0) {
1654 Copy(s, &afloat, 1, float);
1655 DO_BO_UNPACK_N(afloat, float);
1656 s += sizeof(float);
1657 if (!checksum) {
a6ec74c1
JH
1658 sv = NEWSV(47, 0);
1659 sv_setnv(sv, (NV)afloat);
1660 PUSHs(sv_2mortal(sv));
1661 }
73cb7263
NC
1662 else {
1663 cdouble += afloat;
1664 }
a6ec74c1
JH
1665 }
1666 break;
1667 case 'd':
a6ec74c1
JH
1668 along = (strend - s) / sizeof(double);
1669 if (len > along)
1670 len = along;
73cb7263 1671 if (!checksum) {
49704364 1672 if (len && unpack_only_one)
c8f824eb 1673 len = 1;
a6ec74c1
JH
1674 EXTEND(SP, len);
1675 EXTEND_MORTAL(len);
73cb7263
NC
1676 }
1677 while (len-- > 0) {
1678 Copy(s, &adouble, 1, double);
1679 DO_BO_UNPACK_N(adouble, double);
1680 s += sizeof(double);
1681 if (!checksum) {
a6ec74c1
JH
1682 sv = NEWSV(48, 0);
1683 sv_setnv(sv, (NV)adouble);
1684 PUSHs(sv_2mortal(sv));
1685 }
73cb7263
NC
1686 else {
1687 cdouble += adouble;
1688 }
a6ec74c1
JH
1689 }
1690 break;
92d41999
JH
1691 case 'F':
1692 along = (strend - s) / NVSIZE;
1693 if (len > along)
1694 len = along;
73cb7263 1695 if (!checksum) {
49704364 1696 if (len && unpack_only_one)
c8f824eb 1697 len = 1;
92d41999
JH
1698 EXTEND(SP, len);
1699 EXTEND_MORTAL(len);
73cb7263
NC
1700 }
1701 while (len-- > 0) {
1702 Copy(s, &anv, 1, NV);
1703 DO_BO_UNPACK_N(anv, NV);
1704 s += NVSIZE;
1705 if (!checksum) {
92d41999
JH
1706 sv = NEWSV(48, 0);
1707 sv_setnv(sv, anv);
1708 PUSHs(sv_2mortal(sv));
1709 }
73cb7263
NC
1710 else {
1711 cdouble += anv;
1712 }
92d41999
JH
1713 }
1714 break;
1715#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1716 case 'D':
1717 along = (strend - s) / LONG_DOUBLESIZE;
1718 if (len > along)
1719 len = along;
73cb7263 1720 if (!checksum) {
49704364 1721 if (len && unpack_only_one)
c8f824eb 1722 len = 1;
92d41999
JH
1723 EXTEND(SP, len);
1724 EXTEND_MORTAL(len);
73cb7263
NC
1725 }
1726 while (len-- > 0) {
1727 Copy(s, &aldouble, 1, long double);
1728 DO_BO_UNPACK_N(aldouble, long double);
1729 s += LONG_DOUBLESIZE;
1730 if (!checksum) {
92d41999
JH
1731 sv = NEWSV(48, 0);
1732 sv_setnv(sv, (NV)aldouble);
1733 PUSHs(sv_2mortal(sv));
1734 }
73cb7263
NC
1735 else {cdouble += aldouble;
1736 }
92d41999
JH
1737 }
1738 break;
1739#endif
a6ec74c1
JH
1740 case 'u':
1741 /* MKS:
1742 * Initialise the decode mapping. By using a table driven
1743 * algorithm, the code will be character-set independent
1744 * (and just as fast as doing character arithmetic)
1745 */
1746 if (PL_uudmap['M'] == 0) {
1747 int i;
1748
1749 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1750 PL_uudmap[(U8)PL_uuemap[i]] = i;
1751 /*
1752 * Because ' ' and '`' map to the same value,
1753 * we need to decode them both the same.
1754 */
1755 PL_uudmap[' '] = 0;
1756 }
1757
1758 along = (strend - s) * 3 / 4;
1759 sv = NEWSV(42, along);
1760 if (along)
1761 SvPOK_on(sv);
1762 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1763 I32 a, b, c, d;
1764 char hunk[4];
1765
1766 hunk[3] = '\0';
1767 len = PL_uudmap[*(U8*)s++] & 077;
1768 while (len > 0) {
1769 if (s < strend && ISUUCHAR(*s))
1770 a = PL_uudmap[*(U8*)s++] & 077;
1771 else
1772 a = 0;
1773 if (s < strend && ISUUCHAR(*s))
1774 b = PL_uudmap[*(U8*)s++] & 077;
1775 else
1776 b = 0;
1777 if (s < strend && ISUUCHAR(*s))
1778 c = PL_uudmap[*(U8*)s++] & 077;
1779 else
1780 c = 0;
1781 if (s < strend && ISUUCHAR(*s))
1782 d = PL_uudmap[*(U8*)s++] & 077;
1783 else
1784 d = 0;
eb160463
GS
1785 hunk[0] = (char)((a << 2) | (b >> 4));
1786 hunk[1] = (char)((b << 4) | (c >> 2));
1787 hunk[2] = (char)((c << 6) | d);
a6ec74c1
JH
1788 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1789 len -= 3;
1790 }
1791 if (*s == '\n')
1792 s++;
92aa5668
JH
1793 else /* possible checksum byte */
1794 if (s + 1 < strend && s[1] == '\n')
1795 s += 2;
a6ec74c1
JH
1796 }
1797 XPUSHs(sv_2mortal(sv));
1798 break;
1799 }
49704364 1800
a6ec74c1
JH
1801 if (checksum) {
1802 sv = NEWSV(42, 0);
1109a392 1803 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
92d41999 1804 (checksum > bits_in_uv &&
1109a392 1805 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
a6ec74c1
JH
1806 NV trouble;
1807
fa8ec7c1 1808 adouble = (NV) (1 << (checksum & 15));
a6ec74c1
JH
1809 while (checksum >= 16) {
1810 checksum -= 16;
1811 adouble *= 65536.0;
1812 }
a6ec74c1
JH
1813 while (cdouble < 0.0)
1814 cdouble += adouble;
1815 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1816 sv_setnv(sv, cdouble);
1817 }
1818 else {
fa8ec7c1
NC
1819 if (checksum < bits_in_uv) {
1820 UV mask = ((UV)1 << checksum) - 1;
92d41999 1821 cuv &= mask;
a6ec74c1 1822 }
92d41999 1823 sv_setuv(sv, cuv);
a6ec74c1
JH
1824 }
1825 XPUSHs(sv_2mortal(sv));
1826 checksum = 0;
1827 }
49704364
LW
1828
1829 if (symptr->flags & FLAG_SLASH){
1830 if (SP - PL_stack_base - start_sp_offset <= 0)
1831 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1832 if( next_symbol(symptr) ){
1833 if( symptr->howlen == e_number )
1834 Perl_croak(aTHX_ "Count after length/code in unpack" );
1835 if( beyond ){
1836 /* ...end of char buffer then no decent length available */
1837 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1838 } else {
1839 /* take top of stack (hope it's numeric) */
1840 len = POPi;
1841 if( len < 0 )
1842 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1843 }
1844 } else {
1845 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1846 }
1847 datumtype = symptr->code;
1848 goto redo_switch;
1849 }
a6ec74c1 1850 }
49704364 1851
18529408
IZ
1852 if (new_s)
1853 *new_s = s;
1854 PUTBACK;
1855 return SP - PL_stack_base - start_sp_offset;
1856}
1857
1858PP(pp_unpack)
1859{
1860 dSP;
bab9c0ac 1861 dPOPPOPssrl;
18529408
IZ
1862 I32 gimme = GIMME_V;
1863 STRLEN llen;
1864 STRLEN rlen;
1865 register char *pat = SvPV(left, llen);
1866#ifdef PACKED_IS_OCTETS
1867 /* Packed side is assumed to be octets - so force downgrade if it
1868 has been UTF-8 encoded by accident
1869 */
1870 register char *s = SvPVbyte(right, rlen);
1871#else
1872 register char *s = SvPV(right, rlen);
1873#endif
1874 char *strend = s + rlen;
1875 register char *patend = pat + llen;
1876 register I32 cnt;
1877
1878 PUTBACK;
7accc089 1879 cnt = unpackstring(pat, patend, s, strend,
49704364
LW
1880 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1881 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1882
18529408
IZ
1883 SPAGAIN;
1884 if ( !cnt && gimme == G_SCALAR )
1885 PUSHs(&PL_sv_undef);
a6ec74c1
JH
1886 RETURN;
1887}
1888
1889STATIC void
1890S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1891{
1892 char hunk[5];
1893
1894 *hunk = PL_uuemap[len];
1895 sv_catpvn(sv, hunk, 1);
1896 hunk[4] = '\0';
1897 while (len > 2) {
1898 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1899 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1900 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1901 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1902 sv_catpvn(sv, hunk, 4);
1903 s += 3;
1904 len -= 3;
1905 }
1906 if (len > 0) {
1907 char r = (len > 1 ? s[1] : '\0');
1908 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1909 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1910 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1911 hunk[3] = PL_uuemap[0];
1912 sv_catpvn(sv, hunk, 4);
1913 }
1914 sv_catpvn(sv, "\n", 1);
1915}
1916
1917STATIC SV *
1918S_is_an_int(pTHX_ char *s, STRLEN l)
1919{
1920 STRLEN n_a;
1921 SV *result = newSVpvn(s, l);
1922 char *result_c = SvPV(result, n_a); /* convenience */
1923 char *out = result_c;
1924 bool skip = 1;
1925 bool ignore = 0;
1926
1927 while (*s) {
1928 switch (*s) {
1929 case ' ':
1930 break;
1931 case '+':
1932 if (!skip) {
1933 SvREFCNT_dec(result);
1934 return (NULL);
1935 }
1936 break;
1937 case '0':
1938 case '1':
1939 case '2':
1940 case '3':
1941 case '4':
1942 case '5':
1943 case '6':
1944 case '7':
1945 case '8':
1946 case '9':
1947 skip = 0;
1948 if (!ignore) {
1949 *(out++) = *s;
1950 }
1951 break;
1952 case '.':
1953 ignore = 1;
1954 break;
1955 default:
1956 SvREFCNT_dec(result);
1957 return (NULL);
1958 }
1959 s++;
1960 }
1961 *(out++) = '\0';
1962 SvCUR_set(result, out - result_c);
1963 return (result);
1964}
1965
1966/* pnum must be '\0' terminated */
1967STATIC int
1968S_div128(pTHX_ SV *pnum, bool *done)
1969{
1970 STRLEN len;
1971 char *s = SvPV(pnum, len);
1972 int m = 0;
1973 int r = 0;
1974 char *t = s;
1975
1976 *done = 1;
1977 while (*t) {
1978 int i;
1979
1980 i = m * 10 + (*t - '0');
1981 m = i & 0x7F;
1982 r = (i >> 7); /* r < 10 */
1983 if (r) {
1984 *done = 0;
1985 }
1986 *(t++) = '0' + r;
1987 }
1988 *(t++) = '\0';
1989 SvCUR_set(pnum, (STRLEN) (t - s));
1990 return (m);
1991}
1992
49704364 1993
a6ec74c1 1994
18529408
IZ
1995/*
1996=for apidoc pack_cat
1997
7accc089
JH
1998The engine implementing pack() Perl function. Note: parameters next_in_list and
1999flags are not used. This call should not be used; use packlist instead.
18529408
IZ
2000
2001=cut */
2002
49704364 2003
18529408
IZ
2004void
2005Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
a6ec74c1 2006{
49704364
LW
2007 tempsym_t sym = { 0 };
2008 sym.patptr = pat;
2009 sym.patend = patend;
7accc089
JH
2010 sym.flags = FLAG_PACK;
2011
2012 (void)pack_rec( cat, &sym, beglist, endlist );
2013}
2014
2015
2016/*
2017=for apidoc packlist
2018
2019The engine implementing pack() Perl function.
2020
2021=cut */
2022
2023
2024void
2025Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2026{
2027 tempsym_t sym = { 0 };
2028 sym.patptr = pat;
2029 sym.patend = patend;
2030 sym.flags = FLAG_PACK;
49704364
LW
2031
2032 (void)pack_rec( cat, &sym, beglist, endlist );
2033}
2034
2035
2036STATIC
2037SV **
2038S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
2039{
a6ec74c1
JH
2040 register I32 items;
2041 STRLEN fromlen;
49704364 2042 register I32 len = 0;
a6ec74c1
JH
2043 SV *fromstr;
2044 /*SUPPRESS 442*/
2045 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2046 static char *space10 = " ";
49704364 2047 bool found;
a6ec74c1
JH
2048
2049 /* These must not be in registers: */
2050 char achar;
ef108786
MHM
2051 I16 ai16;
2052 U16 au16;
2053 I32 ai32;
2054 U32 au32;
a6ec74c1
JH
2055#ifdef HAS_QUAD
2056 Quad_t aquad;
2057 Uquad_t auquad;
2058#endif
ef108786
MHM
2059#if SHORTSIZE != SIZE16
2060 short ashort;
2061 unsigned short aushort;
2062#endif
2063 int aint;
2064 unsigned int auint;
2065#if LONGSIZE != SIZE32
2066 long along;
2067 unsigned long aulong;
2068#endif
a6ec74c1
JH
2069 char *aptr;
2070 float afloat;
2071 double adouble;
ef108786
MHM
2072#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2073 long double aldouble;
2074#endif
2075 IV aiv;
2076 UV auv;
2077 NV anv;
2078
49704364
LW
2079 int strrelbeg = SvCUR(cat);
2080 tempsym_t lookahead;
a6ec74c1 2081
18529408 2082 items = endlist - beglist;
49704364
LW
2083 found = next_symbol( symptr );
2084
18529408 2085#ifndef PACKED_IS_OCTETS
49704364 2086 if (symptr->level == 0 && found && symptr->code == 'U' ){
18529408 2087 SvUTF8_on(cat);
49704364 2088 }
18529408 2089#endif
49704364
LW
2090
2091 while (found) {
a6ec74c1 2092 SV *lengthcode = Nullsv;
18529408 2093#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
49704364
LW
2094
2095 I32 datumtype = symptr->code;
2096 howlen_t howlen;
2097
2098 switch( howlen = symptr->howlen ){
2099 case e_no_len:
2100 case e_number:
2101 len = symptr->length;
2102 break;
2103 case e_star:
1109a392 2104 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
49704364
LW
2105 break;
2106 }
2107
2108 /* Look ahead for next symbol. Do we have code/code? */
2109 lookahead = *symptr;
2110 found = next_symbol(&lookahead);
2111 if ( symptr->flags & FLAG_SLASH ) {
2112 if (found){
2113 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2114 e_star != lookahead.howlen )
2115 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2116 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
18529408 2117 ? *beglist : &PL_sv_no)
49704364
LW
2118 + (lookahead.code == 'Z' ? 1 : 0)));
2119 } else {
2120 Perl_croak(aTHX_ "Code missing after '/' in pack");
2121 }
a6ec74c1 2122 }
49704364 2123
1109a392 2124 switch(TYPE_NO_ENDIANNESS(datumtype)) {
a6ec74c1 2125 default:
1109a392 2126 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
a6ec74c1 2127 case '%':
49704364 2128 Perl_croak(aTHX_ "'%%' may not be used in pack");
a6ec74c1 2129 case '@':
49704364 2130 len += strrelbeg - SvCUR(cat);
a6ec74c1
JH
2131 if (len > 0)
2132 goto grow;
2133 len = -len;
2134 if (len > 0)
2135 goto shrink;
2136 break;
18529408
IZ
2137 case '(':
2138 {
49704364 2139 tempsym_t savsym = *symptr;
66c611c5
MHM
2140 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2141 symptr->flags |= group_modifiers;
49704364
LW
2142 symptr->patend = savsym.grpend;
2143 symptr->level++;
18529408 2144 while (len--) {
49704364
LW
2145 symptr->patptr = savsym.grpbeg;
2146 beglist = pack_rec(cat, symptr, beglist, endlist );
2147 if (savsym.howlen == e_star && beglist == endlist)
18529408
IZ
2148 break; /* No way to continue */
2149 }
66c611c5 2150 symptr->flags &= ~group_modifiers;
49704364
LW
2151 lookahead.flags = symptr->flags;
2152 *symptr = savsym;
18529408
IZ
2153 break;
2154 }
62f95557
IZ
2155 case 'X' | TYPE_IS_SHRIEKING:
2156 if (!len) /* Avoid division by 0 */
2157 len = 1;
2158 len = (SvCUR(cat)) % len;
2159 /* FALL THROUGH */
a6ec74c1
JH
2160 case 'X':
2161 shrink:
eb160463 2162 if ((I32)SvCUR(cat) < len)
49704364 2163 Perl_croak(aTHX_ "'X' outside of string in pack");
a6ec74c1
JH
2164 SvCUR(cat) -= len;
2165 *SvEND(cat) = '\0';
2166 break;
62f95557
IZ
2167 case 'x' | TYPE_IS_SHRIEKING:
2168 if (!len) /* Avoid division by 0 */
2169 len = 1;
2170 aint = (SvCUR(cat)) % len;
2171 if (aint) /* Other portable ways? */
2172 len = len - aint;
2173 else
2174 len = 0;
2175 /* FALL THROUGH */
49704364 2176
a6ec74c1
JH
2177 case 'x':
2178 grow:
2179 while (len >= 10) {
2180 sv_catpvn(cat, null10, 10);
2181 len -= 10;
2182 }
2183 sv_catpvn(cat, null10, len);
2184 break;
2185 case 'A':
2186 case 'Z':
2187 case 'a':
2188 fromstr = NEXTFROM;
2189 aptr = SvPV(fromstr, fromlen);
49704364 2190 if (howlen == e_star) {
a6ec74c1
JH
2191 len = fromlen;
2192 if (datumtype == 'Z')
2193 ++len;
2194 }
eb160463 2195 if ((I32)fromlen >= len) {
a6ec74c1
JH
2196 sv_catpvn(cat, aptr, len);
2197 if (datumtype == 'Z')
2198 *(SvEND(cat)-1) = '\0';
2199 }
2200 else {
2201 sv_catpvn(cat, aptr, fromlen);
2202 len -= fromlen;
2203 if (datumtype == 'A') {
2204 while (len >= 10) {
2205 sv_catpvn(cat, space10, 10);
2206 len -= 10;
2207 }
2208 sv_catpvn(cat, space10, len);
2209 }
2210 else {
2211 while (len >= 10) {
2212 sv_catpvn(cat, null10, 10);
2213 len -= 10;
2214 }
2215 sv_catpvn(cat, null10, len);
2216 }
2217 }
2218 break;
2219 case 'B':
2220 case 'b':
2221 {
2222 register char *str;
2223 I32 saveitems;
2224
2225 fromstr = NEXTFROM;
2226 saveitems = items;
2227 str = SvPV(fromstr, fromlen);
49704364 2228 if (howlen == e_star)
a6ec74c1
JH
2229 len = fromlen;
2230 aint = SvCUR(cat);
2231 SvCUR(cat) += (len+7)/8;
2232 SvGROW(cat, SvCUR(cat) + 1);
2233 aptr = SvPVX(cat) + aint;
eb160463 2234 if (len > (I32)fromlen)
a6ec74c1
JH
2235 len = fromlen;
2236 aint = len;
2237 items = 0;
2238 if (datumtype == 'B') {
2239 for (len = 0; len++ < aint;) {
2240 items |= *str++ & 1;
2241 if (len & 7)
2242 items <<= 1;
2243 else {
2244 *aptr++ = items & 0xff;
2245 items = 0;
2246 }
2247 }
2248 }
2249 else {
2250 for (len = 0; len++ < aint;) {
2251 if (*str++ & 1)
2252 items |= 128;
2253 if (len & 7)
2254 items >>= 1;
2255 else {
2256 *aptr++ = items & 0xff;
2257 items = 0;
2258 }
2259 }
2260 }
2261 if (aint & 7) {
2262 if (datumtype == 'B')
2263 items <<= 7 - (aint & 7);
2264 else
2265 items >>= 7 - (aint & 7);
2266 *aptr++ = items & 0xff;
2267 }
2268 str = SvPVX(cat) + SvCUR(cat);
2269 while (aptr <= str)
2270 *aptr++ = '\0';
2271
2272 items = saveitems;
2273 }
2274 break;
2275 case 'H':
2276 case 'h':
2277 {
2278 register char *str;
2279 I32 saveitems;
2280
2281 fromstr = NEXTFROM;
2282 saveitems = items;
2283 str = SvPV(fromstr, fromlen);
49704364 2284 if (howlen == e_star)
a6ec74c1
JH
2285 len = fromlen;
2286 aint = SvCUR(cat);
2287 SvCUR(cat) += (len+1)/2;
2288 SvGROW(cat, SvCUR(cat) + 1);
2289 aptr = SvPVX(cat) + aint;
eb160463 2290 if (len > (I32)fromlen)
a6ec74c1
JH
2291 len = fromlen;
2292 aint = len;
2293 items = 0;
2294 if (datumtype == 'H') {
2295 for (len = 0; len++ < aint;) {
2296 if (isALPHA(*str))
2297 items |= ((*str++ & 15) + 9) & 15;
2298 else
2299 items |= *str++ & 15;
2300 if (len & 1)
2301 items <<= 4;
2302 else {
2303 *aptr++ = items & 0xff;
2304 items = 0;
2305 }
2306 }
2307 }
2308 else {
2309 for (len = 0; len++ < aint;) {
2310 if (isALPHA(*str))
2311 items |= (((*str++ & 15) + 9) & 15) << 4;
2312 else
2313 items |= (*str++ & 15) << 4;
2314 if (len & 1)
2315 items >>= 4;
2316 else {
2317 *aptr++ = items & 0xff;
2318 items = 0;
2319 }
2320 }
2321 }
2322 if (aint & 1)
2323 *aptr++ = items & 0xff;
2324 str = SvPVX(cat) + SvCUR(cat);
2325 while (aptr <= str)
2326 *aptr++ = '\0';
2327
2328 items = saveitems;
2329 }
2330 break;
2331 case 'C':
2332 case 'c':
2333 while (len-- > 0) {
2334 fromstr = NEXTFROM;
1109a392 2335 switch (TYPE_NO_MODIFIERS(datumtype)) {
a6ec74c1
JH
2336 case 'C':
2337 aint = SvIV(fromstr);
2338 if ((aint < 0 || aint > 255) &&
2339 ckWARN(WARN_PACK))
9014280d 2340 Perl_warner(aTHX_ packWARN(WARN_PACK),
49704364 2341 "Character in 'C' format wrapped in pack");
a6ec74c1
JH
2342 achar = aint & 255;
2343 sv_catpvn(cat, &achar, sizeof(char));
2344 break;
2345 case 'c':
2346 aint = SvIV(fromstr);
2347 if ((aint < -128 || aint > 127) &&
2348 ckWARN(WARN_PACK))
9014280d 2349 Perl_warner(aTHX_ packWARN(WARN_PACK),
49704364 2350 "Character in 'c' format wrapped in pack" );
a6ec74c1
JH
2351 achar = aint & 255;
2352 sv_catpvn(cat, &achar, sizeof(char));
2353 break;
2354 }
2355 }
2356 break;
2357 case 'U':
2358 while (len-- > 0) {
2359 fromstr = NEXTFROM;
e87322b2 2360 auint = UNI_TO_NATIVE(SvUV(fromstr));
a6ec74c1 2361 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
52ea3e69
JH
2362 SvCUR_set(cat,
2363 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2364 auint,
2365 ckWARN(WARN_UTF8) ?
2366 0 : UNICODE_ALLOW_ANY)
2367 - SvPVX(cat));
a6ec74c1
JH
2368 }
2369 *SvEND(cat) = '\0';
2370 break;
2371 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2372 case 'f':
a6ec74c1
JH
2373 while (len-- > 0) {
2374 fromstr = NEXTFROM;
5cdb9e01
PG
2375#ifdef __VOS__
2376/* VOS does not automatically map a floating-point overflow
2377 during conversion from double to float into infinity, so we
2378 do it by hand. This code should either be generalized for
2379 any OS that needs it, or removed if and when VOS implements
2380 posix-976 (suggestion to support mapping to infinity).
2381 Paul.Green@stratus.com 02-04-02. */
2382 if (SvNV(fromstr) > FLT_MAX)
2383 afloat = _float_constants[0]; /* single prec. inf. */
2384 else if (SvNV(fromstr) < -FLT_MAX)
2385 afloat = _float_constants[0]; /* single prec. inf. */
2386 else afloat = (float)SvNV(fromstr);
2387#else
baf3cf9c
CB
2388# if defined(VMS) && !defined(__IEEE_FP)
2389/* IEEE fp overflow shenanigans are unavailable on VAX and optional
2390 * on Alpha; fake it if we don't have them.
2391 */
2392 if (SvNV(fromstr) > FLT_MAX)
2393 afloat = FLT_MAX;
2394 else if (SvNV(fromstr) < -FLT_MAX)
2395 afloat = -FLT_MAX;
2396 else afloat = (float)SvNV(fromstr);
2397# else
a6ec74c1 2398 afloat = (float)SvNV(fromstr);
baf3cf9c 2399# endif
5cdb9e01 2400#endif
1109a392 2401 DO_BO_PACK_N(afloat, float);
a6ec74c1
JH
2402 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2403 }
2404 break;
2405 case 'd':
a6ec74c1
JH
2406 while (len-- > 0) {
2407 fromstr = NEXTFROM;
5cdb9e01
PG
2408#ifdef __VOS__
2409/* VOS does not automatically map a floating-point overflow
2410 during conversion from long double to double into infinity,
2411 so we do it by hand. This code should either be generalized
2412 for any OS that needs it, or removed if and when VOS
2413 implements posix-976 (suggestion to support mapping to
2414 infinity). Paul.Green@stratus.com 02-04-02. */
2415 if (SvNV(fromstr) > DBL_MAX)
2416 adouble = _double_constants[0]; /* double prec. inf. */
2417 else if (SvNV(fromstr) < -DBL_MAX)
2418 adouble = _double_constants[0]; /* double prec. inf. */
2419 else adouble = (double)SvNV(fromstr);
2420#else
baf3cf9c
CB
2421# if defined(VMS) && !defined(__IEEE_FP)
2422/* IEEE fp overflow shenanigans are unavailable on VAX and optional
2423 * on Alpha; fake it if we don't have them.
2424 */
2425 if (SvNV(fromstr) > DBL_MAX)
2426 adouble = DBL_MAX;
2427 else if (SvNV(fromstr) < -DBL_MAX)
2428 adouble = -DBL_MAX;
2429 else adouble = (double)SvNV(fromstr);
2430# else
a6ec74c1 2431 adouble = (double)SvNV(fromstr);
baf3cf9c 2432# endif
5cdb9e01 2433#endif
1109a392 2434 DO_BO_PACK_N(adouble, double);
a6ec74c1
JH
2435 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2436 }
2437 break;
92d41999 2438 case 'F':
1109a392 2439 Zero(&anv, 1, NV); /* can be long double with unused bits */
92d41999
JH
2440 while (len-- > 0) {
2441 fromstr = NEXTFROM;
2442 anv = SvNV(fromstr);
1109a392 2443 DO_BO_PACK_N(anv, NV);
92d41999
JH
2444 sv_catpvn(cat, (char *)&anv, NVSIZE);
2445 }
2446 break;
2447#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2448 case 'D':
1109a392
MHM
2449 /* long doubles can have unused bits, which may be nonzero */
2450 Zero(&aldouble, 1, long double);
92d41999
JH
2451 while (len-- > 0) {
2452 fromstr = NEXTFROM;
2453 aldouble = (long double)SvNV(fromstr);
1109a392 2454 DO_BO_PACK_N(aldouble, long double);
92d41999
JH
2455 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2456 }
2457 break;
2458#endif
068bd2e7 2459 case 'n' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
2460 case 'n':
2461 while (len-- > 0) {
2462 fromstr = NEXTFROM;
ef108786 2463 ai16 = (I16)SvIV(fromstr);
a6ec74c1 2464#ifdef HAS_HTONS
ef108786 2465 ai16 = PerlSock_htons(ai16);
a6ec74c1 2466#endif
ef108786 2467 CAT16(cat, &ai16);
a6ec74c1
JH
2468 }
2469 break;
068bd2e7 2470 case 'v' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
2471 case 'v':
2472 while (len-- > 0) {
2473 fromstr = NEXTFROM;
ef108786 2474 ai16 = (I16)SvIV(fromstr);
a6ec74c1 2475#ifdef HAS_HTOVS
ef108786 2476 ai16 = htovs(ai16);
a6ec74c1 2477#endif
ef108786 2478 CAT16(cat, &ai16);
a6ec74c1
JH
2479 }
2480 break;
49704364 2481 case 'S' | TYPE_IS_SHRIEKING:
a6ec74c1 2482#if SHORTSIZE != SIZE16
49704364 2483 {
a6ec74c1
JH
2484 while (len-- > 0) {
2485 fromstr = NEXTFROM;
2486 aushort = SvUV(fromstr);
1109a392 2487 DO_BO_PACK(aushort, s);
a6ec74c1
JH
2488 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2489 }
49704364
LW
2490 }
2491 break;
2492#else
2493 /* Fall through! */
a6ec74c1 2494#endif
49704364 2495 case 'S':
a6ec74c1 2496 {
a6ec74c1
JH
2497 while (len-- > 0) {
2498 fromstr = NEXTFROM;
ef108786
MHM
2499 au16 = (U16)SvUV(fromstr);
2500 DO_BO_PACK(au16, 16);
2501 CAT16(cat, &au16);
a6ec74c1
JH
2502 }
2503
2504 }
2505 break;
49704364 2506 case 's' | TYPE_IS_SHRIEKING:
a6ec74c1 2507#if SHORTSIZE != SIZE16
49704364 2508 {
a6ec74c1
JH
2509 while (len-- > 0) {
2510 fromstr = NEXTFROM;
2511 ashort = SvIV(fromstr);
1109a392 2512 DO_BO_PACK(ashort, s);
a6ec74c1
JH
2513 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2514 }
2515 }
49704364
LW
2516 break;
2517#else
2518 /* Fall through! */
a6ec74c1 2519#endif
49704364
LW
2520 case 's':
2521 while (len-- > 0) {
2522 fromstr = NEXTFROM;
ef108786
MHM
2523 ai16 = (I16)SvIV(fromstr);
2524 DO_BO_PACK(ai16, 16);
2525 CAT16(cat, &ai16);
a6ec74c1
JH
2526 }
2527 break;
2528 case 'I':
49704364 2529 case 'I' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
2530 while (len-- > 0) {
2531 fromstr = NEXTFROM;
2532 auint = SvUV(fromstr);
1109a392 2533 DO_BO_PACK(auint, i);
a6ec74c1
JH
2534 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2535 }
2536 break;
92d41999
JH
2537 case 'j':
2538 while (len-- > 0) {
2539 fromstr = NEXTFROM;
2540 aiv = SvIV(fromstr);
1109a392
MHM
2541#if IVSIZE == INTSIZE
2542 DO_BO_PACK(aiv, i);
2543#elif IVSIZE == LONGSIZE
2544 DO_BO_PACK(aiv, l);
2545#elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2546 DO_BO_PACK(aiv, 64);
2547#endif
92d41999
JH
2548 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2549 }
2550 break;
2551 case 'J':
2552 while (len-- > 0) {
2553 fromstr = NEXTFROM;
2554 auv = SvUV(fromstr);
1109a392
MHM
2555#if UVSIZE == INTSIZE
2556 DO_BO_PACK(auv, i);
2557#elif UVSIZE == LONGSIZE
2558 DO_BO_PACK(auv, l);
2559#elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2560 DO_BO_PACK(auv, 64);
2561#endif
92d41999
JH
2562 sv_catpvn(cat, (char*)&auv, UVSIZE);
2563 }
2564 break;
a6ec74c1
JH
2565 case 'w':
2566 while (len-- > 0) {
2567 fromstr = NEXTFROM;
15e9f109 2568 anv = SvNV(fromstr);
a6ec74c1 2569
15e9f109 2570 if (anv < 0)
49704364 2571 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
a6ec74c1 2572
196b62db
NC
2573 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2574 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2575 any negative IVs will have already been got by the croak()
2576 above. IOK is untrue for fractions, so we test them
2577 against UV_MAX_P1. */
15e9f109 2578 if (SvIOK(fromstr) || anv < UV_MAX_P1)
a6ec74c1 2579 {
7c1b502b 2580 char buf[(sizeof(UV)*8)/7+1];
a6ec74c1 2581 char *in = buf + sizeof(buf);
196b62db 2582 UV auv = SvUV(fromstr);
a6ec74c1
JH
2583
2584 do {
eb160463 2585 *--in = (char)((auv & 0x7f) | 0x80);
a6ec74c1
JH
2586 auv >>= 7;
2587 } while (auv);
2588 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2589 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2590 }
2591 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2592 char *from, *result, *in;
2593 SV *norm;
2594 STRLEN len;
2595 bool done;
2596
2597 /* Copy string and check for compliance */
2598 from = SvPV(fromstr, len);
2599 if ((norm = is_an_int(from, len)) == NULL)
49704364 2600 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
a6ec74c1
JH
2601
2602 New('w', result, len, char);
2603 in = result + len;
2604 done = FALSE;
2605 while (!done)
2606 *--in = div128(norm, &done) | 0x80;
2607 result[len - 1] &= 0x7F; /* clear continue bit */
2608 sv_catpvn(cat, in, (result + len) - in);
2609 Safefree(result);
2610 SvREFCNT_dec(norm); /* free norm */
2611 }
2612 else if (SvNOKp(fromstr)) {
0258719b
NC
2613 /* 10**NV_MAX_10_EXP is the largest power of 10
2614 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2615 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2616 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2617 And with that many bytes only Inf can overflow.
8f8d40ab
PG
2618 Some C compilers are strict about integral constant
2619 expressions so we conservatively divide by a slightly
2620 smaller integer instead of multiplying by the exact
2621 floating-point value.
0258719b
NC
2622 */
2623#ifdef NV_MAX_10_EXP
8f8d40ab
PG
2624/* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2625 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
0258719b 2626#else
8f8d40ab
PG
2627/* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2628 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
0258719b 2629#endif
a6ec74c1
JH
2630 char *in = buf + sizeof(buf);
2631
15e9f109 2632 anv = Perl_floor(anv);
a6ec74c1 2633 do {
15e9f109 2634 NV next = Perl_floor(anv / 128);
a6ec74c1 2635 if (in <= buf) /* this cannot happen ;-) */
49704364 2636 Perl_croak(aTHX_ "Cannot compress integer in pack");
0258719b 2637 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
15e9f109
NC
2638 anv = next;
2639 } while (anv > 0);
a6ec74c1
JH
2640 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2641 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2642 }
735b914b
JH
2643 else {
2644 char *from, *result, *in;
2645 SV *norm;
2646 STRLEN len;
2647 bool done;
2648
2649 /* Copy string and check for compliance */
2650 from = SvPV(fromstr, len);
2651 if ((norm = is_an_int(from, len)) == NULL)
49704364 2652 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
735b914b
JH
2653
2654 New('w', result, len, char);
2655 in = result + len;
2656 done = FALSE;
2657 while (!done)
2658 *--in = div128(norm, &done) | 0x80;
2659 result[len - 1] &= 0x7F; /* clear continue bit */
2660 sv_catpvn(cat, in, (result + len) - in);
2661 Safefree(result);
2662 SvREFCNT_dec(norm); /* free norm */
2663 }
a6ec74c1
JH
2664 }
2665 break;
2666 case 'i':
49704364 2667 case 'i' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
2668 while (len-- > 0) {
2669 fromstr = NEXTFROM;
2670 aint = SvIV(fromstr);
1109a392 2671 DO_BO_PACK(aint, i);
a6ec74c1
JH
2672 sv_catpvn(cat, (char*)&aint, sizeof(int));
2673 }
2674 break;
068bd2e7 2675 case 'N' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
2676 case 'N':
2677 while (len-- > 0) {
2678 fromstr = NEXTFROM;
ef108786 2679 au32 = SvUV(fromstr);
a6ec74c1 2680#ifdef HAS_HTONL
ef108786 2681 au32 = PerlSock_htonl(au32);
a6ec74c1 2682#endif
ef108786 2683 CAT32(cat, &au32);
a6ec74c1
JH
2684 }
2685 break;
068bd2e7 2686 case 'V' | TYPE_IS_SHRIEKING:
a6ec74c1
JH
2687 case 'V':
2688 while (len-- > 0) {
2689 fromstr = NEXTFROM;
ef108786 2690 au32 = SvUV(fromstr);
a6ec74c1 2691#ifdef HAS_HTOVL
ef108786 2692 au32 = htovl(au32);
a6ec74c1 2693#endif
ef108786 2694 CAT32(cat, &au32);
a6ec74c1
JH
2695 }
2696 break;
49704364 2697 case 'L' | TYPE_IS_SHRIEKING:
a6ec74c1 2698#if LONGSIZE != SIZE32
49704364 2699 {
a6ec74c1
JH
2700 while (len-- > 0) {
2701 fromstr = NEXTFROM;
2702 aulong = SvUV(fromstr);
1109a392 2703 DO_BO_PACK(aulong, l);
a6ec74c1
JH
2704 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2705 }
2706 }
49704364
LW
2707 break;
2708#else
2709 /* Fall though! */
a6ec74c1 2710#endif
49704364 2711 case 'L':
a6ec74c1
JH
2712 {
2713 while (len-- > 0) {
2714 fromstr = NEXTFROM;
ef108786
MHM
2715 au32 = SvUV(fromstr);
2716 DO_BO_PACK(au32, 32);
2717 CAT32(cat, &au32);
a6ec74c1
JH
2718 }
2719 }
2720 break;
49704364 2721 case 'l' | TYPE_IS_SHRIEKING:
a6ec74c1 2722#if LONGSIZE != SIZE32
49704364 2723 {
a6ec74c1
JH
2724 while (len-- > 0) {
2725 fromstr = NEXTFROM;
2726 along = SvIV(fromstr);
1109a392 2727 DO_BO_PACK(along, l);
a6ec74c1
JH
2728 sv_catpvn(cat, (char *)&along, sizeof(long));
2729 }
2730 }
49704364
LW
2731 break;
2732#else
2733 /* Fall though! */
a6ec74c1 2734#endif
49704364
LW
2735 case 'l':
2736 while (len-- > 0) {
2737 fromstr = NEXTFROM;
ef108786
MHM
2738 ai32 = SvIV(fromstr);
2739 DO_BO_PACK(ai32, 32);
2740 CAT32(cat, &ai32);
a6ec74c1
JH
2741 }
2742 break;
2743#ifdef HAS_QUAD
2744 case 'Q':
2745 while (len-- > 0) {
2746 fromstr = NEXTFROM;
2747 auquad = (Uquad_t)SvUV(fromstr);
1109a392 2748 DO_BO_PACK(auquad, 64);
a6ec74c1
JH
2749 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2750 }
2751 break;
2752 case 'q':
2753 while (len-- > 0) {
2754 fromstr = NEXTFROM;
2755 aquad = (Quad_t)SvIV(fromstr);
1109a392 2756 DO_BO_PACK(aquad, 64);
a6ec74c1
JH
2757 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2758 }
2759 break;
2760#endif
2761 case 'P':
2762 len = 1; /* assume SV is correct length */
49704364 2763 /* Fall through! */
a6ec74c1
JH
2764 case 'p':
2765 while (len-- > 0) {
2766 fromstr = NEXTFROM;
2767 if (fromstr == &PL_sv_undef)
2768 aptr = NULL;
2769 else {
2770 STRLEN n_a;
2771 /* XXX better yet, could spirit away the string to
2772 * a safe spot and hang on to it until the result
2773 * of pack() (and all copies of the result) are
2774 * gone.
2775 */
2776 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2777 || (SvPADTMP(fromstr)
2778 && !SvREADONLY(fromstr))))
2779 {
9014280d 2780 Perl_warner(aTHX_ packWARN(WARN_PACK),
a6ec74c1
JH
2781 "Attempt to pack pointer to temporary value");
2782 }
2783 if (SvPOK(fromstr) || SvNIOK(fromstr))
2784 aptr = SvPV(fromstr,n_a);
2785 else
2786 aptr = SvPV_force(fromstr,n_a);
2787 }
1109a392 2788 DO_BO_PACK_P(aptr);
a6ec74c1
JH
2789 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2790 }
2791 break;
2792 case 'u':
2793 fromstr = NEXTFROM;
2794 aptr = SvPV(fromstr, fromlen);
2795 SvGROW(cat, fromlen * 4 / 3);
19c9db5e 2796 if (len <= 2)
a6ec74c1
JH
2797 len = 45;
2798 else
2799 len = len / 3 * 3;
2800 while (fromlen > 0) {
2801 I32 todo;
2802
eb160463 2803 if ((I32)fromlen > len)
a6ec74c1
JH
2804 todo = len;
2805 else
2806 todo = fromlen;
2807 doencodes(cat, aptr, todo);
2808 fromlen -= todo;
2809 aptr += todo;
2810 }
2811 break;
2812 }
49704364 2813 *symptr = lookahead;
a6ec74c1 2814 }
49704364 2815 return beglist;
18529408
IZ
2816}
2817#undef NEXTFROM
2818
2819
2820PP(pp_pack)
2821{
2822 dSP; dMARK; dORIGMARK; dTARGET;
2823 register SV *cat = TARG;
2824 STRLEN fromlen;
2825 register char *pat = SvPVx(*++MARK, fromlen);
2826 register char *patend = pat + fromlen;
2827
2828 MARK++;
2829 sv_setpvn(cat, "", 0);
2830
7accc089 2831 packlist(cat, pat, patend, MARK, SP + 1);
18529408 2832
a6ec74c1
JH
2833 SvSETMAGIC(cat);
2834 SP = ORIGMARK;
2835 PUSHs(cat);
2836 RETURN;
2837}
a6ec74c1 2838
73cb7263
NC
2839/*
2840 * Local variables:
2841 * c-indentation-style: bsd
2842 * c-basic-offset: 4
2843 * indent-tabs-mode: t
2844 * End:
2845 *
2846 * vim: expandtab shiftwidth=4:
2847*/