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