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