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