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