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