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