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