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