This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
unpack("Z*Z*", pack("Z*Z*", ..)) bug, patch and test from
[perl5.git] / pp_pack.c
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
22 static 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
78 STATIC SV *
79 S_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
119 PP(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     UV culong = 0;
163     NV cdouble = 0.0;
164     const int bits_in_uv = 8 * sizeof(culong);
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
171     bool do_utf8 = DO_UTF8(right);
172
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;
199         if (pat >= patend)
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);
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++;
275                     if (star) /* exact for 'Z*' */
276                         len = s - SvPVX(sv) + 1;
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             }
287             s += len;
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;
395                     if (checksum > bits_in_uv)
396                         cdouble += (NV)aint;
397                     else
398                         culong += aint;
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':
415         unpack_C: /* unpack U will jump here if not UTF-8 */
416             if (len == 0) {
417                 do_utf8 = FALSE;
418                 break;
419             }
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':
441             if (len == 0) {
442                 do_utf8 = TRUE;
443                 break;
444             }
445             if (!do_utf8)
446                  goto unpack_C;
447             if (len > strend - s)
448                 len = strend - s;
449             if (checksum) {
450                 while (len-- > 0 && s < strend) {
451                     STRLEN alen;
452                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
453                     along = alen;
454                     s += along;
455                     if (checksum > bits_in_uv)
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;
466                     auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
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);
490                         if (checksum > bits_in_uv)
491                             cdouble += (NV)ashort;
492                         else
493                             culong += ashort;
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;
507                         if (checksum > bits_in_uv)
508                             cdouble += (NV)ashort;
509                         else
510                             culong += ashort;
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);
563                         if (checksum > bits_in_uv)
564                             cdouble += (NV)aushort;
565                         else
566                             culong += aushort;
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
583                         if (checksum > bits_in_uv)
584                             cdouble += (NV)aushort;
585                         else
586                             culong += aushort;
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);
633                     if (checksum > bits_in_uv)
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);
684                     if (checksum > bits_in_uv)
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);
723                         if (checksum > bits_in_uv)
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;
742                         if (checksum > bits_in_uv)
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);
800                         if (checksum > bits_in_uv)
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
820                         if (checksum > bits_in_uv)
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':
925             EXTEND(SP, 1);
926             if (sizeof(char*) > strend - s)
927                 break;
928             else {
929                 Copy(s, &aptr, 1, char*);
930                 s += sizeof(char*);
931             }
932             sv = NEWSV(44, 0);
933             if (aptr)
934                 sv_setpvn(sv, aptr, len);
935             PUSHs(sv_2mortal(sv));
936             break;
937 #ifdef HAS_QUAD
938         case 'q':
939             along = (strend - s) / sizeof(Quad_t);
940             if (len > along)
941                 len = along;
942             if (checksum) {
943                 while (len-- > 0) {
944                     Copy(s, &aquad, 1, Quad_t);
945                     s += sizeof(Quad_t);
946                     if (checksum > bits_in_uv)
947                         cdouble += (NV)aquad;
948                     else
949                         culong += aquad;
950                 }
951             }
952             else {
953                 EXTEND(SP, len);
954                 EXTEND_MORTAL(len);
955                 while (len-- > 0) {
956                     if (s + sizeof(Quad_t) > strend)
957                         aquad = 0;
958                     else {
959                     Copy(s, &aquad, 1, Quad_t);
960                     s += sizeof(Quad_t);
961                     }
962                     sv = NEWSV(42, 0);
963                     if (aquad >= IV_MIN && aquad <= IV_MAX)
964                     sv_setiv(sv, (IV)aquad);
965                     else
966                         sv_setnv(sv, (NV)aquad);
967                     PUSHs(sv_2mortal(sv));
968                 }
969             }
970             break;
971         case 'Q':
972             along = (strend - s) / sizeof(Quad_t);
973             if (len > along)
974                 len = along;
975             if (checksum) {
976                 while (len-- > 0) {
977                     Copy(s, &auquad, 1, Uquad_t);
978                     s += sizeof(Uquad_t);
979                     if (checksum > bits_in_uv)
980                         cdouble += (NV)auquad;
981                     else
982                         culong += auquad;
983                 }
984             }
985             else {
986                 EXTEND(SP, len);
987                 EXTEND_MORTAL(len);
988                 while (len-- > 0) {
989                     if (s + sizeof(Uquad_t) > strend)
990                         auquad = 0;
991                     else {
992                         Copy(s, &auquad, 1, Uquad_t);
993                         s += sizeof(Uquad_t);
994                     }
995                     sv = NEWSV(43, 0);
996                     if (auquad <= UV_MAX)
997                         sv_setuv(sv, (UV)auquad);
998                     else
999                     sv_setnv(sv, (NV)auquad);
1000                     PUSHs(sv_2mortal(sv));
1001                 }
1002             }
1003             break;
1004 #endif
1005         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1006         case 'f':
1007         case 'F':
1008             along = (strend - s) / sizeof(float);
1009             if (len > along)
1010                 len = along;
1011             if (checksum) {
1012                 while (len-- > 0) {
1013                     Copy(s, &afloat, 1, float);
1014                     s += sizeof(float);
1015                     cdouble += afloat;
1016                 }
1017             }
1018             else {
1019                 EXTEND(SP, len);
1020                 EXTEND_MORTAL(len);
1021                 while (len-- > 0) {
1022                     Copy(s, &afloat, 1, float);
1023                     s += sizeof(float);
1024                     sv = NEWSV(47, 0);
1025                     sv_setnv(sv, (NV)afloat);
1026                     PUSHs(sv_2mortal(sv));
1027                 }
1028             }
1029             break;
1030         case 'd':
1031         case 'D':
1032             along = (strend - s) / sizeof(double);
1033             if (len > along)
1034                 len = along;
1035             if (checksum) {
1036                 while (len-- > 0) {
1037                     Copy(s, &adouble, 1, double);
1038                     s += sizeof(double);
1039                     cdouble += adouble;
1040                 }
1041             }
1042             else {
1043                 EXTEND(SP, len);
1044                 EXTEND_MORTAL(len);
1045                 while (len-- > 0) {
1046                     Copy(s, &adouble, 1, double);
1047                     s += sizeof(double);
1048                     sv = NEWSV(48, 0);
1049                     sv_setnv(sv, (NV)adouble);
1050                     PUSHs(sv_2mortal(sv));
1051                 }
1052             }
1053             break;
1054         case 'u':
1055             /* MKS:
1056              * Initialise the decode mapping.  By using a table driven
1057              * algorithm, the code will be character-set independent
1058              * (and just as fast as doing character arithmetic)
1059              */
1060             if (PL_uudmap['M'] == 0) {
1061                 int i;
1062
1063                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1064                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1065                 /*
1066                  * Because ' ' and '`' map to the same value,
1067                  * we need to decode them both the same.
1068                  */
1069                 PL_uudmap[' '] = 0;
1070             }
1071
1072             along = (strend - s) * 3 / 4;
1073             sv = NEWSV(42, along);
1074             if (along)
1075                 SvPOK_on(sv);
1076             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1077                 I32 a, b, c, d;
1078                 char hunk[4];
1079
1080                 hunk[3] = '\0';
1081                 len = PL_uudmap[*(U8*)s++] & 077;
1082                 while (len > 0) {
1083                     if (s < strend && ISUUCHAR(*s))
1084                         a = PL_uudmap[*(U8*)s++] & 077;
1085                     else
1086                         a = 0;
1087                     if (s < strend && ISUUCHAR(*s))
1088                         b = PL_uudmap[*(U8*)s++] & 077;
1089                     else
1090                         b = 0;
1091                     if (s < strend && ISUUCHAR(*s))
1092                         c = PL_uudmap[*(U8*)s++] & 077;
1093                     else
1094                         c = 0;
1095                     if (s < strend && ISUUCHAR(*s))
1096                         d = PL_uudmap[*(U8*)s++] & 077;
1097                     else
1098                         d = 0;
1099                     hunk[0] = (a << 2) | (b >> 4);
1100                     hunk[1] = (b << 4) | (c >> 2);
1101                     hunk[2] = (c << 6) | d;
1102                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1103                     len -= 3;
1104                 }
1105                 if (*s == '\n')
1106                     s++;
1107                 else if (s[1] == '\n')          /* possible checksum byte */
1108                     s += 2;
1109             }
1110             XPUSHs(sv_2mortal(sv));
1111             break;
1112         }
1113         if (checksum) {
1114             sv = NEWSV(42, 0);
1115             if (strchr("fFdD", datumtype) ||
1116               (checksum > bits_in_uv && strchr("csSiIlLnNUvVqQ", datumtype)) ) {
1117                 NV trouble;
1118
1119                 adouble = (NV) (1 << (checksum & 15));
1120                 while (checksum >= 16) {
1121                     checksum -= 16;
1122                     adouble *= 65536.0;
1123                 }
1124                 while (cdouble < 0.0)
1125                     cdouble += adouble;
1126                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1127                 sv_setnv(sv, cdouble);
1128             }
1129             else {
1130                 if (checksum < bits_in_uv) {
1131                     UV mask = ((UV)1 << checksum) - 1;
1132                     culong &= mask;
1133                 }
1134                 sv_setuv(sv, (UV)culong);
1135             }
1136             XPUSHs(sv_2mortal(sv));
1137             checksum = 0;
1138         }
1139         if (gimme != G_ARRAY &&
1140             SP - PL_stack_base == start_sp_offset + 1) {
1141           /* do first one only unless in list context
1142              / is implmented by unpacking the count, then poping it from the
1143              stack, so must check that we're not in the middle of a /  */
1144           if ((pat >= patend) || *pat != '/')
1145             RETURN;
1146         }
1147     }
1148     if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
1149         PUSHs(&PL_sv_undef);
1150     RETURN;
1151 }
1152
1153 STATIC void
1154 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1155 {
1156     char hunk[5];
1157
1158     *hunk = PL_uuemap[len];
1159     sv_catpvn(sv, hunk, 1);
1160     hunk[4] = '\0';
1161     while (len > 2) {
1162         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1163         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1164         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1165         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1166         sv_catpvn(sv, hunk, 4);
1167         s += 3;
1168         len -= 3;
1169     }
1170     if (len > 0) {
1171         char r = (len > 1 ? s[1] : '\0');
1172         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1173         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1174         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1175         hunk[3] = PL_uuemap[0];
1176         sv_catpvn(sv, hunk, 4);
1177     }
1178     sv_catpvn(sv, "\n", 1);
1179 }
1180
1181 STATIC SV *
1182 S_is_an_int(pTHX_ char *s, STRLEN l)
1183 {
1184   STRLEN         n_a;
1185   SV             *result = newSVpvn(s, l);
1186   char           *result_c = SvPV(result, n_a); /* convenience */
1187   char           *out = result_c;
1188   bool            skip = 1;
1189   bool            ignore = 0;
1190
1191   while (*s) {
1192     switch (*s) {
1193     case ' ':
1194       break;
1195     case '+':
1196       if (!skip) {
1197         SvREFCNT_dec(result);
1198         return (NULL);
1199       }
1200       break;
1201     case '0':
1202     case '1':
1203     case '2':
1204     case '3':
1205     case '4':
1206     case '5':
1207     case '6':
1208     case '7':
1209     case '8':
1210     case '9':
1211       skip = 0;
1212       if (!ignore) {
1213         *(out++) = *s;
1214       }
1215       break;
1216     case '.':
1217       ignore = 1;
1218       break;
1219     default:
1220       SvREFCNT_dec(result);
1221       return (NULL);
1222     }
1223     s++;
1224   }
1225   *(out++) = '\0';
1226   SvCUR_set(result, out - result_c);
1227   return (result);
1228 }
1229
1230 /* pnum must be '\0' terminated */
1231 STATIC int
1232 S_div128(pTHX_ SV *pnum, bool *done)
1233 {
1234   STRLEN          len;
1235   char           *s = SvPV(pnum, len);
1236   int             m = 0;
1237   int             r = 0;
1238   char           *t = s;
1239
1240   *done = 1;
1241   while (*t) {
1242     int             i;
1243
1244     i = m * 10 + (*t - '0');
1245     m = i & 0x7F;
1246     r = (i >> 7);               /* r < 10 */
1247     if (r) {
1248       *done = 0;
1249     }
1250     *(t++) = '0' + r;
1251   }
1252   *(t++) = '\0';
1253   SvCUR_set(pnum, (STRLEN) (t - s));
1254   return (m);
1255 }
1256
1257
1258 PP(pp_pack)
1259 {
1260     dSP; dMARK; dORIGMARK; dTARGET;
1261     register SV *cat = TARG;
1262     register I32 items;
1263     STRLEN fromlen;
1264     register char *pat = SvPVx(*++MARK, fromlen);
1265     char *patcopy;
1266     register char *patend = pat + fromlen;
1267     register I32 len;
1268     I32 datumtype;
1269     SV *fromstr;
1270     /*SUPPRESS 442*/
1271     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1272     static char *space10 = "          ";
1273
1274     /* These must not be in registers: */
1275     char achar;
1276     I16 ashort;
1277     int aint;
1278     unsigned int auint;
1279     I32 along;
1280     U32 aulong;
1281 #ifdef HAS_QUAD
1282     Quad_t aquad;
1283     Uquad_t auquad;
1284 #endif
1285     char *aptr;
1286     float afloat;
1287     double adouble;
1288     int commas = 0;
1289 #ifdef PERL_NATINT_PACK
1290     int natint;         /* native integer */
1291 #endif
1292
1293     items = SP - MARK;
1294     MARK++;
1295     sv_setpvn(cat, "", 0);
1296     patcopy = pat;
1297     while (pat < patend) {
1298         SV *lengthcode = Nullsv;
1299 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
1300         datumtype = *pat++ & 0xFF;
1301 #ifdef PERL_NATINT_PACK
1302         natint = 0;
1303 #endif
1304         if (isSPACE(datumtype)) {
1305             patcopy++;
1306             continue;
1307         }
1308 #ifndef PACKED_IS_OCTETS
1309         if (datumtype == 'U' && pat == patcopy+1)
1310             SvUTF8_on(cat);
1311 #endif
1312         if (datumtype == '#') {
1313             while (pat < patend && *pat != '\n')
1314                 pat++;
1315             continue;
1316         }
1317         if (*pat == '!') {
1318             char *natstr = "sSiIlL";
1319
1320             if (strchr(natstr, datumtype)) {
1321 #ifdef PERL_NATINT_PACK
1322                 natint = 1;
1323 #endif
1324                 pat++;
1325             }
1326             else
1327                 DIE(aTHX_ "'!' allowed only after types %s", natstr);
1328         }
1329         if (*pat == '*') {
1330             len = strchr("@Xxu", datumtype) ? 0 : items;
1331             pat++;
1332         }
1333         else if (isDIGIT(*pat)) {
1334             len = *pat++ - '0';
1335             while (isDIGIT(*pat)) {
1336                 len = (len * 10) + (*pat++ - '0');
1337                 if (len < 0)
1338                     DIE(aTHX_ "Repeat count in pack overflows");
1339             }
1340         }
1341         else
1342             len = 1;
1343         if (*pat == '/') {
1344             ++pat;
1345             if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
1346                 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
1347             lengthcode = sv_2mortal(newSViv(sv_len(items > 0
1348                                                    ? *MARK : &PL_sv_no)
1349                                             + (*pat == 'Z' ? 1 : 0)));
1350         }
1351         switch(datumtype) {
1352         default:
1353             DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
1354         case ',': /* grandfather in commas but with a warning */
1355             if (commas++ == 0 && ckWARN(WARN_PACK))
1356                 Perl_warner(aTHX_ WARN_PACK,
1357                             "Invalid type in pack: '%c'", (int)datumtype);
1358             break;
1359         case '%':
1360             DIE(aTHX_ "%% may only be used in unpack");
1361         case '@':
1362             len -= SvCUR(cat);
1363             if (len > 0)
1364                 goto grow;
1365             len = -len;
1366             if (len > 0)
1367                 goto shrink;
1368             break;
1369         case 'X':
1370           shrink:
1371             if (SvCUR(cat) < len)
1372                 DIE(aTHX_ "X outside of string");
1373             SvCUR(cat) -= len;
1374             *SvEND(cat) = '\0';
1375             break;
1376         case 'x':
1377           grow:
1378             while (len >= 10) {
1379                 sv_catpvn(cat, null10, 10);
1380                 len -= 10;
1381             }
1382             sv_catpvn(cat, null10, len);
1383             break;
1384         case 'A':
1385         case 'Z':
1386         case 'a':
1387             fromstr = NEXTFROM;
1388             aptr = SvPV(fromstr, fromlen);
1389             if (pat[-1] == '*') {
1390                 len = fromlen;
1391                 if (datumtype == 'Z')
1392                     ++len;
1393             }
1394             if (fromlen >= len) {
1395                 sv_catpvn(cat, aptr, len);
1396                 if (datumtype == 'Z')
1397                     *(SvEND(cat)-1) = '\0';
1398             }
1399             else {
1400                 sv_catpvn(cat, aptr, fromlen);
1401                 len -= fromlen;
1402                 if (datumtype == 'A') {
1403                     while (len >= 10) {
1404                         sv_catpvn(cat, space10, 10);
1405                         len -= 10;
1406                     }
1407                     sv_catpvn(cat, space10, len);
1408                 }
1409                 else {
1410                     while (len >= 10) {
1411                         sv_catpvn(cat, null10, 10);
1412                         len -= 10;
1413                     }
1414                     sv_catpvn(cat, null10, len);
1415                 }
1416             }
1417             break;
1418         case 'B':
1419         case 'b':
1420             {
1421                 register char *str;
1422                 I32 saveitems;
1423
1424                 fromstr = NEXTFROM;
1425                 saveitems = items;
1426                 str = SvPV(fromstr, fromlen);
1427                 if (pat[-1] == '*')
1428                     len = fromlen;
1429                 aint = SvCUR(cat);
1430                 SvCUR(cat) += (len+7)/8;
1431                 SvGROW(cat, SvCUR(cat) + 1);
1432                 aptr = SvPVX(cat) + aint;
1433                 if (len > fromlen)
1434                     len = fromlen;
1435                 aint = len;
1436                 items = 0;
1437                 if (datumtype == 'B') {
1438                     for (len = 0; len++ < aint;) {
1439                         items |= *str++ & 1;
1440                         if (len & 7)
1441                             items <<= 1;
1442                         else {
1443                             *aptr++ = items & 0xff;
1444                             items = 0;
1445                         }
1446                     }
1447                 }
1448                 else {
1449                     for (len = 0; len++ < aint;) {
1450                         if (*str++ & 1)
1451                             items |= 128;
1452                         if (len & 7)
1453                             items >>= 1;
1454                         else {
1455                             *aptr++ = items & 0xff;
1456                             items = 0;
1457                         }
1458                     }
1459                 }
1460                 if (aint & 7) {
1461                     if (datumtype == 'B')
1462                         items <<= 7 - (aint & 7);
1463                     else
1464                         items >>= 7 - (aint & 7);
1465                     *aptr++ = items & 0xff;
1466                 }
1467                 str = SvPVX(cat) + SvCUR(cat);
1468                 while (aptr <= str)
1469                     *aptr++ = '\0';
1470
1471                 items = saveitems;
1472             }
1473             break;
1474         case 'H':
1475         case 'h':
1476             {
1477                 register char *str;
1478                 I32 saveitems;
1479
1480                 fromstr = NEXTFROM;
1481                 saveitems = items;
1482                 str = SvPV(fromstr, fromlen);
1483                 if (pat[-1] == '*')
1484                     len = fromlen;
1485                 aint = SvCUR(cat);
1486                 SvCUR(cat) += (len+1)/2;
1487                 SvGROW(cat, SvCUR(cat) + 1);
1488                 aptr = SvPVX(cat) + aint;
1489                 if (len > fromlen)
1490                     len = fromlen;
1491                 aint = len;
1492                 items = 0;
1493                 if (datumtype == 'H') {
1494                     for (len = 0; len++ < aint;) {
1495                         if (isALPHA(*str))
1496                             items |= ((*str++ & 15) + 9) & 15;
1497                         else
1498                             items |= *str++ & 15;
1499                         if (len & 1)
1500                             items <<= 4;
1501                         else {
1502                             *aptr++ = items & 0xff;
1503                             items = 0;
1504                         }
1505                     }
1506                 }
1507                 else {
1508                     for (len = 0; len++ < aint;) {
1509                         if (isALPHA(*str))
1510                             items |= (((*str++ & 15) + 9) & 15) << 4;
1511                         else
1512                             items |= (*str++ & 15) << 4;
1513                         if (len & 1)
1514                             items >>= 4;
1515                         else {
1516                             *aptr++ = items & 0xff;
1517                             items = 0;
1518                         }
1519                     }
1520                 }
1521                 if (aint & 1)
1522                     *aptr++ = items & 0xff;
1523                 str = SvPVX(cat) + SvCUR(cat);
1524                 while (aptr <= str)
1525                     *aptr++ = '\0';
1526
1527                 items = saveitems;
1528             }
1529             break;
1530         case 'C':
1531         case 'c':
1532             while (len-- > 0) {
1533                 fromstr = NEXTFROM;
1534                 switch (datumtype) {
1535                 case 'C':
1536                     aint = SvIV(fromstr);
1537                     if ((aint < 0 || aint > 255) &&
1538                         ckWARN(WARN_PACK))
1539                         Perl_warner(aTHX_ WARN_PACK,
1540                                     "Character in \"C\" format wrapped");
1541                     achar = aint & 255;
1542                     sv_catpvn(cat, &achar, sizeof(char));
1543                     break;
1544                 case 'c':
1545                     aint = SvIV(fromstr);
1546                     if ((aint < -128 || aint > 127) &&
1547                         ckWARN(WARN_PACK))
1548                         Perl_warner(aTHX_ WARN_PACK,
1549                                     "Character in \"c\" format wrapped");
1550                     achar = aint & 255;
1551                     sv_catpvn(cat, &achar, sizeof(char));
1552                     break;
1553                 }
1554             }
1555             break;
1556         case 'U':
1557             while (len-- > 0) {
1558                 fromstr = NEXTFROM;
1559                 auint = SvUV(fromstr);
1560                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
1561                 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
1562                                - SvPVX(cat));
1563             }
1564             *SvEND(cat) = '\0';
1565             break;
1566         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
1567         case 'f':
1568         case 'F':
1569             while (len-- > 0) {
1570                 fromstr = NEXTFROM;
1571                 afloat = (float)SvNV(fromstr);
1572                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
1573             }
1574             break;
1575         case 'd':
1576         case 'D':
1577             while (len-- > 0) {
1578                 fromstr = NEXTFROM;
1579                 adouble = (double)SvNV(fromstr);
1580                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
1581             }
1582             break;
1583         case 'n':
1584             while (len-- > 0) {
1585                 fromstr = NEXTFROM;
1586                 ashort = (I16)SvIV(fromstr);
1587 #ifdef HAS_HTONS
1588                 ashort = PerlSock_htons(ashort);
1589 #endif
1590                 CAT16(cat, &ashort);
1591             }
1592             break;
1593         case 'v':
1594             while (len-- > 0) {
1595                 fromstr = NEXTFROM;
1596                 ashort = (I16)SvIV(fromstr);
1597 #ifdef HAS_HTOVS
1598                 ashort = htovs(ashort);
1599 #endif
1600                 CAT16(cat, &ashort);
1601             }
1602             break;
1603         case 'S':
1604 #if SHORTSIZE != SIZE16
1605             if (natint) {
1606                 unsigned short aushort;
1607
1608                 while (len-- > 0) {
1609                     fromstr = NEXTFROM;
1610                     aushort = SvUV(fromstr);
1611                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
1612                 }
1613             }
1614             else
1615 #endif
1616             {
1617                 U16 aushort;
1618
1619                 while (len-- > 0) {
1620                     fromstr = NEXTFROM;
1621                     aushort = (U16)SvUV(fromstr);
1622                     CAT16(cat, &aushort);
1623                 }
1624
1625             }
1626             break;
1627         case 's':
1628 #if SHORTSIZE != SIZE16
1629             if (natint) {
1630                 short ashort;
1631
1632                 while (len-- > 0) {
1633                     fromstr = NEXTFROM;
1634                     ashort = SvIV(fromstr);
1635                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
1636                 }
1637             }
1638             else
1639 #endif
1640             {
1641                 while (len-- > 0) {
1642                     fromstr = NEXTFROM;
1643                     ashort = (I16)SvIV(fromstr);
1644                     CAT16(cat, &ashort);
1645                 }
1646             }
1647             break;
1648         case 'I':
1649             while (len-- > 0) {
1650                 fromstr = NEXTFROM;
1651                 auint = SvUV(fromstr);
1652                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
1653             }
1654             break;
1655         case 'w':
1656             while (len-- > 0) {
1657                 fromstr = NEXTFROM;
1658                 adouble = Perl_floor(SvNV(fromstr));
1659
1660                 if (adouble < 0)
1661                     DIE(aTHX_ "Cannot compress negative numbers");
1662
1663                 if (
1664 #if UVSIZE > 4 && UVSIZE >= NVSIZE
1665                     adouble <= 0xffffffff
1666 #else
1667 #   ifdef CXUX_BROKEN_CONSTANT_CONVERT
1668                     adouble <= UV_MAX_cxux
1669 #   else
1670                     adouble <= UV_MAX
1671 #   endif
1672 #endif
1673                     )
1674                 {
1675                     char   buf[1 + sizeof(UV)];
1676                     char  *in = buf + sizeof(buf);
1677                     UV     auv = U_V(adouble);
1678
1679                     do {
1680                         *--in = (auv & 0x7f) | 0x80;
1681                         auv >>= 7;
1682                     } while (auv);
1683                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
1684                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
1685                 }
1686                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
1687                     char           *from, *result, *in;
1688                     SV             *norm;
1689                     STRLEN          len;
1690                     bool            done;
1691
1692                     /* Copy string and check for compliance */
1693                     from = SvPV(fromstr, len);
1694                     if ((norm = is_an_int(from, len)) == NULL)
1695                         DIE(aTHX_ "can compress only unsigned integer");
1696
1697                     New('w', result, len, char);
1698                     in = result + len;
1699                     done = FALSE;
1700                     while (!done)
1701                         *--in = div128(norm, &done) | 0x80;
1702                     result[len - 1] &= 0x7F; /* clear continue bit */
1703                     sv_catpvn(cat, in, (result + len) - in);
1704                     Safefree(result);
1705                     SvREFCNT_dec(norm); /* free norm */
1706                 }
1707                 else if (SvNOKp(fromstr)) {
1708                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
1709                     char  *in = buf + sizeof(buf);
1710
1711                     do {
1712                         double next = floor(adouble / 128);
1713                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
1714                         if (in <= buf)  /* this cannot happen ;-) */
1715                             DIE(aTHX_ "Cannot compress integer");
1716                         adouble = next;
1717                     } while (adouble > 0);
1718                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
1719                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
1720                 }
1721                 else
1722                     DIE(aTHX_ "Cannot compress non integer");
1723             }
1724             break;
1725         case 'i':
1726             while (len-- > 0) {
1727                 fromstr = NEXTFROM;
1728                 aint = SvIV(fromstr);
1729                 sv_catpvn(cat, (char*)&aint, sizeof(int));
1730             }
1731             break;
1732         case 'N':
1733             while (len-- > 0) {
1734                 fromstr = NEXTFROM;
1735                 aulong = SvUV(fromstr);
1736 #ifdef HAS_HTONL
1737                 aulong = PerlSock_htonl(aulong);
1738 #endif
1739                 CAT32(cat, &aulong);
1740             }
1741             break;
1742         case 'V':
1743             while (len-- > 0) {
1744                 fromstr = NEXTFROM;
1745                 aulong = SvUV(fromstr);
1746 #ifdef HAS_HTOVL
1747                 aulong = htovl(aulong);
1748 #endif
1749                 CAT32(cat, &aulong);
1750             }
1751             break;
1752         case 'L':
1753 #if LONGSIZE != SIZE32
1754             if (natint) {
1755                 unsigned long aulong;
1756
1757                 while (len-- > 0) {
1758                     fromstr = NEXTFROM;
1759                     aulong = SvUV(fromstr);
1760                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
1761                 }
1762             }
1763             else
1764 #endif
1765             {
1766                 while (len-- > 0) {
1767                     fromstr = NEXTFROM;
1768                     aulong = SvUV(fromstr);
1769                     CAT32(cat, &aulong);
1770                 }
1771             }
1772             break;
1773         case 'l':
1774 #if LONGSIZE != SIZE32
1775             if (natint) {
1776                 long along;
1777
1778                 while (len-- > 0) {
1779                     fromstr = NEXTFROM;
1780                     along = SvIV(fromstr);
1781                     sv_catpvn(cat, (char *)&along, sizeof(long));
1782                 }
1783             }
1784             else
1785 #endif
1786             {
1787                 while (len-- > 0) {
1788                     fromstr = NEXTFROM;
1789                     along = SvIV(fromstr);
1790                     CAT32(cat, &along);
1791                 }
1792             }
1793             break;
1794 #ifdef HAS_QUAD
1795         case 'Q':
1796             while (len-- > 0) {
1797                 fromstr = NEXTFROM;
1798                 auquad = (Uquad_t)SvUV(fromstr);
1799                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
1800             }
1801             break;
1802         case 'q':
1803             while (len-- > 0) {
1804                 fromstr = NEXTFROM;
1805                 aquad = (Quad_t)SvIV(fromstr);
1806                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
1807             }
1808             break;
1809 #endif
1810         case 'P':
1811             len = 1;            /* assume SV is correct length */
1812             /* FALL THROUGH */
1813         case 'p':
1814             while (len-- > 0) {
1815                 fromstr = NEXTFROM;
1816                 if (fromstr == &PL_sv_undef)
1817                     aptr = NULL;
1818                 else {
1819                     STRLEN n_a;
1820                     /* XXX better yet, could spirit away the string to
1821                      * a safe spot and hang on to it until the result
1822                      * of pack() (and all copies of the result) are
1823                      * gone.
1824                      */
1825                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
1826                                                 || (SvPADTMP(fromstr)
1827                                                     && !SvREADONLY(fromstr))))
1828                     {
1829                         Perl_warner(aTHX_ WARN_PACK,
1830                                 "Attempt to pack pointer to temporary value");
1831                     }
1832                     if (SvPOK(fromstr) || SvNIOK(fromstr))
1833                         aptr = SvPV(fromstr,n_a);
1834                     else
1835                         aptr = SvPV_force(fromstr,n_a);
1836                 }
1837                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
1838             }
1839             break;
1840         case 'u':
1841             fromstr = NEXTFROM;
1842             aptr = SvPV(fromstr, fromlen);
1843             SvGROW(cat, fromlen * 4 / 3);
1844             if (len <= 1)
1845                 len = 45;
1846             else
1847                 len = len / 3 * 3;
1848             while (fromlen > 0) {
1849                 I32 todo;
1850
1851                 if (fromlen > len)
1852                     todo = len;
1853                 else
1854                     todo = fromlen;
1855                 doencodes(cat, aptr, todo);
1856                 fromlen -= todo;
1857                 aptr += todo;
1858             }
1859             break;
1860         }
1861     }
1862     SvSETMAGIC(cat);
1863     SP = ORIGMARK;
1864     PUSHs(cat);
1865     RETURN;
1866 }
1867 #undef NEXTFROM
1868