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