This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re-sort MANIFEST.
[perl5.git] / pp_pack.c
CommitLineData
a6ec74c1
JH
1/* pp_pack.c
2 *
be3c0a43 3 * Copyright (c) 1991-2002, 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;
107 *(t--) = '0' + (i % 10);
108 m = i / 10;
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':
205 buf[0] = datumtype;
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
18529408 461 bool do_utf8 = flags & UNPACK_DO_UTF8;
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 {
723 EXTEND(SP, len);
724 EXTEND_MORTAL(len);
725 while (len-- > 0) {
726 aint = *s++;
727 if (aint >= 128) /* fake up signed chars */
728 aint -= 256;
729 sv = NEWSV(36, 0);
730 sv_setiv(sv, (IV)aint);
731 PUSHs(sv_2mortal(sv));
732 }
733 }
734 break;
735 case 'C':
35bcd338
JH
736 unpack_C: /* unpack U will jump here if not UTF-8 */
737 if (len == 0) {
738 do_utf8 = FALSE;
739 break;
740 }
a6ec74c1
JH
741 if (len > strend - s)
742 len = strend - s;
743 if (checksum) {
744 uchar_checksum:
745 while (len-- > 0) {
746 auint = *s++ & 255;
92d41999 747 cuv += auint;
a6ec74c1
JH
748 }
749 }
750 else {
751 EXTEND(SP, len);
752 EXTEND_MORTAL(len);
753 while (len-- > 0) {
754 auint = *s++ & 255;
755 sv = NEWSV(37, 0);
756 sv_setiv(sv, (IV)auint);
757 PUSHs(sv_2mortal(sv));
758 }
759 }
760 break;
761 case 'U':
35bcd338
JH
762 if (len == 0) {
763 do_utf8 = TRUE;
764 break;
765 }
766 if (!do_utf8)
767 goto unpack_C;
a6ec74c1
JH
768 if (len > strend - s)
769 len = strend - s;
770 if (checksum) {
771 while (len-- > 0 && s < strend) {
772 STRLEN alen;
872c91ae 773 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
a6ec74c1
JH
774 along = alen;
775 s += along;
fa8ec7c1 776 if (checksum > bits_in_uv)
a6ec74c1
JH
777 cdouble += (NV)auint;
778 else
92d41999 779 cuv += auint;
a6ec74c1
JH
780 }
781 }
782 else {
783 EXTEND(SP, len);
784 EXTEND_MORTAL(len);
785 while (len-- > 0 && s < strend) {
786 STRLEN alen;
872c91ae 787 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
a6ec74c1
JH
788 along = alen;
789 s += along;
790 sv = NEWSV(37, 0);
791 sv_setuv(sv, (UV)auint);
792 PUSHs(sv_2mortal(sv));
793 }
794 }
795 break;
796 case 's':
797#if SHORTSIZE == SIZE16
798 along = (strend - s) / SIZE16;
799#else
800 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
801#endif
802 if (len > along)
803 len = along;
804 if (checksum) {
805#if SHORTSIZE != SIZE16
806 if (natint) {
807 short ashort;
808 while (len-- > 0) {
809 COPYNN(s, &ashort, sizeof(short));
810 s += sizeof(short);
fa8ec7c1
NC
811 if (checksum > bits_in_uv)
812 cdouble += (NV)ashort;
813 else
92d41999 814 cuv += ashort;
a6ec74c1
JH
815
816 }
817 }
818 else
819#endif
820 {
821 while (len-- > 0) {
822 COPY16(s, &ashort);
823#if SHORTSIZE > SIZE16
824 if (ashort > 32767)
825 ashort -= 65536;
826#endif
827 s += SIZE16;
fa8ec7c1
NC
828 if (checksum > bits_in_uv)
829 cdouble += (NV)ashort;
830 else
92d41999 831 cuv += ashort;
a6ec74c1
JH
832 }
833 }
834 }
835 else {
836 EXTEND(SP, len);
837 EXTEND_MORTAL(len);
838#if SHORTSIZE != SIZE16
839 if (natint) {
840 short ashort;
841 while (len-- > 0) {
842 COPYNN(s, &ashort, sizeof(short));
843 s += sizeof(short);
844 sv = NEWSV(38, 0);
845 sv_setiv(sv, (IV)ashort);
846 PUSHs(sv_2mortal(sv));
847 }
848 }
849 else
850#endif
851 {
852 while (len-- > 0) {
853 COPY16(s, &ashort);
854#if SHORTSIZE > SIZE16
855 if (ashort > 32767)
856 ashort -= 65536;
857#endif
858 s += SIZE16;
859 sv = NEWSV(38, 0);
860 sv_setiv(sv, (IV)ashort);
861 PUSHs(sv_2mortal(sv));
862 }
863 }
864 }
865 break;
866 case 'v':
867 case 'n':
868 case 'S':
869#if SHORTSIZE == SIZE16
870 along = (strend - s) / SIZE16;
871#else
872 unatint = natint && datumtype == 'S';
873 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
874#endif
875 if (len > along)
876 len = along;
877 if (checksum) {
878#if SHORTSIZE != SIZE16
879 if (unatint) {
880 unsigned short aushort;
881 while (len-- > 0) {
882 COPYNN(s, &aushort, sizeof(unsigned short));
883 s += sizeof(unsigned short);
fa8ec7c1
NC
884 if (checksum > bits_in_uv)
885 cdouble += (NV)aushort;
886 else
92d41999 887 cuv += aushort;
a6ec74c1
JH
888 }
889 }
890 else
891#endif
892 {
893 while (len-- > 0) {
894 COPY16(s, &aushort);
895 s += SIZE16;
896#ifdef HAS_NTOHS
897 if (datumtype == 'n')
898 aushort = PerlSock_ntohs(aushort);
899#endif
900#ifdef HAS_VTOHS
901 if (datumtype == 'v')
902 aushort = vtohs(aushort);
903#endif
fa8ec7c1
NC
904 if (checksum > bits_in_uv)
905 cdouble += (NV)aushort;
906 else
92d41999 907 cuv += aushort;
a6ec74c1
JH
908 }
909 }
910 }
911 else {
912 EXTEND(SP, len);
913 EXTEND_MORTAL(len);
914#if SHORTSIZE != SIZE16
915 if (unatint) {
916 unsigned short aushort;
917 while (len-- > 0) {
918 COPYNN(s, &aushort, sizeof(unsigned short));
919 s += sizeof(unsigned short);
920 sv = NEWSV(39, 0);
921 sv_setiv(sv, (UV)aushort);
922 PUSHs(sv_2mortal(sv));
923 }
924 }
925 else
926#endif
927 {
928 while (len-- > 0) {
929 COPY16(s, &aushort);
930 s += SIZE16;
931 sv = NEWSV(39, 0);
932#ifdef HAS_NTOHS
933 if (datumtype == 'n')
934 aushort = PerlSock_ntohs(aushort);
935#endif
936#ifdef HAS_VTOHS
937 if (datumtype == 'v')
938 aushort = vtohs(aushort);
939#endif
940 sv_setiv(sv, (UV)aushort);
941 PUSHs(sv_2mortal(sv));
942 }
943 }
944 }
945 break;
946 case 'i':
947 along = (strend - s) / sizeof(int);
948 if (len > along)
949 len = along;
950 if (checksum) {
951 while (len-- > 0) {
952 Copy(s, &aint, 1, int);
953 s += sizeof(int);
fa8ec7c1 954 if (checksum > bits_in_uv)
a6ec74c1
JH
955 cdouble += (NV)aint;
956 else
92d41999 957 cuv += aint;
a6ec74c1
JH
958 }
959 }
960 else {
961 EXTEND(SP, len);
962 EXTEND_MORTAL(len);
963 while (len-- > 0) {
964 Copy(s, &aint, 1, int);
965 s += sizeof(int);
966 sv = NEWSV(40, 0);
967#ifdef __osf__
968 /* Without the dummy below unpack("i", pack("i",-1))
969 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
970 * cc with optimization turned on.
971 *
972 * The bug was detected in
973 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
974 * with optimization (-O4) turned on.
975 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
976 * does not have this problem even with -O4.
977 *
978 * This bug was reported as DECC_BUGS 1431
979 * and tracked internally as GEM_BUGS 7775.
980 *
981 * The bug is fixed in
982 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
983 * UNIX V4.0F support: DEC C V5.9-006 or later
984 * UNIX V4.0E support: DEC C V5.8-011 or later
985 * and also in DTK.
986 *
987 * See also few lines later for the same bug.
988 */
989 (aint) ?
990 sv_setiv(sv, (IV)aint) :
991#endif
992 sv_setiv(sv, (IV)aint);
993 PUSHs(sv_2mortal(sv));
994 }
995 }
996 break;
997 case 'I':
998 along = (strend - s) / sizeof(unsigned int);
999 if (len > along)
1000 len = along;
1001 if (checksum) {
1002 while (len-- > 0) {
1003 Copy(s, &auint, 1, unsigned int);
1004 s += sizeof(unsigned int);
fa8ec7c1 1005 if (checksum > bits_in_uv)
a6ec74c1
JH
1006 cdouble += (NV)auint;
1007 else
92d41999 1008 cuv += auint;
a6ec74c1
JH
1009 }
1010 }
1011 else {
1012 EXTEND(SP, len);
1013 EXTEND_MORTAL(len);
1014 while (len-- > 0) {
1015 Copy(s, &auint, 1, unsigned int);
1016 s += sizeof(unsigned int);
1017 sv = NEWSV(41, 0);
1018#ifdef __osf__
1019 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1020 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1021 * See details few lines earlier. */
1022 (auint) ?
1023 sv_setuv(sv, (UV)auint) :
1024#endif
1025 sv_setuv(sv, (UV)auint);
1026 PUSHs(sv_2mortal(sv));
1027 }
1028 }
1029 break;
92d41999
JH
1030 case 'j':
1031 along = (strend - s) / IVSIZE;
1032 if (len > along)
1033 len = along;
1034 if (checksum) {
1035 while (len-- > 0) {
1036 Copy(s, &aiv, 1, IV);
1037 s += IVSIZE;
1038 if (checksum > bits_in_uv)
1039 cdouble += (NV)aiv;
1040 else
1041 cuv += aiv;
1042 }
1043 }
1044 else {
1045 EXTEND(SP, len);
1046 EXTEND_MORTAL(len);
1047 while (len-- > 0) {
1048 Copy(s, &aiv, 1, IV);
1049 s += IVSIZE;
1050 sv = NEWSV(40, 0);
1051 sv_setiv(sv, aiv);
1052 PUSHs(sv_2mortal(sv));
1053 }
1054 }
1055 break;
1056 case 'J':
1057 along = (strend - s) / UVSIZE;
1058 if (len > along)
1059 len = along;
1060 if (checksum) {
1061 while (len-- > 0) {
1062 Copy(s, &auv, 1, UV);
1063 s += UVSIZE;
1064 if (checksum > bits_in_uv)
1065 cdouble += (NV)auv;
1066 else
1067 cuv += auv;
1068 }
1069 }
1070 else {
1071 EXTEND(SP, len);
1072 EXTEND_MORTAL(len);
1073 while (len-- > 0) {
1074 Copy(s, &auv, 1, UV);
1075 s += UVSIZE;
1076 sv = NEWSV(41, 0);
1077 sv_setuv(sv, auv);
1078 PUSHs(sv_2mortal(sv));
1079 }
1080 }
1081 break;
a6ec74c1
JH
1082 case 'l':
1083#if LONGSIZE == SIZE32
1084 along = (strend - s) / SIZE32;
1085#else
1086 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
1087#endif
1088 if (len > along)
1089 len = along;
1090 if (checksum) {
1091#if LONGSIZE != SIZE32
1092 if (natint) {
1093 while (len-- > 0) {
1094 COPYNN(s, &along, sizeof(long));
1095 s += sizeof(long);
fa8ec7c1 1096 if (checksum > bits_in_uv)
a6ec74c1
JH
1097 cdouble += (NV)along;
1098 else
92d41999 1099 cuv += along;
a6ec74c1
JH
1100 }
1101 }
1102 else
1103#endif
1104 {
1105 while (len-- > 0) {
1106#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1107 I32 along;
1108#endif
1109 COPY32(s, &along);
1110#if LONGSIZE > SIZE32
1111 if (along > 2147483647)
1112 along -= 4294967296;
1113#endif
1114 s += SIZE32;
fa8ec7c1 1115 if (checksum > bits_in_uv)
a6ec74c1
JH
1116 cdouble += (NV)along;
1117 else
92d41999 1118 cuv += along;
a6ec74c1
JH
1119 }
1120 }
1121 }
1122 else {
1123 EXTEND(SP, len);
1124 EXTEND_MORTAL(len);
1125#if LONGSIZE != SIZE32
1126 if (natint) {
1127 while (len-- > 0) {
1128 COPYNN(s, &along, sizeof(long));
1129 s += sizeof(long);
1130 sv = NEWSV(42, 0);
1131 sv_setiv(sv, (IV)along);
1132 PUSHs(sv_2mortal(sv));
1133 }
1134 }
1135 else
1136#endif
1137 {
1138 while (len-- > 0) {
1139#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1140 I32 along;
1141#endif
1142 COPY32(s, &along);
1143#if LONGSIZE > SIZE32
1144 if (along > 2147483647)
1145 along -= 4294967296;
1146#endif
1147 s += SIZE32;
1148 sv = NEWSV(42, 0);
1149 sv_setiv(sv, (IV)along);
1150 PUSHs(sv_2mortal(sv));
1151 }
1152 }
1153 }
1154 break;
1155 case 'V':
1156 case 'N':
1157 case 'L':
1158#if LONGSIZE == SIZE32
1159 along = (strend - s) / SIZE32;
1160#else
1161 unatint = natint && datumtype == 'L';
1162 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
1163#endif
1164 if (len > along)
1165 len = along;
1166 if (checksum) {
1167#if LONGSIZE != SIZE32
1168 if (unatint) {
1169 unsigned long aulong;
1170 while (len-- > 0) {
1171 COPYNN(s, &aulong, sizeof(unsigned long));
1172 s += sizeof(unsigned long);
fa8ec7c1 1173 if (checksum > bits_in_uv)
a6ec74c1
JH
1174 cdouble += (NV)aulong;
1175 else
92d41999 1176 cuv += aulong;
a6ec74c1
JH
1177 }
1178 }
1179 else
1180#endif
1181 {
1182 while (len-- > 0) {
1183 COPY32(s, &aulong);
1184 s += SIZE32;
1185#ifdef HAS_NTOHL
1186 if (datumtype == 'N')
1187 aulong = PerlSock_ntohl(aulong);
1188#endif
1189#ifdef HAS_VTOHL
1190 if (datumtype == 'V')
1191 aulong = vtohl(aulong);
1192#endif
fa8ec7c1 1193 if (checksum > bits_in_uv)
a6ec74c1
JH
1194 cdouble += (NV)aulong;
1195 else
92d41999 1196 cuv += aulong;
a6ec74c1
JH
1197 }
1198 }
1199 }
1200 else {
1201 EXTEND(SP, len);
1202 EXTEND_MORTAL(len);
1203#if LONGSIZE != SIZE32
1204 if (unatint) {
1205 unsigned long aulong;
1206 while (len-- > 0) {
1207 COPYNN(s, &aulong, sizeof(unsigned long));
1208 s += sizeof(unsigned long);
1209 sv = NEWSV(43, 0);
1210 sv_setuv(sv, (UV)aulong);
1211 PUSHs(sv_2mortal(sv));
1212 }
1213 }
1214 else
1215#endif
1216 {
1217 while (len-- > 0) {
1218 COPY32(s, &aulong);
1219 s += SIZE32;
1220#ifdef HAS_NTOHL
1221 if (datumtype == 'N')
1222 aulong = PerlSock_ntohl(aulong);
1223#endif
1224#ifdef HAS_VTOHL
1225 if (datumtype == 'V')
1226 aulong = vtohl(aulong);
1227#endif
1228 sv = NEWSV(43, 0);
1229 sv_setuv(sv, (UV)aulong);
1230 PUSHs(sv_2mortal(sv));
1231 }
1232 }
1233 }
1234 break;
1235 case 'p':
1236 along = (strend - s) / sizeof(char*);
1237 if (len > along)
1238 len = along;
1239 EXTEND(SP, len);
1240 EXTEND_MORTAL(len);
1241 while (len-- > 0) {
1242 if (sizeof(char*) > strend - s)
1243 break;
1244 else {
1245 Copy(s, &aptr, 1, char*);
1246 s += sizeof(char*);
1247 }
1248 sv = NEWSV(44, 0);
1249 if (aptr)
1250 sv_setpv(sv, aptr);
1251 PUSHs(sv_2mortal(sv));
1252 }
1253 break;
1254 case 'w':
1255 EXTEND(SP, len);
1256 EXTEND_MORTAL(len);
1257 {
1258 UV auv = 0;
1259 U32 bytes = 0;
1260
1261 while ((len > 0) && (s < strend)) {
1262 auv = (auv << 7) | (*s & 0x7f);
1263 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1264 if ((U8)(*s++) < 0x80) {
1265 bytes = 0;
1266 sv = NEWSV(40, 0);
1267 sv_setuv(sv, auv);
1268 PUSHs(sv_2mortal(sv));
1269 len--;
1270 auv = 0;
1271 }
1272 else if (++bytes >= sizeof(UV)) { /* promote to string */
1273 char *t;
1274 STRLEN n_a;
1275
1276 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1277 while (s < strend) {
1278 sv = mul128(sv, *s & 0x7f);
1279 if (!(*s++ & 0x80)) {
1280 bytes = 0;
1281 break;
1282 }
1283 }
1284 t = SvPV(sv, n_a);
1285 while (*t == '0')
1286 t++;
1287 sv_chop(sv, t);
1288 PUSHs(sv_2mortal(sv));
1289 len--;
1290 auv = 0;
1291 }
1292 }
1293 if ((s >= strend) && bytes)
518eff30 1294 Perl_croak(aTHX_ "Unterminated compressed integer");
a6ec74c1
JH
1295 }
1296 break;
1297 case 'P':
18529408 1298 if (star > 0)
518eff30 1299 Perl_croak(aTHX_ "P must have an explicit size");
a6ec74c1
JH
1300 EXTEND(SP, 1);
1301 if (sizeof(char*) > strend - s)
1302 break;
1303 else {
1304 Copy(s, &aptr, 1, char*);
1305 s += sizeof(char*);
1306 }
1307 sv = NEWSV(44, 0);
1308 if (aptr)
1309 sv_setpvn(sv, aptr, len);
1310 PUSHs(sv_2mortal(sv));
1311 break;
1312#ifdef HAS_QUAD
1313 case 'q':
1314 along = (strend - s) / sizeof(Quad_t);
1315 if (len > along)
1316 len = along;
fa8ec7c1
NC
1317 if (checksum) {
1318 while (len-- > 0) {
a6ec74c1
JH
1319 Copy(s, &aquad, 1, Quad_t);
1320 s += sizeof(Quad_t);
fa8ec7c1
NC
1321 if (checksum > bits_in_uv)
1322 cdouble += (NV)aquad;
1323 else
92d41999 1324 cuv += aquad;
a6ec74c1 1325 }
a6ec74c1 1326 }
fa8ec7c1
NC
1327 else {
1328 EXTEND(SP, len);
1329 EXTEND_MORTAL(len);
1330 while (len-- > 0) {
1331 if (s + sizeof(Quad_t) > strend)
1332 aquad = 0;
1333 else {
92d41999
JH
1334 Copy(s, &aquad, 1, Quad_t);
1335 s += sizeof(Quad_t);
fa8ec7c1
NC
1336 }
1337 sv = NEWSV(42, 0);
1338 if (aquad >= IV_MIN && aquad <= IV_MAX)
92d41999 1339 sv_setiv(sv, (IV)aquad);
fa8ec7c1
NC
1340 else
1341 sv_setnv(sv, (NV)aquad);
1342 PUSHs(sv_2mortal(sv));
1343 }
1344 }
a6ec74c1
JH
1345 break;
1346 case 'Q':
206947d2 1347 along = (strend - s) / sizeof(Uquad_t);
a6ec74c1
JH
1348 if (len > along)
1349 len = along;
fa8ec7c1
NC
1350 if (checksum) {
1351 while (len-- > 0) {
a6ec74c1
JH
1352 Copy(s, &auquad, 1, Uquad_t);
1353 s += sizeof(Uquad_t);
fa8ec7c1
NC
1354 if (checksum > bits_in_uv)
1355 cdouble += (NV)auquad;
1356 else
92d41999 1357 cuv += auquad;
a6ec74c1 1358 }
a6ec74c1 1359 }
fa8ec7c1
NC
1360 else {
1361 EXTEND(SP, len);
1362 EXTEND_MORTAL(len);
1363 while (len-- > 0) {
1364 if (s + sizeof(Uquad_t) > strend)
1365 auquad = 0;
1366 else {
1367 Copy(s, &auquad, 1, Uquad_t);
1368 s += sizeof(Uquad_t);
1369 }
1370 sv = NEWSV(43, 0);
1371 if (auquad <= UV_MAX)
1372 sv_setuv(sv, (UV)auquad);
1373 else
1374 sv_setnv(sv, (NV)auquad);
1375 PUSHs(sv_2mortal(sv));
1376 }
1377 }
a6ec74c1
JH
1378 break;
1379#endif
1380 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1381 case 'f':
a6ec74c1
JH
1382 along = (strend - s) / sizeof(float);
1383 if (len > along)
1384 len = along;
1385 if (checksum) {
1386 while (len-- > 0) {
1387 Copy(s, &afloat, 1, float);
1388 s += sizeof(float);
1389 cdouble += afloat;
1390 }
1391 }
1392 else {
1393 EXTEND(SP, len);
1394 EXTEND_MORTAL(len);
1395 while (len-- > 0) {
1396 Copy(s, &afloat, 1, float);
1397 s += sizeof(float);
1398 sv = NEWSV(47, 0);
1399 sv_setnv(sv, (NV)afloat);
1400 PUSHs(sv_2mortal(sv));
1401 }
1402 }
1403 break;
1404 case 'd':
a6ec74c1
JH
1405 along = (strend - s) / sizeof(double);
1406 if (len > along)
1407 len = along;
1408 if (checksum) {
1409 while (len-- > 0) {
1410 Copy(s, &adouble, 1, double);
1411 s += sizeof(double);
1412 cdouble += adouble;
1413 }
1414 }
1415 else {
1416 EXTEND(SP, len);
1417 EXTEND_MORTAL(len);
1418 while (len-- > 0) {
1419 Copy(s, &adouble, 1, double);
1420 s += sizeof(double);
1421 sv = NEWSV(48, 0);
1422 sv_setnv(sv, (NV)adouble);
1423 PUSHs(sv_2mortal(sv));
1424 }
1425 }
1426 break;
92d41999
JH
1427 case 'F':
1428 along = (strend - s) / NVSIZE;
1429 if (len > along)
1430 len = along;
1431 if (checksum) {
1432 while (len-- > 0) {
1433 Copy(s, &anv, 1, NV);
1434 s += NVSIZE;
1435 cdouble += anv;
1436 }
1437 }
1438 else {
1439 EXTEND(SP, len);
1440 EXTEND_MORTAL(len);
1441 while (len-- > 0) {
1442 Copy(s, &anv, 1, NV);
1443 s += NVSIZE;
1444 sv = NEWSV(48, 0);
1445 sv_setnv(sv, anv);
1446 PUSHs(sv_2mortal(sv));
1447 }
1448 }
1449 break;
1450#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1451 case 'D':
1452 along = (strend - s) / LONG_DOUBLESIZE;
1453 if (len > along)
1454 len = along;
1455 if (checksum) {
1456 while (len-- > 0) {
1457 Copy(s, &aldouble, 1, long double);
1458 s += LONG_DOUBLESIZE;
1459 cdouble += aldouble;
1460 }
1461 }
1462 else {
1463 EXTEND(SP, len);
1464 EXTEND_MORTAL(len);
1465 while (len-- > 0) {
1466 Copy(s, &aldouble, 1, long double);
1467 s += LONG_DOUBLESIZE;
1468 sv = NEWSV(48, 0);
1469 sv_setnv(sv, (NV)aldouble);
1470 PUSHs(sv_2mortal(sv));
1471 }
1472 }
1473 break;
1474#endif
a6ec74c1
JH
1475 case 'u':
1476 /* MKS:
1477 * Initialise the decode mapping. By using a table driven
1478 * algorithm, the code will be character-set independent
1479 * (and just as fast as doing character arithmetic)
1480 */
1481 if (PL_uudmap['M'] == 0) {
1482 int i;
1483
1484 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1485 PL_uudmap[(U8)PL_uuemap[i]] = i;
1486 /*
1487 * Because ' ' and '`' map to the same value,
1488 * we need to decode them both the same.
1489 */
1490 PL_uudmap[' '] = 0;
1491 }
1492
1493 along = (strend - s) * 3 / 4;
1494 sv = NEWSV(42, along);
1495 if (along)
1496 SvPOK_on(sv);
1497 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1498 I32 a, b, c, d;
1499 char hunk[4];
1500
1501 hunk[3] = '\0';
1502 len = PL_uudmap[*(U8*)s++] & 077;
1503 while (len > 0) {
1504 if (s < strend && ISUUCHAR(*s))
1505 a = PL_uudmap[*(U8*)s++] & 077;
1506 else
1507 a = 0;
1508 if (s < strend && ISUUCHAR(*s))
1509 b = PL_uudmap[*(U8*)s++] & 077;
1510 else
1511 b = 0;
1512 if (s < strend && ISUUCHAR(*s))
1513 c = PL_uudmap[*(U8*)s++] & 077;
1514 else
1515 c = 0;
1516 if (s < strend && ISUUCHAR(*s))
1517 d = PL_uudmap[*(U8*)s++] & 077;
1518 else
1519 d = 0;
1520 hunk[0] = (a << 2) | (b >> 4);
1521 hunk[1] = (b << 4) | (c >> 2);
1522 hunk[2] = (c << 6) | d;
1523 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1524 len -= 3;
1525 }
1526 if (*s == '\n')
1527 s++;
92aa5668
JH
1528 else /* possible checksum byte */
1529 if (s + 1 < strend && s[1] == '\n')
1530 s += 2;
a6ec74c1
JH
1531 }
1532 XPUSHs(sv_2mortal(sv));
1533 break;
1534 }
1535 if (checksum) {
1536 sv = NEWSV(42, 0);
1537 if (strchr("fFdD", datumtype) ||
92d41999
JH
1538 (checksum > bits_in_uv &&
1539 strchr("csSiIlLnNUvVqQjJ", datumtype)) ) {
a6ec74c1
JH
1540 NV trouble;
1541
fa8ec7c1 1542 adouble = (NV) (1 << (checksum & 15));
a6ec74c1
JH
1543 while (checksum >= 16) {
1544 checksum -= 16;
1545 adouble *= 65536.0;
1546 }
a6ec74c1
JH
1547 while (cdouble < 0.0)
1548 cdouble += adouble;
1549 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1550 sv_setnv(sv, cdouble);
1551 }
1552 else {
fa8ec7c1
NC
1553 if (checksum < bits_in_uv) {
1554 UV mask = ((UV)1 << checksum) - 1;
92d41999
JH
1555
1556 cuv &= mask;
a6ec74c1 1557 }
92d41999 1558 sv_setuv(sv, cuv);
a6ec74c1
JH
1559 }
1560 XPUSHs(sv_2mortal(sv));
1561 checksum = 0;
1562 }
1563 }
18529408
IZ
1564 if (new_s)
1565 *new_s = s;
1566 PUTBACK;
1567 return SP - PL_stack_base - start_sp_offset;
1568}
1569
1570PP(pp_unpack)
1571{
1572 dSP;
1573 dPOPPOPssrl;
1574 I32 gimme = GIMME_V;
1575 STRLEN llen;
1576 STRLEN rlen;
1577 register char *pat = SvPV(left, llen);
1578#ifdef PACKED_IS_OCTETS
1579 /* Packed side is assumed to be octets - so force downgrade if it
1580 has been UTF-8 encoded by accident
1581 */
1582 register char *s = SvPVbyte(right, rlen);
1583#else
1584 register char *s = SvPV(right, rlen);
1585#endif
1586 char *strend = s + rlen;
1587 register char *patend = pat + llen;
1588 register I32 cnt;
1589
1590 PUTBACK;
1591 cnt = unpack_str(pat, patend, s, s, strend, NULL, 0,
1592 ((gimme == G_SCALAR) ? UNPACK_ONLY_ONE : 0)
1593 | (DO_UTF8(right) ? UNPACK_DO_UTF8 : 0));
1594 SPAGAIN;
1595 if ( !cnt && gimme == G_SCALAR )
1596 PUSHs(&PL_sv_undef);
a6ec74c1
JH
1597 RETURN;
1598}
1599
1600STATIC void
1601S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1602{
1603 char hunk[5];
1604
1605 *hunk = PL_uuemap[len];
1606 sv_catpvn(sv, hunk, 1);
1607 hunk[4] = '\0';
1608 while (len > 2) {
1609 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1610 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1611 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1612 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1613 sv_catpvn(sv, hunk, 4);
1614 s += 3;
1615 len -= 3;
1616 }
1617 if (len > 0) {
1618 char r = (len > 1 ? s[1] : '\0');
1619 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1620 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1621 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1622 hunk[3] = PL_uuemap[0];
1623 sv_catpvn(sv, hunk, 4);
1624 }
1625 sv_catpvn(sv, "\n", 1);
1626}
1627
1628STATIC SV *
1629S_is_an_int(pTHX_ char *s, STRLEN l)
1630{
1631 STRLEN n_a;
1632 SV *result = newSVpvn(s, l);
1633 char *result_c = SvPV(result, n_a); /* convenience */
1634 char *out = result_c;
1635 bool skip = 1;
1636 bool ignore = 0;
1637
1638 while (*s) {
1639 switch (*s) {
1640 case ' ':
1641 break;
1642 case '+':
1643 if (!skip) {
1644 SvREFCNT_dec(result);
1645 return (NULL);
1646 }
1647 break;
1648 case '0':
1649 case '1':
1650 case '2':
1651 case '3':
1652 case '4':
1653 case '5':
1654 case '6':
1655 case '7':
1656 case '8':
1657 case '9':
1658 skip = 0;
1659 if (!ignore) {
1660 *(out++) = *s;
1661 }
1662 break;
1663 case '.':
1664 ignore = 1;
1665 break;
1666 default:
1667 SvREFCNT_dec(result);
1668 return (NULL);
1669 }
1670 s++;
1671 }
1672 *(out++) = '\0';
1673 SvCUR_set(result, out - result_c);
1674 return (result);
1675}
1676
1677/* pnum must be '\0' terminated */
1678STATIC int
1679S_div128(pTHX_ SV *pnum, bool *done)
1680{
1681 STRLEN len;
1682 char *s = SvPV(pnum, len);
1683 int m = 0;
1684 int r = 0;
1685 char *t = s;
1686
1687 *done = 1;
1688 while (*t) {
1689 int i;
1690
1691 i = m * 10 + (*t - '0');
1692 m = i & 0x7F;
1693 r = (i >> 7); /* r < 10 */
1694 if (r) {
1695 *done = 0;
1696 }
1697 *(t++) = '0' + r;
1698 }
1699 *(t++) = '\0';
1700 SvCUR_set(pnum, (STRLEN) (t - s));
1701 return (m);
1702}
1703
18529408 1704#define PACK_CHILD 0x1
a6ec74c1 1705
18529408
IZ
1706/*
1707=for apidoc pack_cat
1708
1709The engine implementing pack() Perl function.
1710
1711=cut */
1712
1713void
1714Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
a6ec74c1 1715{
a6ec74c1
JH
1716 register I32 items;
1717 STRLEN fromlen;
a6ec74c1
JH
1718 register I32 len;
1719 I32 datumtype;
1720 SV *fromstr;
1721 /*SUPPRESS 442*/
1722 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1723 static char *space10 = " ";
18529408 1724 int star;
a6ec74c1
JH
1725
1726 /* These must not be in registers: */
1727 char achar;
1728 I16 ashort;
1729 int aint;
1730 unsigned int auint;
1731 I32 along;
1732 U32 aulong;
92d41999
JH
1733 IV aiv;
1734 UV auv;
1735 NV anv;
1736#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1737 long double aldouble;
1738#endif
a6ec74c1
JH
1739#ifdef HAS_QUAD
1740 Quad_t aquad;
1741 Uquad_t auquad;
1742#endif
1743 char *aptr;
1744 float afloat;
1745 double adouble;
1746 int commas = 0;
1747#ifdef PERL_NATINT_PACK
1748 int natint; /* native integer */
1749#endif
1750
18529408
IZ
1751 items = endlist - beglist;
1752#ifndef PACKED_IS_OCTETS
1753 pat = next_symbol(pat, patend);
1754 if (pat < patend && *pat == 'U' && !flags)
1755 SvUTF8_on(cat);
1756#endif
1757 while ((pat = next_symbol(pat, patend)) < patend) {
a6ec74c1 1758 SV *lengthcode = Nullsv;
18529408 1759#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
a6ec74c1
JH
1760 datumtype = *pat++ & 0xFF;
1761#ifdef PERL_NATINT_PACK
1762 natint = 0;
1763#endif
a6ec74c1 1764 if (*pat == '!') {
62f95557 1765 static const char natstr[] = "sSiIlLxX";
a6ec74c1
JH
1766
1767 if (strchr(natstr, datumtype)) {
62f95557
IZ
1768 if (datumtype == 'x' || datumtype == 'X') {
1769 datumtype |= TYPE_IS_SHRIEKING;
1770 } else { /* XXXX Should be redone similarly! */
a6ec74c1 1771#ifdef PERL_NATINT_PACK
62f95557 1772 natint = 1;
a6ec74c1 1773#endif
62f95557 1774 }
a6ec74c1
JH
1775 pat++;
1776 }
1777 else
518eff30 1778 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
a6ec74c1 1779 }
18529408
IZ
1780 len = find_count(&pat, patend, &star);
1781 if (star > 0) /* Count is '*' */
a6ec74c1 1782 len = strchr("@Xxu", datumtype) ? 0 : items;
18529408 1783 else if (star < 0) /* Default len */
a6ec74c1 1784 len = 1;
18529408 1785 if (*pat == '/') { /* doing lookahead how... */
a6ec74c1
JH
1786 ++pat;
1787 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
518eff30 1788 Perl_croak(aTHX_ "/ must be followed by a*, A* or Z*");
a6ec74c1 1789 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
18529408 1790 ? *beglist : &PL_sv_no)
a6ec74c1
JH
1791 + (*pat == 'Z' ? 1 : 0)));
1792 }
1793 switch(datumtype) {
1794 default:
518eff30 1795 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
a6ec74c1
JH
1796 case ',': /* grandfather in commas but with a warning */
1797 if (commas++ == 0 && ckWARN(WARN_PACK))
9014280d 1798 Perl_warner(aTHX_ packWARN(WARN_PACK),
a6ec74c1
JH
1799 "Invalid type in pack: '%c'", (int)datumtype);
1800 break;
1801 case '%':
518eff30 1802 Perl_croak(aTHX_ "%% may only be used in unpack");
a6ec74c1
JH
1803 case '@':
1804 len -= SvCUR(cat);
1805 if (len > 0)
1806 goto grow;
1807 len = -len;
1808 if (len > 0)
1809 goto shrink;
1810 break;
18529408
IZ
1811 case '(':
1812 {
1813 char *beg = pat;
1814 SV **savebeglist = beglist; /* beglist de-register-ed */
1815
1816 if (star >= 0)
518eff30 1817 Perl_croak(aTHX_ "()-group starts with a count");
18529408
IZ
1818 aptr = group_end(beg, patend, ')');
1819 pat = aptr + 1;
1820 if (star != -2) {
1821 len = find_count(&pat, patend, &star);
1822 if (star < 0) /* No count */
1823 len = 1;
1824 else if (star > 0) /* Star */
1825 len = items; /* long enough? */
1826 }
1827 while (len--) {
1828 pack_cat(cat, beg, aptr, savebeglist, endlist,
1829 &savebeglist, PACK_CHILD);
1830 if (star > 0 && savebeglist == endlist)
1831 break; /* No way to continue */
1832 }
1833 beglist = savebeglist;
1834 break;
1835 }
62f95557
IZ
1836 case 'X' | TYPE_IS_SHRIEKING:
1837 if (!len) /* Avoid division by 0 */
1838 len = 1;
1839 len = (SvCUR(cat)) % len;
1840 /* FALL THROUGH */
a6ec74c1
JH
1841 case 'X':
1842 shrink:
1843 if (SvCUR(cat) < len)
518eff30 1844 Perl_croak(aTHX_ "X outside of string");
a6ec74c1
JH
1845 SvCUR(cat) -= len;
1846 *SvEND(cat) = '\0';
1847 break;
62f95557
IZ
1848 case 'x' | TYPE_IS_SHRIEKING:
1849 if (!len) /* Avoid division by 0 */
1850 len = 1;
1851 aint = (SvCUR(cat)) % len;
1852 if (aint) /* Other portable ways? */
1853 len = len - aint;
1854 else
1855 len = 0;
1856 /* FALL THROUGH */
a6ec74c1
JH
1857 case 'x':
1858 grow:
1859 while (len >= 10) {
1860 sv_catpvn(cat, null10, 10);
1861 len -= 10;
1862 }
1863 sv_catpvn(cat, null10, len);
1864 break;
1865 case 'A':
1866 case 'Z':
1867 case 'a':
1868 fromstr = NEXTFROM;
1869 aptr = SvPV(fromstr, fromlen);
18529408 1870 if (star > 0) { /* -2 after '/' */
a6ec74c1
JH
1871 len = fromlen;
1872 if (datumtype == 'Z')
1873 ++len;
1874 }
1875 if (fromlen >= len) {
1876 sv_catpvn(cat, aptr, len);
1877 if (datumtype == 'Z')
1878 *(SvEND(cat)-1) = '\0';
1879 }
1880 else {
1881 sv_catpvn(cat, aptr, fromlen);
1882 len -= fromlen;
1883 if (datumtype == 'A') {
1884 while (len >= 10) {
1885 sv_catpvn(cat, space10, 10);
1886 len -= 10;
1887 }
1888 sv_catpvn(cat, space10, len);
1889 }
1890 else {
1891 while (len >= 10) {
1892 sv_catpvn(cat, null10, 10);
1893 len -= 10;
1894 }
1895 sv_catpvn(cat, null10, len);
1896 }
1897 }
1898 break;
1899 case 'B':
1900 case 'b':
1901 {
1902 register char *str;
1903 I32 saveitems;
1904
1905 fromstr = NEXTFROM;
1906 saveitems = items;
1907 str = SvPV(fromstr, fromlen);
18529408 1908 if (star > 0)
a6ec74c1
JH
1909 len = fromlen;
1910 aint = SvCUR(cat);
1911 SvCUR(cat) += (len+7)/8;
1912 SvGROW(cat, SvCUR(cat) + 1);
1913 aptr = SvPVX(cat) + aint;
1914 if (len > fromlen)
1915 len = fromlen;
1916 aint = len;
1917 items = 0;
1918 if (datumtype == 'B') {
1919 for (len = 0; len++ < aint;) {
1920 items |= *str++ & 1;
1921 if (len & 7)
1922 items <<= 1;
1923 else {
1924 *aptr++ = items & 0xff;
1925 items = 0;
1926 }
1927 }
1928 }
1929 else {
1930 for (len = 0; len++ < aint;) {
1931 if (*str++ & 1)
1932 items |= 128;
1933 if (len & 7)
1934 items >>= 1;
1935 else {
1936 *aptr++ = items & 0xff;
1937 items = 0;
1938 }
1939 }
1940 }
1941 if (aint & 7) {
1942 if (datumtype == 'B')
1943 items <<= 7 - (aint & 7);
1944 else
1945 items >>= 7 - (aint & 7);
1946 *aptr++ = items & 0xff;
1947 }
1948 str = SvPVX(cat) + SvCUR(cat);
1949 while (aptr <= str)
1950 *aptr++ = '\0';
1951
1952 items = saveitems;
1953 }
1954 break;
1955 case 'H':
1956 case 'h':
1957 {
1958 register char *str;
1959 I32 saveitems;
1960
1961 fromstr = NEXTFROM;
1962 saveitems = items;
1963 str = SvPV(fromstr, fromlen);
18529408 1964 if (star > 0)
a6ec74c1
JH
1965 len = fromlen;
1966 aint = SvCUR(cat);
1967 SvCUR(cat) += (len+1)/2;
1968 SvGROW(cat, SvCUR(cat) + 1);
1969 aptr = SvPVX(cat) + aint;
1970 if (len > fromlen)
1971 len = fromlen;
1972 aint = len;
1973 items = 0;
1974 if (datumtype == 'H') {
1975 for (len = 0; len++ < aint;) {
1976 if (isALPHA(*str))
1977 items |= ((*str++ & 15) + 9) & 15;
1978 else
1979 items |= *str++ & 15;
1980 if (len & 1)
1981 items <<= 4;
1982 else {
1983 *aptr++ = items & 0xff;
1984 items = 0;
1985 }
1986 }
1987 }
1988 else {
1989 for (len = 0; len++ < aint;) {
1990 if (isALPHA(*str))
1991 items |= (((*str++ & 15) + 9) & 15) << 4;
1992 else
1993 items |= (*str++ & 15) << 4;
1994 if (len & 1)
1995 items >>= 4;
1996 else {
1997 *aptr++ = items & 0xff;
1998 items = 0;
1999 }
2000 }
2001 }
2002 if (aint & 1)
2003 *aptr++ = items & 0xff;
2004 str = SvPVX(cat) + SvCUR(cat);
2005 while (aptr <= str)
2006 *aptr++ = '\0';
2007
2008 items = saveitems;
2009 }
2010 break;
2011 case 'C':
2012 case 'c':
2013 while (len-- > 0) {
2014 fromstr = NEXTFROM;
2015 switch (datumtype) {
2016 case 'C':
2017 aint = SvIV(fromstr);
2018 if ((aint < 0 || aint > 255) &&
2019 ckWARN(WARN_PACK))
9014280d 2020 Perl_warner(aTHX_ packWARN(WARN_PACK),
a6ec74c1
JH
2021 "Character in \"C\" format wrapped");
2022 achar = aint & 255;
2023 sv_catpvn(cat, &achar, sizeof(char));
2024 break;
2025 case 'c':
2026 aint = SvIV(fromstr);
2027 if ((aint < -128 || aint > 127) &&
2028 ckWARN(WARN_PACK))
9014280d 2029 Perl_warner(aTHX_ packWARN(WARN_PACK),
a6ec74c1
JH
2030 "Character in \"c\" format wrapped");
2031 achar = aint & 255;
2032 sv_catpvn(cat, &achar, sizeof(char));
2033 break;
2034 }
2035 }
2036 break;
2037 case 'U':
2038 while (len-- > 0) {
2039 fromstr = NEXTFROM;
e87322b2 2040 auint = UNI_TO_NATIVE(SvUV(fromstr));
a6ec74c1 2041 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
52ea3e69
JH
2042 SvCUR_set(cat,
2043 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2044 auint,
2045 ckWARN(WARN_UTF8) ?
2046 0 : UNICODE_ALLOW_ANY)
2047 - SvPVX(cat));
a6ec74c1
JH
2048 }
2049 *SvEND(cat) = '\0';
2050 break;
2051 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2052 case 'f':
a6ec74c1
JH
2053 while (len-- > 0) {
2054 fromstr = NEXTFROM;
5cdb9e01
PG
2055#ifdef __VOS__
2056/* VOS does not automatically map a floating-point overflow
2057 during conversion from double to float into infinity, so we
2058 do it by hand. This code should either be generalized for
2059 any OS that needs it, or removed if and when VOS implements
2060 posix-976 (suggestion to support mapping to infinity).
2061 Paul.Green@stratus.com 02-04-02. */
2062 if (SvNV(fromstr) > FLT_MAX)
2063 afloat = _float_constants[0]; /* single prec. inf. */
2064 else if (SvNV(fromstr) < -FLT_MAX)
2065 afloat = _float_constants[0]; /* single prec. inf. */
2066 else afloat = (float)SvNV(fromstr);
2067#else
a6ec74c1 2068 afloat = (float)SvNV(fromstr);
5cdb9e01 2069#endif
a6ec74c1
JH
2070 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2071 }
2072 break;
2073 case 'd':
a6ec74c1
JH
2074 while (len-- > 0) {
2075 fromstr = NEXTFROM;
5cdb9e01
PG
2076#ifdef __VOS__
2077/* VOS does not automatically map a floating-point overflow
2078 during conversion from long double to double into infinity,
2079 so we do it by hand. This code should either be generalized
2080 for any OS that needs it, or removed if and when VOS
2081 implements posix-976 (suggestion to support mapping to
2082 infinity). Paul.Green@stratus.com 02-04-02. */
2083 if (SvNV(fromstr) > DBL_MAX)
2084 adouble = _double_constants[0]; /* double prec. inf. */
2085 else if (SvNV(fromstr) < -DBL_MAX)
2086 adouble = _double_constants[0]; /* double prec. inf. */
2087 else adouble = (double)SvNV(fromstr);
2088#else
a6ec74c1 2089 adouble = (double)SvNV(fromstr);
5cdb9e01 2090#endif
a6ec74c1
JH
2091 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2092 }
2093 break;
92d41999
JH
2094 case 'F':
2095 while (len-- > 0) {
2096 fromstr = NEXTFROM;
2097 anv = SvNV(fromstr);
2098 sv_catpvn(cat, (char *)&anv, NVSIZE);
2099 }
2100 break;
2101#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2102 case 'D':
2103 while (len-- > 0) {
2104 fromstr = NEXTFROM;
2105 aldouble = (long double)SvNV(fromstr);
2106 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2107 }
2108 break;
2109#endif
a6ec74c1
JH
2110 case 'n':
2111 while (len-- > 0) {
2112 fromstr = NEXTFROM;
2113 ashort = (I16)SvIV(fromstr);
2114#ifdef HAS_HTONS
2115 ashort = PerlSock_htons(ashort);
2116#endif
2117 CAT16(cat, &ashort);
2118 }
2119 break;
2120 case 'v':
2121 while (len-- > 0) {
2122 fromstr = NEXTFROM;
2123 ashort = (I16)SvIV(fromstr);
2124#ifdef HAS_HTOVS
2125 ashort = htovs(ashort);
2126#endif
2127 CAT16(cat, &ashort);
2128 }
2129 break;
2130 case 'S':
2131#if SHORTSIZE != SIZE16
2132 if (natint) {
2133 unsigned short aushort;
2134
2135 while (len-- > 0) {
2136 fromstr = NEXTFROM;
2137 aushort = SvUV(fromstr);
2138 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2139 }
2140 }
2141 else
2142#endif
2143 {
2144 U16 aushort;
2145
2146 while (len-- > 0) {
2147 fromstr = NEXTFROM;
2148 aushort = (U16)SvUV(fromstr);
2149 CAT16(cat, &aushort);
2150 }
2151
2152 }
2153 break;
2154 case 's':
2155#if SHORTSIZE != SIZE16
2156 if (natint) {
2157 short ashort;
2158
2159 while (len-- > 0) {
2160 fromstr = NEXTFROM;
2161 ashort = SvIV(fromstr);
2162 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2163 }
2164 }
2165 else
2166#endif
2167 {
2168 while (len-- > 0) {
2169 fromstr = NEXTFROM;
2170 ashort = (I16)SvIV(fromstr);
2171 CAT16(cat, &ashort);
2172 }
2173 }
2174 break;
2175 case 'I':
2176 while (len-- > 0) {
2177 fromstr = NEXTFROM;
2178 auint = SvUV(fromstr);
2179 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2180 }
2181 break;
92d41999
JH
2182 case 'j':
2183 while (len-- > 0) {
2184 fromstr = NEXTFROM;
2185 aiv = SvIV(fromstr);
2186 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2187 }
2188 break;
2189 case 'J':
2190 while (len-- > 0) {
2191 fromstr = NEXTFROM;
2192 auv = SvUV(fromstr);
2193 sv_catpvn(cat, (char*)&auv, UVSIZE);
2194 }
2195 break;
a6ec74c1
JH
2196 case 'w':
2197 while (len-- > 0) {
2198 fromstr = NEXTFROM;
196b62db 2199 adouble = SvNV(fromstr);
a6ec74c1
JH
2200
2201 if (adouble < 0)
518eff30 2202 Perl_croak(aTHX_ "Cannot compress negative numbers");
a6ec74c1 2203
196b62db
NC
2204 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2205 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2206 any negative IVs will have already been got by the croak()
2207 above. IOK is untrue for fractions, so we test them
2208 against UV_MAX_P1. */
2209 if (SvIOK(fromstr) || adouble < UV_MAX_P1)
a6ec74c1 2210 {
7c1b502b 2211 char buf[(sizeof(UV)*8)/7+1];
a6ec74c1 2212 char *in = buf + sizeof(buf);
196b62db 2213 UV auv = SvUV(fromstr);
a6ec74c1
JH
2214
2215 do {
2216 *--in = (auv & 0x7f) | 0x80;
2217 auv >>= 7;
2218 } while (auv);
2219 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2220 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2221 }
2222 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2223 char *from, *result, *in;
2224 SV *norm;
2225 STRLEN len;
2226 bool done;
2227
2228 /* Copy string and check for compliance */
2229 from = SvPV(fromstr, len);
2230 if ((norm = is_an_int(from, len)) == NULL)
518eff30 2231 Perl_croak(aTHX_ "can compress only unsigned integer");
a6ec74c1
JH
2232
2233 New('w', result, len, char);
2234 in = result + len;
2235 done = FALSE;
2236 while (!done)
2237 *--in = div128(norm, &done) | 0x80;
2238 result[len - 1] &= 0x7F; /* clear continue bit */
2239 sv_catpvn(cat, in, (result + len) - in);
2240 Safefree(result);
2241 SvREFCNT_dec(norm); /* free norm */
2242 }
2243 else if (SvNOKp(fromstr)) {
2244 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
2245 char *in = buf + sizeof(buf);
2246
196b62db 2247 adouble = Perl_floor(adouble);
a6ec74c1
JH
2248 do {
2249 double next = floor(adouble / 128);
2250 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2251 if (in <= buf) /* this cannot happen ;-) */
518eff30 2252 Perl_croak(aTHX_ "Cannot compress integer");
a6ec74c1
JH
2253 adouble = next;
2254 } while (adouble > 0);
2255 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2256 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2257 }
735b914b
JH
2258 else {
2259 char *from, *result, *in;
2260 SV *norm;
2261 STRLEN len;
2262 bool done;
2263
2264 /* Copy string and check for compliance */
2265 from = SvPV(fromstr, len);
2266 if ((norm = is_an_int(from, len)) == NULL)
518eff30 2267 Perl_croak(aTHX_ "can compress only unsigned integer");
735b914b
JH
2268
2269 New('w', result, len, char);
2270 in = result + len;
2271 done = FALSE;
2272 while (!done)
2273 *--in = div128(norm, &done) | 0x80;
2274 result[len - 1] &= 0x7F; /* clear continue bit */
2275 sv_catpvn(cat, in, (result + len) - in);
2276 Safefree(result);
2277 SvREFCNT_dec(norm); /* free norm */
2278 }
a6ec74c1
JH
2279 }
2280 break;
2281 case 'i':
2282 while (len-- > 0) {
2283 fromstr = NEXTFROM;
2284 aint = SvIV(fromstr);
2285 sv_catpvn(cat, (char*)&aint, sizeof(int));
2286 }
2287 break;
2288 case 'N':
2289 while (len-- > 0) {
2290 fromstr = NEXTFROM;
2291 aulong = SvUV(fromstr);
2292#ifdef HAS_HTONL
2293 aulong = PerlSock_htonl(aulong);
2294#endif
2295 CAT32(cat, &aulong);
2296 }
2297 break;
2298 case 'V':
2299 while (len-- > 0) {
2300 fromstr = NEXTFROM;
2301 aulong = SvUV(fromstr);
2302#ifdef HAS_HTOVL
2303 aulong = htovl(aulong);
2304#endif
2305 CAT32(cat, &aulong);
2306 }
2307 break;
2308 case 'L':
2309#if LONGSIZE != SIZE32
2310 if (natint) {
2311 unsigned long aulong;
2312
2313 while (len-- > 0) {
2314 fromstr = NEXTFROM;
2315 aulong = SvUV(fromstr);
2316 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2317 }
2318 }
2319 else
2320#endif
2321 {
2322 while (len-- > 0) {
2323 fromstr = NEXTFROM;
2324 aulong = SvUV(fromstr);
2325 CAT32(cat, &aulong);
2326 }
2327 }
2328 break;
2329 case 'l':
2330#if LONGSIZE != SIZE32
2331 if (natint) {
2332 long along;
2333
2334 while (len-- > 0) {
2335 fromstr = NEXTFROM;
2336 along = SvIV(fromstr);
2337 sv_catpvn(cat, (char *)&along, sizeof(long));
2338 }
2339 }
2340 else
2341#endif
2342 {
2343 while (len-- > 0) {
2344 fromstr = NEXTFROM;
2345 along = SvIV(fromstr);
2346 CAT32(cat, &along);
2347 }
2348 }
2349 break;
2350#ifdef HAS_QUAD
2351 case 'Q':
2352 while (len-- > 0) {
2353 fromstr = NEXTFROM;
2354 auquad = (Uquad_t)SvUV(fromstr);
2355 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2356 }
2357 break;
2358 case 'q':
2359 while (len-- > 0) {
2360 fromstr = NEXTFROM;
2361 aquad = (Quad_t)SvIV(fromstr);
2362 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2363 }
2364 break;
2365#endif
2366 case 'P':
2367 len = 1; /* assume SV is correct length */
2368 /* FALL THROUGH */
2369 case 'p':
2370 while (len-- > 0) {
2371 fromstr = NEXTFROM;
2372 if (fromstr == &PL_sv_undef)
2373 aptr = NULL;
2374 else {
2375 STRLEN n_a;
2376 /* XXX better yet, could spirit away the string to
2377 * a safe spot and hang on to it until the result
2378 * of pack() (and all copies of the result) are
2379 * gone.
2380 */
2381 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2382 || (SvPADTMP(fromstr)
2383 && !SvREADONLY(fromstr))))
2384 {
9014280d 2385 Perl_warner(aTHX_ packWARN(WARN_PACK),
a6ec74c1
JH
2386 "Attempt to pack pointer to temporary value");
2387 }
2388 if (SvPOK(fromstr) || SvNIOK(fromstr))
2389 aptr = SvPV(fromstr,n_a);
2390 else
2391 aptr = SvPV_force(fromstr,n_a);
2392 }
2393 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2394 }
2395 break;
2396 case 'u':
2397 fromstr = NEXTFROM;
2398 aptr = SvPV(fromstr, fromlen);
2399 SvGROW(cat, fromlen * 4 / 3);
19c9db5e 2400 if (len <= 2)
a6ec74c1
JH
2401 len = 45;
2402 else
2403 len = len / 3 * 3;
2404 while (fromlen > 0) {
2405 I32 todo;
2406
2407 if (fromlen > len)
2408 todo = len;
2409 else
2410 todo = fromlen;
2411 doencodes(cat, aptr, todo);
2412 fromlen -= todo;
2413 aptr += todo;
2414 }
2415 break;
2416 }
2417 }
18529408
IZ
2418 if (next_in_list)
2419 *next_in_list = beglist;
2420}
2421#undef NEXTFROM
2422
2423
2424PP(pp_pack)
2425{
2426 dSP; dMARK; dORIGMARK; dTARGET;
2427 register SV *cat = TARG;
2428 STRLEN fromlen;
2429 register char *pat = SvPVx(*++MARK, fromlen);
2430 register char *patend = pat + fromlen;
2431
2432 MARK++;
2433 sv_setpvn(cat, "", 0);
2434
2435 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);
2436
a6ec74c1
JH
2437 SvSETMAGIC(cat);
2438 SP = ORIGMARK;
2439 PUSHs(cat);
2440 RETURN;
2441}
a6ec74c1 2442