This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Tie::File 0.93, from mjd.
[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;
2055 afloat = (float)SvNV(fromstr);
2056 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2057 }
2058 break;
2059 case 'd':
a6ec74c1
JH
2060 while (len-- > 0) {
2061 fromstr = NEXTFROM;
2062 adouble = (double)SvNV(fromstr);
2063 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2064 }
2065 break;
92d41999
JH
2066 case 'F':
2067 while (len-- > 0) {
2068 fromstr = NEXTFROM;
2069 anv = SvNV(fromstr);
2070 sv_catpvn(cat, (char *)&anv, NVSIZE);
2071 }
2072 break;
2073#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2074 case 'D':
2075 while (len-- > 0) {
2076 fromstr = NEXTFROM;
2077 aldouble = (long double)SvNV(fromstr);
2078 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2079 }
2080 break;
2081#endif
a6ec74c1
JH
2082 case 'n':
2083 while (len-- > 0) {
2084 fromstr = NEXTFROM;
2085 ashort = (I16)SvIV(fromstr);
2086#ifdef HAS_HTONS
2087 ashort = PerlSock_htons(ashort);
2088#endif
2089 CAT16(cat, &ashort);
2090 }
2091 break;
2092 case 'v':
2093 while (len-- > 0) {
2094 fromstr = NEXTFROM;
2095 ashort = (I16)SvIV(fromstr);
2096#ifdef HAS_HTOVS
2097 ashort = htovs(ashort);
2098#endif
2099 CAT16(cat, &ashort);
2100 }
2101 break;
2102 case 'S':
2103#if SHORTSIZE != SIZE16
2104 if (natint) {
2105 unsigned short aushort;
2106
2107 while (len-- > 0) {
2108 fromstr = NEXTFROM;
2109 aushort = SvUV(fromstr);
2110 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2111 }
2112 }
2113 else
2114#endif
2115 {
2116 U16 aushort;
2117
2118 while (len-- > 0) {
2119 fromstr = NEXTFROM;
2120 aushort = (U16)SvUV(fromstr);
2121 CAT16(cat, &aushort);
2122 }
2123
2124 }
2125 break;
2126 case 's':
2127#if SHORTSIZE != SIZE16
2128 if (natint) {
2129 short ashort;
2130
2131 while (len-- > 0) {
2132 fromstr = NEXTFROM;
2133 ashort = SvIV(fromstr);
2134 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2135 }
2136 }
2137 else
2138#endif
2139 {
2140 while (len-- > 0) {
2141 fromstr = NEXTFROM;
2142 ashort = (I16)SvIV(fromstr);
2143 CAT16(cat, &ashort);
2144 }
2145 }
2146 break;
2147 case 'I':
2148 while (len-- > 0) {
2149 fromstr = NEXTFROM;
2150 auint = SvUV(fromstr);
2151 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2152 }
2153 break;
92d41999
JH
2154 case 'j':
2155 while (len-- > 0) {
2156 fromstr = NEXTFROM;
2157 aiv = SvIV(fromstr);
2158 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2159 }
2160 break;
2161 case 'J':
2162 while (len-- > 0) {
2163 fromstr = NEXTFROM;
2164 auv = SvUV(fromstr);
2165 sv_catpvn(cat, (char*)&auv, UVSIZE);
2166 }
2167 break;
a6ec74c1
JH
2168 case 'w':
2169 while (len-- > 0) {
2170 fromstr = NEXTFROM;
196b62db 2171 adouble = SvNV(fromstr);
a6ec74c1
JH
2172
2173 if (adouble < 0)
518eff30 2174 Perl_croak(aTHX_ "Cannot compress negative numbers");
a6ec74c1 2175
196b62db
NC
2176 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2177 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2178 any negative IVs will have already been got by the croak()
2179 above. IOK is untrue for fractions, so we test them
2180 against UV_MAX_P1. */
2181 if (SvIOK(fromstr) || adouble < UV_MAX_P1)
a6ec74c1 2182 {
7c1b502b 2183 char buf[(sizeof(UV)*8)/7+1];
a6ec74c1 2184 char *in = buf + sizeof(buf);
196b62db 2185 UV auv = SvUV(fromstr);
a6ec74c1
JH
2186
2187 do {
2188 *--in = (auv & 0x7f) | 0x80;
2189 auv >>= 7;
2190 } while (auv);
2191 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2192 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2193 }
2194 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2195 char *from, *result, *in;
2196 SV *norm;
2197 STRLEN len;
2198 bool done;
2199
2200 /* Copy string and check for compliance */
2201 from = SvPV(fromstr, len);
2202 if ((norm = is_an_int(from, len)) == NULL)
518eff30 2203 Perl_croak(aTHX_ "can compress only unsigned integer");
a6ec74c1
JH
2204
2205 New('w', result, len, char);
2206 in = result + len;
2207 done = FALSE;
2208 while (!done)
2209 *--in = div128(norm, &done) | 0x80;
2210 result[len - 1] &= 0x7F; /* clear continue bit */
2211 sv_catpvn(cat, in, (result + len) - in);
2212 Safefree(result);
2213 SvREFCNT_dec(norm); /* free norm */
2214 }
2215 else if (SvNOKp(fromstr)) {
2216 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
2217 char *in = buf + sizeof(buf);
2218
196b62db 2219 adouble = Perl_floor(adouble);
a6ec74c1
JH
2220 do {
2221 double next = floor(adouble / 128);
2222 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
2223 if (in <= buf) /* this cannot happen ;-) */
518eff30 2224 Perl_croak(aTHX_ "Cannot compress integer");
a6ec74c1
JH
2225 adouble = next;
2226 } while (adouble > 0);
2227 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2228 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2229 }
735b914b
JH
2230 else {
2231 char *from, *result, *in;
2232 SV *norm;
2233 STRLEN len;
2234 bool done;
2235
2236 /* Copy string and check for compliance */
2237 from = SvPV(fromstr, len);
2238 if ((norm = is_an_int(from, len)) == NULL)
518eff30 2239 Perl_croak(aTHX_ "can compress only unsigned integer");
735b914b
JH
2240
2241 New('w', result, len, char);
2242 in = result + len;
2243 done = FALSE;
2244 while (!done)
2245 *--in = div128(norm, &done) | 0x80;
2246 result[len - 1] &= 0x7F; /* clear continue bit */
2247 sv_catpvn(cat, in, (result + len) - in);
2248 Safefree(result);
2249 SvREFCNT_dec(norm); /* free norm */
2250 }
a6ec74c1
JH
2251 }
2252 break;
2253 case 'i':
2254 while (len-- > 0) {
2255 fromstr = NEXTFROM;
2256 aint = SvIV(fromstr);
2257 sv_catpvn(cat, (char*)&aint, sizeof(int));
2258 }
2259 break;
2260 case 'N':
2261 while (len-- > 0) {
2262 fromstr = NEXTFROM;
2263 aulong = SvUV(fromstr);
2264#ifdef HAS_HTONL
2265 aulong = PerlSock_htonl(aulong);
2266#endif
2267 CAT32(cat, &aulong);
2268 }
2269 break;
2270 case 'V':
2271 while (len-- > 0) {
2272 fromstr = NEXTFROM;
2273 aulong = SvUV(fromstr);
2274#ifdef HAS_HTOVL
2275 aulong = htovl(aulong);
2276#endif
2277 CAT32(cat, &aulong);
2278 }
2279 break;
2280 case 'L':
2281#if LONGSIZE != SIZE32
2282 if (natint) {
2283 unsigned long aulong;
2284
2285 while (len-- > 0) {
2286 fromstr = NEXTFROM;
2287 aulong = SvUV(fromstr);
2288 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2289 }
2290 }
2291 else
2292#endif
2293 {
2294 while (len-- > 0) {
2295 fromstr = NEXTFROM;
2296 aulong = SvUV(fromstr);
2297 CAT32(cat, &aulong);
2298 }
2299 }
2300 break;
2301 case 'l':
2302#if LONGSIZE != SIZE32
2303 if (natint) {
2304 long along;
2305
2306 while (len-- > 0) {
2307 fromstr = NEXTFROM;
2308 along = SvIV(fromstr);
2309 sv_catpvn(cat, (char *)&along, sizeof(long));
2310 }
2311 }
2312 else
2313#endif
2314 {
2315 while (len-- > 0) {
2316 fromstr = NEXTFROM;
2317 along = SvIV(fromstr);
2318 CAT32(cat, &along);
2319 }
2320 }
2321 break;
2322#ifdef HAS_QUAD
2323 case 'Q':
2324 while (len-- > 0) {
2325 fromstr = NEXTFROM;
2326 auquad = (Uquad_t)SvUV(fromstr);
2327 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2328 }
2329 break;
2330 case 'q':
2331 while (len-- > 0) {
2332 fromstr = NEXTFROM;
2333 aquad = (Quad_t)SvIV(fromstr);
2334 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2335 }
2336 break;
2337#endif
2338 case 'P':
2339 len = 1; /* assume SV is correct length */
2340 /* FALL THROUGH */
2341 case 'p':
2342 while (len-- > 0) {
2343 fromstr = NEXTFROM;
2344 if (fromstr == &PL_sv_undef)
2345 aptr = NULL;
2346 else {
2347 STRLEN n_a;
2348 /* XXX better yet, could spirit away the string to
2349 * a safe spot and hang on to it until the result
2350 * of pack() (and all copies of the result) are
2351 * gone.
2352 */
2353 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2354 || (SvPADTMP(fromstr)
2355 && !SvREADONLY(fromstr))))
2356 {
9014280d 2357 Perl_warner(aTHX_ packWARN(WARN_PACK),
a6ec74c1
JH
2358 "Attempt to pack pointer to temporary value");
2359 }
2360 if (SvPOK(fromstr) || SvNIOK(fromstr))
2361 aptr = SvPV(fromstr,n_a);
2362 else
2363 aptr = SvPV_force(fromstr,n_a);
2364 }
2365 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2366 }
2367 break;
2368 case 'u':
2369 fromstr = NEXTFROM;
2370 aptr = SvPV(fromstr, fromlen);
2371 SvGROW(cat, fromlen * 4 / 3);
19c9db5e 2372 if (len <= 2)
a6ec74c1
JH
2373 len = 45;
2374 else
2375 len = len / 3 * 3;
2376 while (fromlen > 0) {
2377 I32 todo;
2378
2379 if (fromlen > len)
2380 todo = len;
2381 else
2382 todo = fromlen;
2383 doencodes(cat, aptr, todo);
2384 fromlen -= todo;
2385 aptr += todo;
2386 }
2387 break;
2388 }
2389 }
18529408
IZ
2390 if (next_in_list)
2391 *next_in_list = beglist;
2392}
2393#undef NEXTFROM
2394
2395
2396PP(pp_pack)
2397{
2398 dSP; dMARK; dORIGMARK; dTARGET;
2399 register SV *cat = TARG;
2400 STRLEN fromlen;
2401 register char *pat = SvPVx(*++MARK, fromlen);
2402 register char *patend = pat + fromlen;
2403
2404 MARK++;
2405 sv_setpvn(cat, "", 0);
2406
2407 pack_cat(cat, pat, patend, MARK, SP + 1, NULL, 0);
2408
a6ec74c1
JH
2409 SvSETMAGIC(cat);
2410 SP = ORIGMARK;
2411 PUSHs(cat);
2412 RETURN;
2413}
a6ec74c1 2414