This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Source code tidy up - avoid assigning to sv.
[perl5.git] / pp_pack.c
1 /*    pp_pack.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * He still hopefully carried some of his gear in his pack: a small tinder-box,
13  * two small shallow pans, the smaller fitting into the larger; inside them a
14  * wooden spoon, a short two-pronged fork and some skewers were stowed; and
15  * hidden at the bottom of the pack in a flat wooden box a dwindling treasure,
16  * some salt.
17  */
18
19 /* This file contains pp ("push/pop") functions that
20  * execute the opcodes that make up a perl program. A typical pp function
21  * expects to find its arguments on the stack, and usually pushes its
22  * results onto the stack, hence the 'pp' terminology. Each OP structure
23  * contains a pointer to the relevant pp_foo() function.
24  *
25  * This particular file just contains pp_pack() and pp_unpack(). See the
26  * other pp*.c files for the rest of the pp_ functions.
27  */
28
29
30 #include "EXTERN.h"
31 #define PERL_IN_PP_PACK_C
32 #include "perl.h"
33
34 /*
35  * Offset for integer pack/unpack.
36  *
37  * On architectures where I16 and I32 aren't really 16 and 32 bits,
38  * which for now are all Crays, pack and unpack have to play games.
39  */
40
41 /*
42  * These values are required for portability of pack() output.
43  * If they're not right on your machine, then pack() and unpack()
44  * wouldn't work right anyway; you'll need to apply the Cray hack.
45  * (I'd like to check them with #if, but you can't use sizeof() in
46  * the preprocessor.)  --???
47  */
48 /*
49     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
50     defines are now in config.h.  --Andy Dougherty  April 1998
51  */
52 #define SIZE16 2
53 #define SIZE32 4
54
55 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
56    --jhi Feb 1999 */
57
58 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
59 #  if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    /* little-endian */
60 #    define OFF16(p)    (char*)(p)
61 #    define OFF32(p)    (char*)(p)
62 #  else
63 #    if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321  /* big-endian */
64 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
65 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
66 #    else
67        }}}} bad cray byte order
68 #    endif
69 #  endif
70 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 #  define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
74 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
75 #else
76 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
77 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
78 #  define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
80 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
81 #endif
82
83 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
84 #define MAX_SUB_TEMPLATE_LEVEL 100
85
86 /* flags (note that type modifiers can also be used as flags!) */
87 #define FLAG_UNPACK_ONLY_ONE  0x10
88 #define FLAG_UNPACK_DO_UTF8   0x08
89 #define FLAG_SLASH            0x04
90 #define FLAG_COMMA            0x02
91 #define FLAG_PACK             0x01
92
93 STATIC SV *
94 S_mul128(pTHX_ SV *sv, U8 m)
95 {
96   STRLEN          len;
97   char           *s = SvPV(sv, len);
98   char           *t;
99   U32             i = 0;
100
101   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
102     SV             *tmpNew = newSVpvn("0000000000", 10);
103
104     sv_catsv(tmpNew, sv);
105     SvREFCNT_dec(sv);           /* free old sv */
106     sv = tmpNew;
107     s = SvPV(sv, len);
108   }
109   t = s + len - 1;
110   while (!*t)                   /* trailing '\0'? */
111     t--;
112   while (t > s) {
113     i = ((*t - '0') << 7) + m;
114     *(t--) = '0' + (char)(i % 10);
115     m = (char)(i / 10);
116   }
117   return (sv);
118 }
119
120 /* Explosives and implosives. */
121
122 #if 'I' == 73 && 'J' == 74
123 /* On an ASCII/ISO kind of system */
124 #define ISUUCHAR(ch)    ((ch) >= ' ' && (ch) < 'a')
125 #else
126 /*
127   Some other sort of character set - use memchr() so we don't match
128   the null byte.
129  */
130 #define ISUUCHAR(ch)    (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
131 #endif
132
133 /* type modifiers */
134 #define TYPE_IS_SHRIEKING       0x100
135 #define TYPE_IS_BIG_ENDIAN      0x200
136 #define TYPE_IS_LITTLE_ENDIAN   0x400
137 #define TYPE_ENDIANNESS_MASK    (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
138 #define TYPE_ENDIANNESS(t)      ((t) & TYPE_ENDIANNESS_MASK)
139 #define TYPE_NO_ENDIANNESS(t)   ((t) & ~TYPE_ENDIANNESS_MASK)
140 #define TYPE_MODIFIERS(t)       ((t) & ~0xFF)
141 #define TYPE_NO_MODIFIERS(t)    ((t) & 0xFF)
142
143 #define ENDIANNESS_ALLOWED_TYPES   "sSiIlLqQjJfFdDpP("
144
145 #define DO_BO_UNPACK(var, type)                                               \
146         STMT_START {                                                          \
147           switch (TYPE_ENDIANNESS(datumtype)) {                               \
148             case TYPE_IS_BIG_ENDIAN:    var = my_betoh ## type (var); break;  \
149             case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break;  \
150             default: break;                                                   \
151           }                                                                   \
152         } STMT_END
153
154 #define DO_BO_PACK(var, type)                                                 \
155         STMT_START {                                                          \
156           switch (TYPE_ENDIANNESS(datumtype)) {                               \
157             case TYPE_IS_BIG_ENDIAN:    var = my_htobe ## type (var); break;  \
158             case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break;  \
159             default: break;                                                   \
160           }                                                                   \
161         } STMT_END
162
163 #define DO_BO_UNPACK_PTR(var, type, pre_cast)                                 \
164         STMT_START {                                                          \
165           switch (TYPE_ENDIANNESS(datumtype)) {                               \
166             case TYPE_IS_BIG_ENDIAN:                                          \
167               var = (void *) my_betoh ## type ((pre_cast) var);               \
168               break;                                                          \
169             case TYPE_IS_LITTLE_ENDIAN:                                       \
170               var = (void *) my_letoh ## type ((pre_cast) var);               \
171               break;                                                          \
172             default:                                                          \
173               break;                                                          \
174           }                                                                   \
175         } STMT_END
176
177 #define DO_BO_PACK_PTR(var, type, pre_cast)                                   \
178         STMT_START {                                                          \
179           switch (TYPE_ENDIANNESS(datumtype)) {                               \
180             case TYPE_IS_BIG_ENDIAN:                                          \
181               var = (void *) my_htobe ## type ((pre_cast) var);               \
182               break;                                                          \
183             case TYPE_IS_LITTLE_ENDIAN:                                       \
184               var = (void *) my_htole ## type ((pre_cast) var);               \
185               break;                                                          \
186             default:                                                          \
187               break;                                                          \
188           }                                                                   \
189         } STMT_END
190
191 #define BO_CANT_DOIT(action, type)                                            \
192         STMT_START {                                                          \
193           switch (TYPE_ENDIANNESS(datumtype)) {                               \
194              case TYPE_IS_BIG_ENDIAN:                                         \
195                Perl_croak(aTHX_ "Can't %s big-endian %ss on this "            \
196                                 "platform", #action, #type);                  \
197                break;                                                         \
198              case TYPE_IS_LITTLE_ENDIAN:                                      \
199                Perl_croak(aTHX_ "Can't %s little-endian %ss on this "         \
200                                 "platform", #action, #type);                  \
201                break;                                                         \
202              default:                                                         \
203                break;                                                         \
204            }                                                                  \
205          } STMT_END
206
207 #if PTRSIZE == INTSIZE
208 # define DO_BO_UNPACK_P(var)    DO_BO_UNPACK_PTR(var, i, int)
209 # define DO_BO_PACK_P(var)      DO_BO_PACK_PTR(var, i, int)
210 #elif PTRSIZE == LONGSIZE
211 # define DO_BO_UNPACK_P(var)    DO_BO_UNPACK_PTR(var, l, long)
212 # define DO_BO_PACK_P(var)      DO_BO_PACK_PTR(var, l, long)
213 #else
214 # define DO_BO_UNPACK_P(var)    BO_CANT_DOIT(unpack, pointer)
215 # define DO_BO_PACK_P(var)      BO_CANT_DOIT(pack, pointer)
216 #endif
217
218 #if defined(my_htolen) && defined(my_letohn) && \
219     defined(my_htoben) && defined(my_betohn)
220 # define DO_BO_UNPACK_N(var, type)                                            \
221          STMT_START {                                                         \
222            switch (TYPE_ENDIANNESS(datumtype)) {                              \
223              case TYPE_IS_BIG_ENDIAN:    my_betohn(&var, sizeof(type)); break;\
224              case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
225              default: break;                                                  \
226            }                                                                  \
227          } STMT_END
228
229 # define DO_BO_PACK_N(var, type)                                              \
230          STMT_START {                                                         \
231            switch (TYPE_ENDIANNESS(datumtype)) {                              \
232              case TYPE_IS_BIG_ENDIAN:    my_htoben(&var, sizeof(type)); break;\
233              case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
234              default: break;                                                  \
235            }                                                                  \
236          } STMT_END
237 #else
238 # define DO_BO_UNPACK_N(var, type)      BO_CANT_DOIT(unpack, type)
239 # define DO_BO_PACK_N(var, type)        BO_CANT_DOIT(pack, type)
240 #endif
241
242 /* Returns the sizeof() struct described by pat */
243 STATIC I32
244 S_measure_struct(pTHX_ register tempsym_t* symptr)
245 {
246     register I32 len = 0;
247     register I32 total = 0;
248     int star;
249
250     register int size;
251
252     while (next_symbol(symptr)) {
253
254         switch( symptr->howlen ){
255         case e_no_len:
256         case e_number:
257             len = symptr->length;
258             break;
259         case e_star:
260             Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
261                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
262             break;
263         }
264
265         /* endianness doesn't influence the size of a type */
266         switch(TYPE_NO_ENDIANNESS(symptr->code)) {
267         default:
268             Perl_croak(aTHX_ "Invalid type '%c' in %s",
269                        (int)TYPE_NO_MODIFIERS(symptr->code),
270                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
271         case '@':
272         case '/':
273         case 'U':                       /* XXXX Is it correct? */
274         case 'w':
275         case 'u':
276             Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
277                        (int)symptr->code,
278                        symptr->flags & FLAG_PACK ? "pack" : "unpack" );
279         case '%':
280             size = 0;
281             break;
282         case '(':
283         {
284             tempsym_t savsym = *symptr;
285             symptr->patptr = savsym.grpbeg;
286             symptr->patend = savsym.grpend;
287             /* XXXX Theoretically, we need to measure many times at different
288                positions, since the subexpression may contain
289                alignment commands, but be not of aligned length.
290                Need to detect this and croak().  */
291             size = measure_struct(symptr);
292             *symptr = savsym;
293             break;
294         }
295         case 'X' | TYPE_IS_SHRIEKING:
296             /* XXXX Is this useful?  Then need to treat MEASURE_BACKWARDS. */
297             if (!len)                   /* Avoid division by 0 */
298                 len = 1;
299             len = total % len;          /* Assumed: the start is aligned. */
300             /* FALL THROUGH */
301         case 'X':
302             size = -1;
303             if (total < len)
304                 Perl_croak(aTHX_ "'X' outside of string in %s",
305                           symptr->flags & FLAG_PACK ? "pack" : "unpack" );
306             break;
307         case 'x' | TYPE_IS_SHRIEKING:
308             if (!len)                   /* Avoid division by 0 */
309                 len = 1;
310             star = total % len;         /* Assumed: the start is aligned. */
311             if (star)                   /* Other portable ways? */
312                 len = len - star;
313             else
314                 len = 0;
315             /* FALL THROUGH */
316         case 'x':
317         case 'A':
318         case 'Z':
319         case 'a':
320         case 'c':
321         case 'C':
322             size = 1;
323             break;
324         case 'B':
325         case 'b':
326             len = (len + 7)/8;
327             size = 1;
328             break;
329         case 'H':
330         case 'h':
331             len = (len + 1)/2;
332             size = 1;
333             break;
334         case 's' | TYPE_IS_SHRIEKING:
335 #if SHORTSIZE != SIZE16
336             size = sizeof(short);
337             break;
338 #else
339             /* FALL THROUGH */
340 #endif
341         case 's':
342             size = SIZE16;
343             break;
344         case 'S' | TYPE_IS_SHRIEKING:
345 #if SHORTSIZE != SIZE16
346             size = sizeof(unsigned short);
347             break;
348 #else
349             /* FALL THROUGH */
350 #endif
351         case 'v' | TYPE_IS_SHRIEKING:
352         case 'n' | TYPE_IS_SHRIEKING:
353         case 'v':
354         case 'n':
355         case 'S':
356             size = SIZE16;
357             break;
358         case 'i' | TYPE_IS_SHRIEKING:
359         case 'i':
360             size = sizeof(int);
361             break;
362         case 'I' | TYPE_IS_SHRIEKING:
363         case 'I':
364             size = sizeof(unsigned int);
365             break;
366         case 'j':
367             size = IVSIZE;
368             break;
369         case 'J':
370             size = UVSIZE;
371             break;
372         case 'l' | TYPE_IS_SHRIEKING:
373 #if LONGSIZE != SIZE32
374             size = sizeof(long);
375             break;
376 #else
377             /* FALL THROUGH */
378 #endif
379         case 'l':
380             size = SIZE32;
381             break;
382         case 'L' | TYPE_IS_SHRIEKING:
383 #if LONGSIZE != SIZE32
384             size = sizeof(unsigned long);
385             break;
386 #else
387             /* FALL THROUGH */
388 #endif
389         case 'V' | TYPE_IS_SHRIEKING:
390         case 'N' | TYPE_IS_SHRIEKING:
391         case 'V':
392         case 'N':
393         case 'L':
394             size = SIZE32;
395             break;
396         case 'P':
397             len = 1;
398             /* FALL THROUGH */
399         case 'p':
400             size = sizeof(char*);
401             break;
402 #ifdef HAS_QUAD
403         case 'q':
404             size = sizeof(Quad_t);
405             break;
406         case 'Q':
407             size = sizeof(Uquad_t);
408             break;
409 #endif
410         case 'f':
411             size = sizeof(float);
412             break;
413         case 'd':
414             size = sizeof(double);
415             break;
416         case 'F':
417             size = NVSIZE;
418             break;
419 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
420         case 'D':
421             size = LONG_DOUBLESIZE;
422             break;
423 #endif
424         }
425         total += len * size;
426     }
427     return total;
428 }
429
430
431 /* locate matching closing parenthesis or bracket
432  * returns char pointer to char after match, or NULL
433  */
434 STATIC char *
435 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
436 {
437     while (patptr < patend) {
438         char c = *patptr++;
439
440         if (isSPACE(c))
441             continue;
442         else if (c == ender)
443             return patptr-1;
444         else if (c == '#') {
445             while (patptr < patend && *patptr != '\n')
446                 patptr++;
447             continue;
448         } else if (c == '(')
449             patptr = group_end(patptr, patend, ')') + 1;
450         else if (c == '[')
451             patptr = group_end(patptr, patend, ']') + 1;
452     }
453     Perl_croak(aTHX_ "No group ending character '%c' found in template",
454                ender);
455     return 0;
456 }
457
458
459 /* Convert unsigned decimal number to binary.
460  * Expects a pointer to the first digit and address of length variable
461  * Advances char pointer to 1st non-digit char and returns number
462  */ 
463 STATIC char *
464 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
465 {
466   I32 len = *patptr++ - '0';
467   while (isDIGIT(*patptr)) {
468     if (len >= 0x7FFFFFFF/10)
469       Perl_croak(aTHX_ "pack/unpack repeat count overflow");
470     len = (len * 10) + (*patptr++ - '0');
471   }
472   *lenptr = len;
473   return patptr;
474 }
475
476 /* The marvellous template parsing routine: Using state stored in *symptr,
477  * locates next template code and count
478  */
479 STATIC bool
480 S_next_symbol(pTHX_ register tempsym_t* symptr )
481 {
482   register char* patptr = symptr->patptr; 
483   register char* patend = symptr->patend; 
484
485   symptr->flags &= ~FLAG_SLASH;
486
487   while (patptr < patend) {
488     if (isSPACE(*patptr))
489       patptr++;
490     else if (*patptr == '#') {
491       patptr++;
492       while (patptr < patend && *patptr != '\n')
493         patptr++;
494       if (patptr < patend)
495         patptr++;
496     } else {
497       /* We should have found a template code */ 
498       I32 code = *patptr++ & 0xFF;
499       U32 inherited_modifiers = 0;
500
501       if (code == ','){ /* grandfather in commas but with a warning */
502         if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
503           symptr->flags |= FLAG_COMMA;
504           Perl_warner(aTHX_ packWARN(WARN_UNPACK),
505                       "Invalid type ',' in %s",
506                       symptr->flags & FLAG_PACK ? "pack" : "unpack" );
507         }
508         continue;
509       }
510       
511       /* for '(', skip to ')' */
512       if (code == '(') {  
513         if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
514           Perl_croak(aTHX_ "()-group starts with a count in %s",
515                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
516         symptr->grpbeg = patptr;
517         patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
518         if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
519           Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
520                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
521       }
522
523       /* look for group modifiers to inherit */
524       if (TYPE_ENDIANNESS(symptr->flags)) {
525         if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
526           inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
527       }
528
529       /* look for modifiers */
530       while (patptr < patend) {
531         const char *allowed;
532         I32 modifier = 0;
533         switch (*patptr) {
534           case '!':
535             modifier = TYPE_IS_SHRIEKING;
536             allowed = "sSiIlLxXnNvV";
537             break;
538           case '>':
539             modifier = TYPE_IS_BIG_ENDIAN;
540             allowed = ENDIANNESS_ALLOWED_TYPES;
541             break;
542           case '<':
543             modifier = TYPE_IS_LITTLE_ENDIAN;
544             allowed = ENDIANNESS_ALLOWED_TYPES;
545             break;
546           default:
547             break;
548         }
549
550         if (modifier == 0)
551           break;
552
553         if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
554           Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
555                      allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
556
557         if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
558           Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
559                      (int) TYPE_NO_MODIFIERS(code),
560                      symptr->flags & FLAG_PACK ? "pack" : "unpack" );
561         else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
562                  TYPE_ENDIANNESS_MASK)
563           Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
564                      *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
565
566         if (ckWARN(WARN_UNPACK)) {
567           if (code & modifier)
568             Perl_warner(aTHX_ packWARN(WARN_UNPACK),
569                         "Duplicate modifier '%c' after '%c' in %s",
570                         *patptr, (int) TYPE_NO_MODIFIERS(code),
571                         symptr->flags & FLAG_PACK ? "pack" : "unpack" );
572         }
573
574         code |= modifier;
575         patptr++;
576       }
577
578       /* inherit modifiers */
579       code |= inherited_modifiers;
580
581       /* look for count and/or / */ 
582       if (patptr < patend) {
583         if (isDIGIT(*patptr)) {
584           patptr = get_num( patptr, &symptr->length );
585           symptr->howlen = e_number;
586
587         } else if (*patptr == '*') {
588           patptr++;
589           symptr->howlen = e_star;
590
591         } else if (*patptr == '[') {
592           char* lenptr = ++patptr;            
593           symptr->howlen = e_number;
594           patptr = group_end( patptr, patend, ']' ) + 1;
595           /* what kind of [] is it? */
596           if (isDIGIT(*lenptr)) {
597             lenptr = get_num( lenptr, &symptr->length );
598             if( *lenptr != ']' )
599               Perl_croak(aTHX_ "Malformed integer in [] in %s",
600                          symptr->flags & FLAG_PACK ? "pack" : "unpack");
601           } else {
602             tempsym_t savsym = *symptr;
603             symptr->patend = patptr-1;
604             symptr->patptr = lenptr;
605             savsym.length = measure_struct(symptr);
606             *symptr = savsym;
607           }
608         } else {
609           symptr->howlen = e_no_len;
610           symptr->length = 1;
611         }
612
613         /* try to find / */
614         while (patptr < patend) {
615           if (isSPACE(*patptr))
616             patptr++;
617           else if (*patptr == '#') {
618             patptr++;
619             while (patptr < patend && *patptr != '\n')
620               patptr++;
621             if (patptr < patend)
622               patptr++;
623           } else {
624             if (*patptr == '/') {
625               symptr->flags |= FLAG_SLASH;
626               patptr++;
627               if (patptr < patend &&
628                   (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
629                 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
630                            symptr->flags & FLAG_PACK ? "pack" : "unpack" );
631             }
632             break;
633           }
634         }
635       } else {
636         /* at end - no count, no / */
637         symptr->howlen = e_no_len;
638         symptr->length = 1;
639       }
640
641       symptr->code = code;
642       symptr->patptr = patptr; 
643       return TRUE;
644     }
645   }
646   symptr->patptr = patptr; 
647   return FALSE;
648 }
649
650 /*
651 =for apidoc unpack_str
652
653 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
654 and ocnt are not used. This call should not be used, use unpackstring instead.
655
656 =cut */
657
658 I32
659 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
660 {
661     tempsym_t sym = { 0 };
662     sym.patptr = pat;
663     sym.patend = patend;
664     sym.flags  = flags;
665
666     return unpack_rec(&sym, s, s, strend, NULL );
667 }
668
669 /*
670 =for apidoc unpackstring
671
672 The engine implementing unpack() Perl function. C<unpackstring> puts the
673 extracted list items on the stack and returns the number of elements.
674 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
675
676 =cut */
677
678 I32
679 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
680 {
681     tempsym_t sym = { 0 };
682     sym.patptr = pat;
683     sym.patend = patend;
684     sym.flags  = flags;
685
686     return unpack_rec(&sym, s, s, strend, NULL );
687 }
688
689 STATIC
690 I32
691 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
692 {
693     dSP;
694     I32 datumtype;
695     register I32 len = 0;
696     register I32 bits = 0;
697     register char *str;
698     SV *sv;
699     I32 start_sp_offset = SP - PL_stack_base;
700     howlen_t howlen;
701
702     /* These must not be in registers: */
703     I16 ai16;
704     U16 au16;
705     I32 ai32;
706     U32 au32;
707 #ifdef HAS_QUAD
708     Quad_t aquad;
709     Uquad_t auquad;
710 #endif
711 #if SHORTSIZE != SIZE16
712     short ashort;
713     unsigned short aushort;
714 #endif
715     int aint;
716     unsigned int auint;
717     long along;
718 #if LONGSIZE != SIZE32
719     unsigned long aulong;
720 #endif
721     char *aptr;
722     float afloat;
723     double adouble;
724 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
725     long double aldouble;
726 #endif
727     IV aiv;
728     UV auv;
729     NV anv;
730
731     I32 checksum = 0;
732     UV cuv = 0;
733     NV cdouble = 0.0;
734     const int bits_in_uv = 8 * sizeof(cuv);
735     char* strrelbeg = s;
736     bool beyond = FALSE;
737     bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
738
739     while (next_symbol(symptr)) {
740         datumtype = symptr->code;
741         /* do first one only unless in list context
742            / is implemented by unpacking the count, then poping it from the
743            stack, so must check that we're not in the middle of a /  */
744         if ( unpack_only_one
745              && (SP - PL_stack_base == start_sp_offset + 1)
746              && (datumtype != '/') )   /* XXX can this be omitted */
747             break;
748
749         switch( howlen = symptr->howlen ){
750         case e_no_len:
751         case e_number:
752             len = symptr->length;
753             break;
754         case e_star:
755             len = strend - strbeg;      /* long enough */          
756             break;
757         }
758
759       redo_switch:
760         beyond = s >= strend;
761         switch(TYPE_NO_ENDIANNESS(datumtype)) {
762         default:
763             Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
764
765         case '%':
766             if (howlen == e_no_len)
767                 len = 16;               /* len is not specified */
768             checksum = len;
769             cuv = 0;
770             cdouble = 0;
771             continue;
772             break;
773         case '(':
774         {
775             char *ss = s;               /* Move from register */
776             tempsym_t savsym = *symptr;
777             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
778             symptr->flags |= group_modifiers;
779             symptr->patend = savsym.grpend;
780             symptr->level++;
781             PUTBACK;
782             while (len--) {
783                 symptr->patptr = savsym.grpbeg;
784                 unpack_rec(symptr, ss, strbeg, strend, &ss );
785                 if (ss == strend && savsym.howlen == e_star)
786                     break; /* No way to continue */
787             }
788             SPAGAIN;
789             s = ss;
790             symptr->flags &= ~group_modifiers;
791             savsym.flags = symptr->flags;
792             *symptr = savsym;
793             break;
794         }
795         case '@':
796             if (len > strend - strrelbeg)
797                 Perl_croak(aTHX_ "'@' outside of string in unpack");
798             s = strrelbeg + len;
799             break;
800         case 'X' | TYPE_IS_SHRIEKING:
801             if (!len)                   /* Avoid division by 0 */
802                 len = 1;
803             len = (s - strbeg) % len;
804             /* FALL THROUGH */
805         case 'X':
806             if (len > s - strbeg)
807                 Perl_croak(aTHX_ "'X' outside of string in unpack" );
808             s -= len;
809             break;
810         case 'x' | TYPE_IS_SHRIEKING:
811             if (!len)                   /* Avoid division by 0 */
812                 len = 1;
813             aint = (s - strbeg) % len;
814             if (aint)                   /* Other portable ways? */
815                 len = len - aint;
816             else
817                 len = 0;
818             /* FALL THROUGH */
819         case 'x':
820             if (len > strend - s)
821                 Perl_croak(aTHX_ "'x' outside of string in unpack");
822             s += len;
823             break;
824         case '/':
825             Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
826             break;
827         case 'A':
828         case 'Z':
829         case 'a':
830             if (len > strend - s)
831                 len = strend - s;
832             if (checksum)
833                 goto uchar_checksum;
834             sv = newSVpvn(s, len);
835             if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
836                 aptr = s;       /* borrow register */
837                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
838                     s = SvPVX(sv);
839                     while (*s)
840                         s++;
841                     if (howlen == e_star) /* exact for 'Z*' */
842                         len = s - SvPVX(sv) + 1;
843                 }
844                 else {          /* 'A' strips both nulls and spaces */
845                     s = SvPVX(sv) + len - 1;
846                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
847                         s--;
848                     *++s = '\0';
849                 }
850                 SvCUR_set(sv, s - SvPVX(sv));
851                 s = aptr;       /* unborrow register */
852             }
853             s += len;
854             XPUSHs(sv_2mortal(sv));
855             break;
856         case 'B':
857         case 'b':
858             if (howlen == e_star || len > (strend - s) * 8)
859                 len = (strend - s) * 8;
860             if (checksum) {
861                 if (!PL_bitcount) {
862                     Newz(601, PL_bitcount, 256, char);
863                     for (bits = 1; bits < 256; bits++) {
864                         if (bits & 1)   PL_bitcount[bits]++;
865                         if (bits & 2)   PL_bitcount[bits]++;
866                         if (bits & 4)   PL_bitcount[bits]++;
867                         if (bits & 8)   PL_bitcount[bits]++;
868                         if (bits & 16)  PL_bitcount[bits]++;
869                         if (bits & 32)  PL_bitcount[bits]++;
870                         if (bits & 64)  PL_bitcount[bits]++;
871                         if (bits & 128) PL_bitcount[bits]++;
872                     }
873                 }
874                 while (len >= 8) {
875                     cuv += PL_bitcount[*(unsigned char*)s++];
876                     len -= 8;
877                 }
878                 if (len) {
879                     bits = *s;
880                     if (datumtype == 'b') {
881                         while (len-- > 0) {
882                             if (bits & 1) cuv++;
883                             bits >>= 1;
884                         }
885                     }
886                     else {
887                         while (len-- > 0) {
888                             if (bits & 128) cuv++;
889                             bits <<= 1;
890                         }
891                     }
892                 }
893                 break;
894             }
895             sv = NEWSV(35, len + 1);
896             SvCUR_set(sv, len);
897             SvPOK_on(sv);
898             str = SvPVX(sv);
899             if (datumtype == 'b') {
900                 aint = len;
901                 for (len = 0; len < aint; len++) {
902                     if (len & 7)                /*SUPPRESS 595*/
903                         bits >>= 1;
904                     else
905                         bits = *s++;
906                     *str++ = '0' + (bits & 1);
907                 }
908             }
909             else {
910                 aint = len;
911                 for (len = 0; len < aint; len++) {
912                     if (len & 7)
913                         bits <<= 1;
914                     else
915                         bits = *s++;
916                     *str++ = '0' + ((bits & 128) != 0);
917                 }
918             }
919             *str = '\0';
920             XPUSHs(sv_2mortal(sv));
921             break;
922         case 'H':
923         case 'h':
924             if (howlen == e_star || len > (strend - s) * 2)
925                 len = (strend - s) * 2;
926             sv = NEWSV(35, len + 1);
927             SvCUR_set(sv, len);
928             SvPOK_on(sv);
929             str = SvPVX(sv);
930             if (datumtype == 'h') {
931                 aint = len;
932                 for (len = 0; len < aint; len++) {
933                     if (len & 1)
934                         bits >>= 4;
935                     else
936                         bits = *s++;
937                     *str++ = PL_hexdigit[bits & 15];
938                 }
939             }
940             else {
941                 aint = len;
942                 for (len = 0; len < aint; len++) {
943                     if (len & 1)
944                         bits <<= 4;
945                     else
946                         bits = *s++;
947                     *str++ = PL_hexdigit[(bits >> 4) & 15];
948                 }
949             }
950             *str = '\0';
951             XPUSHs(sv_2mortal(sv));
952             break;
953         case 'c':
954             if (len > strend - s)
955                 len = strend - s;
956             if (!checksum) {
957                 if (len && unpack_only_one)
958                     len = 1;
959                 EXTEND(SP, len);
960                 EXTEND_MORTAL(len);
961             }
962             while (len-- > 0) {
963                 aint = *s++;
964                 if (aint >= 128)        /* fake up signed chars */
965                     aint -= 256;
966                 if (!checksum) {
967                     PUSHs(sv_2mortal(newSViv((IV)aint)));
968                 }
969                 else if (checksum > bits_in_uv)
970                     cdouble += (NV)aint;
971                 else
972                     cuv += aint;
973             }
974             break;
975         case 'C':
976         unpack_C: /* unpack U will jump here if not UTF-8 */
977             if (len == 0) {
978                 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
979                 break;
980             }
981             if (len > strend - s)
982                 len = strend - s;
983             if (checksum) {
984               uchar_checksum:
985                 while (len-- > 0) {
986                     auint = *s++ & 255;
987                     cuv += auint;
988                 }
989             }
990             else {
991                 if (len && unpack_only_one)
992                     len = 1;
993                 EXTEND(SP, len);
994                 EXTEND_MORTAL(len);
995                 while (len-- > 0) {
996                     auint = *s++ & 255;
997                     PUSHs(sv_2mortal(newSViv((IV)auint)));
998                 }
999             }
1000             break;
1001         case 'U':
1002             if (len == 0) {
1003                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1004                 break;
1005             }
1006             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1007                  goto unpack_C;
1008             if (len > strend - s)
1009                 len = strend - s;
1010             if (!checksum) {
1011                 if (len && unpack_only_one)
1012                     len = 1;
1013                 EXTEND(SP, len);
1014                 EXTEND_MORTAL(len);
1015             }
1016             while (len-- > 0 && s < strend) {
1017                 STRLEN alen;
1018                 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1019                 along = alen;
1020                 s += along;
1021                 if (!checksum) {
1022                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1023                 }
1024                 else if (checksum > bits_in_uv)
1025                     cdouble += (NV)auint;
1026                 else
1027                     cuv += auint;
1028             }
1029             break;
1030         case 's' | TYPE_IS_SHRIEKING:
1031 #if SHORTSIZE != SIZE16
1032             along = (strend - s) / sizeof(short);
1033             if (len > along)
1034                 len = along;
1035             if (!checksum) {
1036                 if (len && unpack_only_one)
1037                     len = 1;
1038                 EXTEND(SP, len);
1039                 EXTEND_MORTAL(len);
1040             }
1041             while (len-- > 0) {
1042                 COPYNN(s, &ashort, sizeof(short));
1043                 DO_BO_UNPACK(ashort, s);
1044                 s += sizeof(short);
1045                 if (!checksum) {
1046                     PUSHs(sv_2mortal(newSViv((IV)ashort)));
1047                 }
1048                 else if (checksum > bits_in_uv)
1049                     cdouble += (NV)ashort;
1050                 else
1051                     cuv += ashort;
1052             }
1053             break;
1054 #else
1055             /* Fallthrough! */
1056 #endif
1057         case 's':
1058             along = (strend - s) / SIZE16;
1059             if (len > along)
1060                 len = along;
1061             if (!checksum) {
1062                 if (len && unpack_only_one)
1063                     len = 1;
1064                 EXTEND(SP, len);
1065                 EXTEND_MORTAL(len);
1066             }
1067             while (len-- > 0) {
1068                 COPY16(s, &ai16);
1069                 DO_BO_UNPACK(ai16, 16);
1070 #if U16SIZE > SIZE16
1071                 if (ai16 > 32767)
1072                     ai16 -= 65536;
1073 #endif
1074                 s += SIZE16;
1075                 if (!checksum) {
1076                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1077                 }
1078                 else if (checksum > bits_in_uv)
1079                     cdouble += (NV)ai16;
1080                 else
1081                     cuv += ai16;
1082             }
1083             break;
1084         case 'S' | TYPE_IS_SHRIEKING:
1085 #if SHORTSIZE != SIZE16
1086             along = (strend - s) / sizeof(unsigned short);
1087             if (len > along)
1088                 len = along;
1089             if (!checksum) {
1090                 if (len && unpack_only_one)
1091                     len = 1;
1092                 EXTEND(SP, len);
1093                 EXTEND_MORTAL(len);
1094             }
1095             while (len-- > 0) {
1096                 COPYNN(s, &aushort, sizeof(unsigned short));
1097                 DO_BO_UNPACK(aushort, s);
1098                 s += sizeof(unsigned short);
1099                 if (!checksum) {
1100                     PUSHs(sv_2mortal(newSViv((UV)aushort)));
1101                 }
1102                 else if (checksum > bits_in_uv)
1103                     cdouble += (NV)aushort;
1104                 else
1105                     cuv += aushort;
1106             }
1107             break;
1108 #else
1109             /* Fallhrough! */
1110 #endif
1111         case 'v':
1112         case 'n':
1113         case 'S':
1114             along = (strend - s) / SIZE16;
1115             if (len > along)
1116                 len = along;
1117             if (!checksum) {
1118                 if (len && unpack_only_one)
1119                     len = 1;
1120                 EXTEND(SP, len);
1121                 EXTEND_MORTAL(len);
1122             }
1123             while (len-- > 0) {
1124                 COPY16(s, &au16);
1125                 DO_BO_UNPACK(au16, 16);
1126                 s += SIZE16;
1127 #ifdef HAS_NTOHS
1128                 if (datumtype == 'n')
1129                     au16 = PerlSock_ntohs(au16);
1130 #endif
1131 #ifdef HAS_VTOHS
1132                 if (datumtype == 'v')
1133                     au16 = vtohs(au16);
1134 #endif
1135                 if (!checksum) {
1136                     PUSHs(sv_2mortal(newSViv((UV)au16)));
1137                 }
1138                 else if (checksum > bits_in_uv)
1139                     cdouble += (NV)au16;
1140                 else
1141                     cuv += au16;
1142             }
1143             break;
1144         case 'v' | TYPE_IS_SHRIEKING:
1145         case 'n' | TYPE_IS_SHRIEKING:
1146             along = (strend - s) / SIZE16;
1147             if (len > along)
1148                 len = along;
1149             if (!checksum) {
1150                 if (len && unpack_only_one)
1151                     len = 1;
1152                 EXTEND(SP, len);
1153                 EXTEND_MORTAL(len);
1154             }
1155             while (len-- > 0) {
1156                 COPY16(s, &ai16);
1157                 s += SIZE16;
1158 #ifdef HAS_NTOHS
1159                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1160                     ai16 = (I16)PerlSock_ntohs((U16)ai16);
1161 #endif
1162 #ifdef HAS_VTOHS
1163                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1164                     ai16 = (I16)vtohs((U16)ai16);
1165 #endif
1166                 if (!checksum) {
1167                     PUSHs(sv_2mortal(newSViv((IV)ai16)));
1168                 }
1169                 else if (checksum > bits_in_uv)
1170                     cdouble += (NV)ai16;
1171                 else
1172                     cuv += ai16;
1173             }
1174             break;
1175         case 'i':
1176         case 'i' | TYPE_IS_SHRIEKING:
1177             along = (strend - s) / sizeof(int);
1178             if (len > along)
1179                 len = along;
1180             if (!checksum) {
1181                 if (len && unpack_only_one)
1182                     len = 1;
1183                 EXTEND(SP, len);
1184                 EXTEND_MORTAL(len);
1185             }
1186             while (len-- > 0) {
1187                 Copy(s, &aint, 1, int);
1188                 DO_BO_UNPACK(aint, i);
1189                 s += sizeof(int);
1190                 if (!checksum) {
1191                     PUSHs(sv_2mortal(newSViv((IV)aint)));
1192                 }
1193                 else if (checksum > bits_in_uv)
1194                     cdouble += (NV)aint;
1195                 else
1196                     cuv += aint;
1197             }
1198             break;
1199         case 'I':
1200         case 'I' | TYPE_IS_SHRIEKING:
1201             along = (strend - s) / sizeof(unsigned int);
1202             if (len > along)
1203                 len = along;
1204             if (!checksum) {
1205                 if (len && unpack_only_one)
1206                     len = 1;
1207                 EXTEND(SP, len);
1208                 EXTEND_MORTAL(len);
1209             }
1210             while (len-- > 0) {
1211                 Copy(s, &auint, 1, unsigned int);
1212                 DO_BO_UNPACK(auint, i);
1213                 s += sizeof(unsigned int);
1214                 if (!checksum) {
1215                     PUSHs(sv_2mortal(newSVuv((UV)auint)));
1216                 }
1217                 else if (checksum > bits_in_uv)
1218                     cdouble += (NV)auint;
1219                 else
1220                     cuv += auint;
1221             }
1222             break;
1223         case 'j':
1224             along = (strend - s) / IVSIZE;
1225             if (len > along)
1226                 len = along;
1227             if (!checksum) {
1228                 if (len && unpack_only_one)
1229                     len = 1;
1230                 EXTEND(SP, len);
1231                 EXTEND_MORTAL(len);
1232             }
1233             while (len-- > 0) {
1234                 Copy(s, &aiv, 1, IV);
1235 #if IVSIZE == INTSIZE
1236                 DO_BO_UNPACK(aiv, i);
1237 #elif IVSIZE == LONGSIZE
1238                 DO_BO_UNPACK(aiv, l);
1239 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1240                 DO_BO_UNPACK(aiv, 64);
1241 #endif
1242                 s += IVSIZE;
1243                 if (!checksum) {
1244                     PUSHs(sv_2mortal(newSViv(aiv)));
1245                 }
1246                 else if (checksum > bits_in_uv)
1247                     cdouble += (NV)aiv;
1248                 else
1249                     cuv += aiv;
1250             }
1251             break;
1252         case 'J':
1253             along = (strend - s) / UVSIZE;
1254             if (len > along)
1255                 len = along;
1256             if (!checksum) {
1257                 if (len && unpack_only_one)
1258                     len = 1;
1259                 EXTEND(SP, len);
1260                 EXTEND_MORTAL(len);
1261             }
1262             while (len-- > 0) {
1263                 Copy(s, &auv, 1, UV);
1264 #if UVSIZE == INTSIZE
1265                 DO_BO_UNPACK(auv, i);
1266 #elif UVSIZE == LONGSIZE
1267                 DO_BO_UNPACK(auv, l);
1268 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1269                 DO_BO_UNPACK(auv, 64);
1270 #endif
1271                 s += UVSIZE;
1272                 if (!checksum) {
1273                     PUSHs(sv_2mortal(newSVuv(auv)));
1274                 }
1275                 else if (checksum > bits_in_uv)
1276                     cdouble += (NV)auv;
1277                 else
1278                     cuv += auv;
1279             }
1280             break;
1281         case 'l' | TYPE_IS_SHRIEKING:
1282 #if LONGSIZE != SIZE32
1283             along = (strend - s) / sizeof(long);
1284             if (len > along)
1285                 len = along;
1286             if (!checksum) {
1287                 if (len && unpack_only_one)
1288                     len = 1;
1289                 EXTEND(SP, len);
1290                 EXTEND_MORTAL(len);
1291             }
1292             while (len-- > 0) {
1293                 COPYNN(s, &along, sizeof(long));
1294                 DO_BO_UNPACK(along, l);
1295                 s += sizeof(long);
1296                 if (!checksum) {
1297                     PUSHs(sv_2mortal(newSViv((IV)along)));
1298                 }
1299                 else if (checksum > bits_in_uv)
1300                     cdouble += (NV)along;
1301                 else
1302                     cuv += along;
1303             }
1304             break;
1305 #else
1306             /* Fallthrough! */
1307 #endif
1308         case 'l':
1309             along = (strend - s) / SIZE32;
1310             if (len > along)
1311                 len = along;
1312             if (!checksum) {
1313                 if (len && unpack_only_one)
1314                     len = 1;
1315                 EXTEND(SP, len);
1316                 EXTEND_MORTAL(len);
1317             }
1318             while (len-- > 0) {
1319                 COPY32(s, &ai32);
1320                 DO_BO_UNPACK(ai32, 32);
1321 #if U32SIZE > SIZE32
1322                 if (ai32 > 2147483647)
1323                     ai32 -= 4294967296;
1324 #endif
1325                 s += SIZE32;
1326                 if (!checksum) {
1327                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1328                 }
1329                 else if (checksum > bits_in_uv)
1330                     cdouble += (NV)ai32;
1331                 else
1332                     cuv += ai32;
1333             }
1334             break;
1335         case 'L' | TYPE_IS_SHRIEKING:
1336 #if LONGSIZE != SIZE32
1337             along = (strend - s) / sizeof(unsigned long);
1338             if (len > along)
1339                 len = along;
1340             if (!checksum) {
1341                 if (len && unpack_only_one)
1342                     len = 1;
1343                 EXTEND(SP, len);
1344                 EXTEND_MORTAL(len);
1345             }
1346             while (len-- > 0) {
1347                 COPYNN(s, &aulong, sizeof(unsigned long));
1348                 DO_BO_UNPACK(aulong, l);
1349                 s += sizeof(unsigned long);
1350                 if (!checksum) {
1351                     PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1352                 }
1353                 else if (checksum > bits_in_uv)
1354                     cdouble += (NV)aulong;
1355                 else
1356                     cuv += aulong;
1357             }
1358             break;
1359 #else
1360             /* Fall through! */
1361 #endif
1362         case 'V':
1363         case 'N':
1364         case 'L':
1365             along = (strend - s) / SIZE32;
1366             if (len > along)
1367                 len = along;
1368             if (!checksum) {
1369                 if (len && unpack_only_one)
1370                     len = 1;
1371                 EXTEND(SP, len);
1372                 EXTEND_MORTAL(len);
1373             }
1374             while (len-- > 0) {
1375                 COPY32(s, &au32);
1376                 DO_BO_UNPACK(au32, 32);
1377                 s += SIZE32;
1378 #ifdef HAS_NTOHL
1379                 if (datumtype == 'N')
1380                     au32 = PerlSock_ntohl(au32);
1381 #endif
1382 #ifdef HAS_VTOHL
1383                 if (datumtype == 'V')
1384                     au32 = vtohl(au32);
1385 #endif
1386                  if (!checksum) {
1387                      PUSHs(sv_2mortal(newSVuv((UV)au32)));
1388                  }
1389                  else if (checksum > bits_in_uv)
1390                      cdouble += (NV)au32;
1391                  else
1392                      cuv += au32;
1393             }
1394             break;
1395         case 'V' | TYPE_IS_SHRIEKING:
1396         case 'N' | TYPE_IS_SHRIEKING:
1397             along = (strend - s) / SIZE32;
1398             if (len > along)
1399                 len = along;
1400             if (!checksum) {
1401                 if (len && unpack_only_one)
1402                     len = 1;
1403                 EXTEND(SP, len);
1404                 EXTEND_MORTAL(len);
1405             }
1406             while (len-- > 0) {
1407                 COPY32(s, &ai32);
1408                 s += SIZE32;
1409 #ifdef HAS_NTOHL
1410                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1411                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1412 #endif
1413 #ifdef HAS_VTOHL
1414                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1415                     ai32 = (I32)vtohl((U32)ai32);
1416 #endif
1417                 if (!checksum) {
1418                     PUSHs(sv_2mortal(newSViv((IV)ai32)));
1419                 }
1420                 else if (checksum > bits_in_uv)
1421                     cdouble += (NV)ai32;
1422                 else
1423                     cuv += ai32;
1424             }
1425             break;
1426         case 'p':
1427             along = (strend - s) / sizeof(char*);
1428             if (len > along)
1429                 len = along;
1430             EXTEND(SP, len);
1431             EXTEND_MORTAL(len);
1432             while (len-- > 0) {
1433                 if (sizeof(char*) > strend - s)
1434                     break;
1435                 else {
1436                     Copy(s, &aptr, 1, char*);
1437                     DO_BO_UNPACK_P(aptr);
1438                     s += sizeof(char*);
1439                 }
1440                 /* newSVpv generates undef if aptr is NULL */
1441                 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1442             }
1443             break;
1444         case 'w':
1445             if (len && unpack_only_one)
1446                 len = 1;
1447             EXTEND(SP, len);
1448             EXTEND_MORTAL(len);
1449             {
1450                 UV auv = 0;
1451                 U32 bytes = 0;
1452                 
1453                 while ((len > 0) && (s < strend)) {
1454                     auv = (auv << 7) | (*s & 0x7f);
1455                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1456                     if ((U8)(*s++) < 0x80) {
1457                         bytes = 0;
1458                         PUSHs(sv_2mortal(newSVuv(auv)));
1459                         len--;
1460                         auv = 0;
1461                     }
1462                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1463                         char *t;
1464                         STRLEN n_a;
1465
1466                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1467                         while (s < strend) {
1468                             sv = mul128(sv, (U8)(*s & 0x7f));
1469                             if (!(*s++ & 0x80)) {
1470                                 bytes = 0;
1471                                 break;
1472                             }
1473                         }
1474                         t = SvPV(sv, n_a);
1475                         while (*t == '0')
1476                             t++;
1477                         sv_chop(sv, t);
1478                         PUSHs(sv_2mortal(sv));
1479                         len--;
1480                         auv = 0;
1481                     }
1482                 }
1483                 if ((s >= strend) && bytes)
1484                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1485             }
1486             break;
1487         case 'P':
1488             if (symptr->howlen == e_star)
1489                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1490             EXTEND(SP, 1);
1491             if (sizeof(char*) > strend - s)
1492                 break;
1493             else {
1494                 Copy(s, &aptr, 1, char*);
1495                 DO_BO_UNPACK_P(aptr);
1496                 s += sizeof(char*);
1497             }
1498             /* newSVpvn generates undef if aptr is NULL */
1499             PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1500             break;
1501 #ifdef HAS_QUAD
1502         case 'q':
1503             along = (strend - s) / sizeof(Quad_t);
1504             if (len > along)
1505                 len = along;
1506             if (!checksum) {
1507                 if (len && unpack_only_one)
1508                     len = 1;
1509                 EXTEND(SP, len);
1510                 EXTEND_MORTAL(len);
1511             }
1512             while (len-- > 0) {
1513                 if (s + sizeof(Quad_t) > strend) {
1514                     /* Surely this should never happen? NWC  */
1515                     aquad = 0;
1516                 }
1517                 else {
1518                     Copy(s, &aquad, 1, Quad_t);
1519                     DO_BO_UNPACK(aquad, 64);
1520                     s += sizeof(Quad_t);
1521                 }
1522                 if (!checksum) {
1523                     PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1524                                      newSViv((IV)aquad) : newSVnv((NV)aquad)));
1525                 }
1526                 else if (checksum > bits_in_uv)
1527                     cdouble += (NV)aquad;
1528                 else
1529                     cuv += aquad;
1530             }
1531             break;
1532         case 'Q':
1533             along = (strend - s) / sizeof(Uquad_t);
1534             if (len > along)
1535                 len = along;
1536             if (!checksum) {
1537                 if (len && unpack_only_one)
1538                     len = 1;
1539                 EXTEND(SP, len);
1540                 EXTEND_MORTAL(len);
1541             }
1542             while (len-- > 0) {
1543                 if (s + sizeof(Uquad_t) > strend)
1544                     auquad = 0;
1545                 else {
1546                     Copy(s, &auquad, 1, Uquad_t);
1547                     DO_BO_UNPACK(auquad, 64);
1548                     s += sizeof(Uquad_t);
1549                 }
1550                 if (!checksum) {
1551                     PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1552                                      newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1553                 }
1554                 else if (checksum > bits_in_uv)
1555                     cdouble += (NV)auquad;
1556                 else
1557                     cuv += auquad;
1558             }
1559             break;
1560 #endif
1561         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1562         case 'f':
1563             along = (strend - s) / sizeof(float);
1564             if (len > along)
1565                 len = along;
1566             if (!checksum) {
1567                 if (len && unpack_only_one)
1568                     len = 1;
1569                 EXTEND(SP, len);
1570                 EXTEND_MORTAL(len);
1571             }
1572             while (len-- > 0) {
1573                 Copy(s, &afloat, 1, float);
1574                 DO_BO_UNPACK_N(afloat, float);
1575                 s += sizeof(float);
1576                 if (!checksum) {
1577                     PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1578                 }
1579                 else {
1580                     cdouble += afloat;
1581                 }
1582             }
1583             break;
1584         case 'd':
1585             along = (strend - s) / sizeof(double);
1586             if (len > along)
1587                 len = along;
1588             if (!checksum) {
1589                 if (len && unpack_only_one)
1590                     len = 1;
1591                 EXTEND(SP, len);
1592                 EXTEND_MORTAL(len);
1593             }
1594             while (len-- > 0) {
1595                 Copy(s, &adouble, 1, double);
1596                 DO_BO_UNPACK_N(adouble, double);
1597                 s += sizeof(double);
1598                 if (!checksum) {
1599                     PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1600                 }
1601                 else {
1602                     cdouble += adouble;
1603                 }
1604             }
1605             break;
1606         case 'F':
1607             along = (strend - s) / NVSIZE;
1608             if (len > along)
1609                 len = along;
1610             if (!checksum) {
1611                 if (len && unpack_only_one)
1612                     len = 1;
1613                 EXTEND(SP, len);
1614                 EXTEND_MORTAL(len);
1615             }
1616             while (len-- > 0) {
1617                 Copy(s, &anv, 1, NV);
1618                 DO_BO_UNPACK_N(anv, NV);
1619                 s += NVSIZE;
1620                 if (!checksum) {
1621                     PUSHs(sv_2mortal(newSVnv(anv)));
1622                 }
1623                 else {
1624                     cdouble += anv;
1625                 }
1626             }
1627             break;
1628 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1629         case 'D':
1630             along = (strend - s) / LONG_DOUBLESIZE;
1631             if (len > along)
1632                 len = along;
1633             if (!checksum) {
1634                 if (len && unpack_only_one)
1635                     len = 1;
1636                 EXTEND(SP, len);
1637                 EXTEND_MORTAL(len);
1638             }
1639             while (len-- > 0) {
1640                 Copy(s, &aldouble, 1, long double);
1641                 DO_BO_UNPACK_N(aldouble, long double);
1642                 s += LONG_DOUBLESIZE;
1643                 if (!checksum) {
1644                     PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1645                 }
1646                 else {cdouble += aldouble;
1647                 }
1648             }
1649             break;
1650 #endif
1651         case 'u':
1652             /* MKS:
1653              * Initialise the decode mapping.  By using a table driven
1654              * algorithm, the code will be character-set independent
1655              * (and just as fast as doing character arithmetic)
1656              */
1657             if (PL_uudmap['M'] == 0) {
1658                 int i;
1659
1660                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1661                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1662                 /*
1663                  * Because ' ' and '`' map to the same value,
1664                  * we need to decode them both the same.
1665                  */
1666                 PL_uudmap[' '] = 0;
1667             }
1668
1669             along = (strend - s) * 3 / 4;
1670             sv = NEWSV(42, along);
1671             if (along)
1672                 SvPOK_on(sv);
1673             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1674                 I32 a, b, c, d;
1675                 char hunk[4];
1676
1677                 hunk[3] = '\0';
1678                 len = PL_uudmap[*(U8*)s++] & 077;
1679                 while (len > 0) {
1680                     if (s < strend && ISUUCHAR(*s))
1681                         a = PL_uudmap[*(U8*)s++] & 077;
1682                     else
1683                         a = 0;
1684                     if (s < strend && ISUUCHAR(*s))
1685                         b = PL_uudmap[*(U8*)s++] & 077;
1686                     else
1687                         b = 0;
1688                     if (s < strend && ISUUCHAR(*s))
1689                         c = PL_uudmap[*(U8*)s++] & 077;
1690                     else
1691                         c = 0;
1692                     if (s < strend && ISUUCHAR(*s))
1693                         d = PL_uudmap[*(U8*)s++] & 077;
1694                     else
1695                         d = 0;
1696                     hunk[0] = (char)((a << 2) | (b >> 4));
1697                     hunk[1] = (char)((b << 4) | (c >> 2));
1698                     hunk[2] = (char)((c << 6) | d);
1699                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1700                     len -= 3;
1701                 }
1702                 if (*s == '\n')
1703                     s++;
1704                 else    /* possible checksum byte */
1705                     if (s + 1 < strend && s[1] == '\n')
1706                         s += 2;
1707             }
1708             XPUSHs(sv_2mortal(sv));
1709             break;
1710         }
1711
1712         if (checksum) {
1713             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1714               (checksum > bits_in_uv &&
1715                strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1716                 NV trouble;
1717
1718                 adouble = (NV) (1 << (checksum & 15));
1719                 while (checksum >= 16) {
1720                     checksum -= 16;
1721                     adouble *= 65536.0;
1722                 }
1723                 while (cdouble < 0.0)
1724                     cdouble += adouble;
1725                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1726                 sv = newSVnv(cdouble);
1727             }
1728             else {
1729                 if (checksum < bits_in_uv) {
1730                     UV mask = ((UV)1 << checksum) - 1;
1731                     cuv &= mask;
1732                 }
1733                 sv = newSVuv(cuv);
1734             }
1735             XPUSHs(sv_2mortal(sv));
1736             checksum = 0;
1737         }
1738     
1739         if (symptr->flags & FLAG_SLASH){
1740             if (SP - PL_stack_base - start_sp_offset <= 0)
1741                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1742             if( next_symbol(symptr) ){
1743               if( symptr->howlen == e_number )
1744                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1745               if( beyond ){
1746                 /* ...end of char buffer then no decent length available */
1747                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1748               } else {
1749                 /* take top of stack (hope it's numeric) */
1750                 len = POPi;
1751                 if( len < 0 )
1752                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1753               }
1754             } else {
1755                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1756             }
1757             datumtype = symptr->code;
1758             goto redo_switch;
1759         }
1760     }
1761
1762     if (new_s)
1763         *new_s = s;
1764     PUTBACK;
1765     return SP - PL_stack_base - start_sp_offset;
1766 }
1767
1768 PP(pp_unpack)
1769 {
1770     dSP;
1771     dPOPPOPssrl;
1772     I32 gimme = GIMME_V;
1773     STRLEN llen;
1774     STRLEN rlen;
1775     register char *pat = SvPV(left, llen);
1776 #ifdef PACKED_IS_OCTETS
1777     /* Packed side is assumed to be octets - so force downgrade if it
1778        has been UTF-8 encoded by accident
1779      */
1780     register char *s = SvPVbyte(right, rlen);
1781 #else
1782     register char *s = SvPV(right, rlen);
1783 #endif
1784     char *strend = s + rlen;
1785     register char *patend = pat + llen;
1786     register I32 cnt;
1787
1788     PUTBACK;
1789     cnt = unpackstring(pat, patend, s, strend,
1790                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1791                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1792
1793     SPAGAIN;
1794     if ( !cnt && gimme == G_SCALAR )
1795        PUSHs(&PL_sv_undef);
1796     RETURN;
1797 }
1798
1799 STATIC void
1800 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1801 {
1802     char hunk[5];
1803
1804     *hunk = PL_uuemap[len];
1805     sv_catpvn(sv, hunk, 1);
1806     hunk[4] = '\0';
1807     while (len > 2) {
1808         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1809         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1810         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1811         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1812         sv_catpvn(sv, hunk, 4);
1813         s += 3;
1814         len -= 3;
1815     }
1816     if (len > 0) {
1817         char r = (len > 1 ? s[1] : '\0');
1818         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1819         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1820         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1821         hunk[3] = PL_uuemap[0];
1822         sv_catpvn(sv, hunk, 4);
1823     }
1824     sv_catpvn(sv, "\n", 1);
1825 }
1826
1827 STATIC SV *
1828 S_is_an_int(pTHX_ char *s, STRLEN l)
1829 {
1830   STRLEN         n_a;
1831   SV             *result = newSVpvn(s, l);
1832   char           *result_c = SvPV(result, n_a); /* convenience */
1833   char           *out = result_c;
1834   bool            skip = 1;
1835   bool            ignore = 0;
1836
1837   while (*s) {
1838     switch (*s) {
1839     case ' ':
1840       break;
1841     case '+':
1842       if (!skip) {
1843         SvREFCNT_dec(result);
1844         return (NULL);
1845       }
1846       break;
1847     case '0':
1848     case '1':
1849     case '2':
1850     case '3':
1851     case '4':
1852     case '5':
1853     case '6':
1854     case '7':
1855     case '8':
1856     case '9':
1857       skip = 0;
1858       if (!ignore) {
1859         *(out++) = *s;
1860       }
1861       break;
1862     case '.':
1863       ignore = 1;
1864       break;
1865     default:
1866       SvREFCNT_dec(result);
1867       return (NULL);
1868     }
1869     s++;
1870   }
1871   *(out++) = '\0';
1872   SvCUR_set(result, out - result_c);
1873   return (result);
1874 }
1875
1876 /* pnum must be '\0' terminated */
1877 STATIC int
1878 S_div128(pTHX_ SV *pnum, bool *done)
1879 {
1880   STRLEN          len;
1881   char           *s = SvPV(pnum, len);
1882   int             m = 0;
1883   int             r = 0;
1884   char           *t = s;
1885
1886   *done = 1;
1887   while (*t) {
1888     int             i;
1889
1890     i = m * 10 + (*t - '0');
1891     m = i & 0x7F;
1892     r = (i >> 7);               /* r < 10 */
1893     if (r) {
1894       *done = 0;
1895     }
1896     *(t++) = '0' + r;
1897   }
1898   *(t++) = '\0';
1899   SvCUR_set(pnum, (STRLEN) (t - s));
1900   return (m);
1901 }
1902
1903
1904
1905 /*
1906 =for apidoc pack_cat
1907
1908 The engine implementing pack() Perl function. Note: parameters next_in_list and
1909 flags are not used. This call should not be used; use packlist instead.
1910
1911 =cut */
1912
1913
1914 void
1915 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1916 {
1917     tempsym_t sym = { 0 };
1918     sym.patptr = pat;
1919     sym.patend = patend;
1920     sym.flags  = FLAG_PACK;
1921
1922     (void)pack_rec( cat, &sym, beglist, endlist );
1923 }
1924
1925
1926 /*
1927 =for apidoc packlist
1928
1929 The engine implementing pack() Perl function.
1930
1931 =cut */
1932
1933
1934 void
1935 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1936 {
1937     tempsym_t sym = { 0 };
1938     sym.patptr = pat;
1939     sym.patend = patend;
1940     sym.flags  = FLAG_PACK;
1941
1942     (void)pack_rec( cat, &sym, beglist, endlist );
1943 }
1944
1945
1946 STATIC
1947 SV **
1948 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1949 {
1950     register I32 items;
1951     STRLEN fromlen;
1952     register I32 len = 0;
1953     SV *fromstr;
1954     /*SUPPRESS 442*/
1955     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1956     static char *space10 = "          ";
1957     bool found;
1958
1959     /* These must not be in registers: */
1960     char achar;
1961     I16 ai16;
1962     U16 au16;
1963     I32 ai32;
1964     U32 au32;
1965 #ifdef HAS_QUAD
1966     Quad_t aquad;
1967     Uquad_t auquad;
1968 #endif
1969 #if SHORTSIZE != SIZE16
1970     short ashort;
1971     unsigned short aushort;
1972 #endif
1973     int aint;
1974     unsigned int auint;
1975 #if LONGSIZE != SIZE32
1976     long along;
1977     unsigned long aulong;
1978 #endif
1979     char *aptr;
1980     float afloat;
1981     double adouble;
1982 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1983     long double aldouble;
1984 #endif
1985     IV aiv;
1986     UV auv;
1987     NV anv;
1988
1989     int strrelbeg = SvCUR(cat);
1990     tempsym_t lookahead;
1991
1992     items = endlist - beglist;
1993     found = next_symbol( symptr );
1994
1995 #ifndef PACKED_IS_OCTETS
1996     if (symptr->level == 0 && found && symptr->code == 'U' ){
1997         SvUTF8_on(cat);
1998     }
1999 #endif
2000
2001     while (found) {
2002         SV *lengthcode = Nullsv;
2003 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2004
2005         I32 datumtype = symptr->code;
2006         howlen_t howlen;
2007
2008         switch( howlen = symptr->howlen ){
2009         case e_no_len:
2010         case e_number:
2011             len = symptr->length;
2012             break;
2013         case e_star:
2014             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items; 
2015             break;
2016         }
2017
2018         /* Look ahead for next symbol. Do we have code/code? */
2019         lookahead = *symptr;
2020         found = next_symbol(&lookahead);
2021         if ( symptr->flags & FLAG_SLASH ) {
2022             if (found){
2023                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2024                      e_star != lookahead.howlen )
2025                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2026                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2027                                                    ? *beglist : &PL_sv_no)
2028                                            + (lookahead.code == 'Z' ? 1 : 0)));
2029             } else {
2030                 Perl_croak(aTHX_ "Code missing after '/' in pack");
2031             }
2032         }
2033
2034         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2035         default:
2036             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2037         case '%':
2038             Perl_croak(aTHX_ "'%%' may not be used in pack");
2039         case '@':
2040             len += strrelbeg - SvCUR(cat);
2041             if (len > 0)
2042                 goto grow;
2043             len = -len;
2044             if (len > 0)
2045                 goto shrink;
2046             break;
2047         case '(':
2048         {
2049             tempsym_t savsym = *symptr;
2050             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2051             symptr->flags |= group_modifiers;
2052             symptr->patend = savsym.grpend;
2053             symptr->level++;
2054             while (len--) {
2055                 symptr->patptr = savsym.grpbeg;
2056                 beglist = pack_rec(cat, symptr, beglist, endlist );
2057                 if (savsym.howlen == e_star && beglist == endlist)
2058                     break;              /* No way to continue */
2059             }
2060             symptr->flags &= ~group_modifiers;
2061             lookahead.flags = symptr->flags;
2062             *symptr = savsym;
2063             break;
2064         }
2065         case 'X' | TYPE_IS_SHRIEKING:
2066             if (!len)                   /* Avoid division by 0 */
2067                 len = 1;
2068             len = (SvCUR(cat)) % len;
2069             /* FALL THROUGH */
2070         case 'X':
2071           shrink:
2072             if ((I32)SvCUR(cat) < len)
2073                 Perl_croak(aTHX_ "'X' outside of string in pack");
2074             SvCUR(cat) -= len;
2075             *SvEND(cat) = '\0';
2076             break;
2077         case 'x' | TYPE_IS_SHRIEKING:
2078             if (!len)                   /* Avoid division by 0 */
2079                 len = 1;
2080             aint = (SvCUR(cat)) % len;
2081             if (aint)                   /* Other portable ways? */
2082                 len = len - aint;
2083             else
2084                 len = 0;
2085             /* FALL THROUGH */
2086
2087         case 'x':
2088           grow:
2089             while (len >= 10) {
2090                 sv_catpvn(cat, null10, 10);
2091                 len -= 10;
2092             }
2093             sv_catpvn(cat, null10, len);
2094             break;
2095         case 'A':
2096         case 'Z':
2097         case 'a':
2098             fromstr = NEXTFROM;
2099             aptr = SvPV(fromstr, fromlen);
2100             if (howlen == e_star) {   
2101                 len = fromlen;
2102                 if (datumtype == 'Z')
2103                     ++len;
2104             }
2105             if ((I32)fromlen >= len) {
2106                 sv_catpvn(cat, aptr, len);
2107                 if (datumtype == 'Z')
2108                     *(SvEND(cat)-1) = '\0';
2109             }
2110             else {
2111                 sv_catpvn(cat, aptr, fromlen);
2112                 len -= fromlen;
2113                 if (datumtype == 'A') {
2114                     while (len >= 10) {
2115                         sv_catpvn(cat, space10, 10);
2116                         len -= 10;
2117                     }
2118                     sv_catpvn(cat, space10, len);
2119                 }
2120                 else {
2121                     while (len >= 10) {
2122                         sv_catpvn(cat, null10, 10);
2123                         len -= 10;
2124                     }
2125                     sv_catpvn(cat, null10, len);
2126                 }
2127             }
2128             break;
2129         case 'B':
2130         case 'b':
2131             {
2132                 register char *str;
2133                 I32 saveitems;
2134
2135                 fromstr = NEXTFROM;
2136                 saveitems = items;
2137                 str = SvPV(fromstr, fromlen);
2138                 if (howlen == e_star)
2139                     len = fromlen;
2140                 aint = SvCUR(cat);
2141                 SvCUR(cat) += (len+7)/8;
2142                 SvGROW(cat, SvCUR(cat) + 1);
2143                 aptr = SvPVX(cat) + aint;
2144                 if (len > (I32)fromlen)
2145                     len = fromlen;
2146                 aint = len;
2147                 items = 0;
2148                 if (datumtype == 'B') {
2149                     for (len = 0; len++ < aint;) {
2150                         items |= *str++ & 1;
2151                         if (len & 7)
2152                             items <<= 1;
2153                         else {
2154                             *aptr++ = items & 0xff;
2155                             items = 0;
2156                         }
2157                     }
2158                 }
2159                 else {
2160                     for (len = 0; len++ < aint;) {
2161                         if (*str++ & 1)
2162                             items |= 128;
2163                         if (len & 7)
2164                             items >>= 1;
2165                         else {
2166                             *aptr++ = items & 0xff;
2167                             items = 0;
2168                         }
2169                     }
2170                 }
2171                 if (aint & 7) {
2172                     if (datumtype == 'B')
2173                         items <<= 7 - (aint & 7);
2174                     else
2175                         items >>= 7 - (aint & 7);
2176                     *aptr++ = items & 0xff;
2177                 }
2178                 str = SvPVX(cat) + SvCUR(cat);
2179                 while (aptr <= str)
2180                     *aptr++ = '\0';
2181
2182                 items = saveitems;
2183             }
2184             break;
2185         case 'H':
2186         case 'h':
2187             {
2188                 register char *str;
2189                 I32 saveitems;
2190
2191                 fromstr = NEXTFROM;
2192                 saveitems = items;
2193                 str = SvPV(fromstr, fromlen);
2194                 if (howlen == e_star)
2195                     len = fromlen;
2196                 aint = SvCUR(cat);
2197                 SvCUR(cat) += (len+1)/2;
2198                 SvGROW(cat, SvCUR(cat) + 1);
2199                 aptr = SvPVX(cat) + aint;
2200                 if (len > (I32)fromlen)
2201                     len = fromlen;
2202                 aint = len;
2203                 items = 0;
2204                 if (datumtype == 'H') {
2205                     for (len = 0; len++ < aint;) {
2206                         if (isALPHA(*str))
2207                             items |= ((*str++ & 15) + 9) & 15;
2208                         else
2209                             items |= *str++ & 15;
2210                         if (len & 1)
2211                             items <<= 4;
2212                         else {
2213                             *aptr++ = items & 0xff;
2214                             items = 0;
2215                         }
2216                     }
2217                 }
2218                 else {
2219                     for (len = 0; len++ < aint;) {
2220                         if (isALPHA(*str))
2221                             items |= (((*str++ & 15) + 9) & 15) << 4;
2222                         else
2223                             items |= (*str++ & 15) << 4;
2224                         if (len & 1)
2225                             items >>= 4;
2226                         else {
2227                             *aptr++ = items & 0xff;
2228                             items = 0;
2229                         }
2230                     }
2231                 }
2232                 if (aint & 1)
2233                     *aptr++ = items & 0xff;
2234                 str = SvPVX(cat) + SvCUR(cat);
2235                 while (aptr <= str)
2236                     *aptr++ = '\0';
2237
2238                 items = saveitems;
2239             }
2240             break;
2241         case 'C':
2242         case 'c':
2243             while (len-- > 0) {
2244                 fromstr = NEXTFROM;
2245                 switch (TYPE_NO_MODIFIERS(datumtype)) {
2246                 case 'C':
2247                     aint = SvIV(fromstr);
2248                     if ((aint < 0 || aint > 255) &&
2249                         ckWARN(WARN_PACK))
2250                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2251                                     "Character in 'C' format wrapped in pack");
2252                     achar = aint & 255;
2253                     sv_catpvn(cat, &achar, sizeof(char));
2254                     break;
2255                 case 'c':
2256                     aint = SvIV(fromstr);
2257                     if ((aint < -128 || aint > 127) &&
2258                         ckWARN(WARN_PACK))
2259                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2260                                     "Character in 'c' format wrapped in pack" );
2261                     achar = aint & 255;
2262                     sv_catpvn(cat, &achar, sizeof(char));
2263                     break;
2264                 }
2265             }
2266             break;
2267         case 'U':
2268             while (len-- > 0) {
2269                 fromstr = NEXTFROM;
2270                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2271                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2272                 SvCUR_set(cat,
2273                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2274                                                      auint,
2275                                                      ckWARN(WARN_UTF8) ?
2276                                                      0 : UNICODE_ALLOW_ANY)
2277                           - SvPVX(cat));
2278             }
2279             *SvEND(cat) = '\0';
2280             break;
2281         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2282         case 'f':
2283             while (len-- > 0) {
2284                 fromstr = NEXTFROM;
2285 #ifdef __VOS__
2286 /* VOS does not automatically map a floating-point overflow
2287    during conversion from double to float into infinity, so we
2288    do it by hand.  This code should either be generalized for
2289    any OS that needs it, or removed if and when VOS implements
2290    posix-976 (suggestion to support mapping to infinity).
2291    Paul.Green@stratus.com 02-04-02.  */
2292                 if (SvNV(fromstr) > FLT_MAX)
2293                      afloat = _float_constants[0];   /* single prec. inf. */
2294                 else if (SvNV(fromstr) < -FLT_MAX)
2295                      afloat = _float_constants[0];   /* single prec. inf. */
2296                 else afloat = (float)SvNV(fromstr);
2297 #else
2298 # if defined(VMS) && !defined(__IEEE_FP)
2299 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2300  * on Alpha; fake it if we don't have them.
2301  */
2302                 if (SvNV(fromstr) > FLT_MAX)
2303                      afloat = FLT_MAX;
2304                 else if (SvNV(fromstr) < -FLT_MAX)
2305                      afloat = -FLT_MAX;
2306                 else afloat = (float)SvNV(fromstr);
2307 # else
2308                 afloat = (float)SvNV(fromstr);
2309 # endif
2310 #endif
2311                 DO_BO_PACK_N(afloat, float);
2312                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2313             }
2314             break;
2315         case 'd':
2316             while (len-- > 0) {
2317                 fromstr = NEXTFROM;
2318 #ifdef __VOS__
2319 /* VOS does not automatically map a floating-point overflow
2320    during conversion from long double to double into infinity,
2321    so we do it by hand.  This code should either be generalized
2322    for any OS that needs it, or removed if and when VOS
2323    implements posix-976 (suggestion to support mapping to
2324    infinity).  Paul.Green@stratus.com 02-04-02.  */
2325                 if (SvNV(fromstr) > DBL_MAX)
2326                      adouble = _double_constants[0];   /* double prec. inf. */
2327                 else if (SvNV(fromstr) < -DBL_MAX)
2328                      adouble = _double_constants[0];   /* double prec. inf. */
2329                 else adouble = (double)SvNV(fromstr);
2330 #else
2331 # if defined(VMS) && !defined(__IEEE_FP)
2332 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2333  * on Alpha; fake it if we don't have them.
2334  */
2335                 if (SvNV(fromstr) > DBL_MAX)
2336                      adouble = DBL_MAX;
2337                 else if (SvNV(fromstr) < -DBL_MAX)
2338                      adouble = -DBL_MAX;
2339                 else adouble = (double)SvNV(fromstr);
2340 # else
2341                 adouble = (double)SvNV(fromstr);
2342 # endif
2343 #endif
2344                 DO_BO_PACK_N(adouble, double);
2345                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2346             }
2347             break;
2348         case 'F':
2349             Zero(&anv, 1, NV); /* can be long double with unused bits */
2350             while (len-- > 0) {
2351                 fromstr = NEXTFROM;
2352                 anv = SvNV(fromstr);
2353                 DO_BO_PACK_N(anv, NV);
2354                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2355             }
2356             break;
2357 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2358         case 'D':
2359             /* long doubles can have unused bits, which may be nonzero */
2360             Zero(&aldouble, 1, long double);
2361             while (len-- > 0) {
2362                 fromstr = NEXTFROM;
2363                 aldouble = (long double)SvNV(fromstr);
2364                 DO_BO_PACK_N(aldouble, long double);
2365                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2366             }
2367             break;
2368 #endif
2369         case 'n' | TYPE_IS_SHRIEKING:
2370         case 'n':
2371             while (len-- > 0) {
2372                 fromstr = NEXTFROM;
2373                 ai16 = (I16)SvIV(fromstr);
2374 #ifdef HAS_HTONS
2375                 ai16 = PerlSock_htons(ai16);
2376 #endif
2377                 CAT16(cat, &ai16);
2378             }
2379             break;
2380         case 'v' | TYPE_IS_SHRIEKING:
2381         case 'v':
2382             while (len-- > 0) {
2383                 fromstr = NEXTFROM;
2384                 ai16 = (I16)SvIV(fromstr);
2385 #ifdef HAS_HTOVS
2386                 ai16 = htovs(ai16);
2387 #endif
2388                 CAT16(cat, &ai16);
2389             }
2390             break;
2391         case 'S' | TYPE_IS_SHRIEKING:
2392 #if SHORTSIZE != SIZE16
2393             {
2394                 while (len-- > 0) {
2395                     fromstr = NEXTFROM;
2396                     aushort = SvUV(fromstr);
2397                     DO_BO_PACK(aushort, s);
2398                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2399                 }
2400             }
2401             break;
2402 #else
2403             /* Fall through! */
2404 #endif
2405         case 'S':
2406             {
2407                 while (len-- > 0) {
2408                     fromstr = NEXTFROM;
2409                     au16 = (U16)SvUV(fromstr);
2410                     DO_BO_PACK(au16, 16);
2411                     CAT16(cat, &au16);
2412                 }
2413
2414             }
2415             break;
2416         case 's' | TYPE_IS_SHRIEKING:
2417 #if SHORTSIZE != SIZE16
2418             {
2419                 while (len-- > 0) {
2420                     fromstr = NEXTFROM;
2421                     ashort = SvIV(fromstr);
2422                     DO_BO_PACK(ashort, s);
2423                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2424                 }
2425             }
2426             break;
2427 #else
2428             /* Fall through! */
2429 #endif
2430         case 's':
2431             while (len-- > 0) {
2432                 fromstr = NEXTFROM;
2433                 ai16 = (I16)SvIV(fromstr);
2434                 DO_BO_PACK(ai16, 16);
2435                 CAT16(cat, &ai16);
2436             }
2437             break;
2438         case 'I':
2439         case 'I' | TYPE_IS_SHRIEKING:
2440             while (len-- > 0) {
2441                 fromstr = NEXTFROM;
2442                 auint = SvUV(fromstr);
2443                 DO_BO_PACK(auint, i);
2444                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2445             }
2446             break;
2447         case 'j':
2448             while (len-- > 0) {
2449                 fromstr = NEXTFROM;
2450                 aiv = SvIV(fromstr);
2451 #if IVSIZE == INTSIZE
2452                 DO_BO_PACK(aiv, i);
2453 #elif IVSIZE == LONGSIZE
2454                 DO_BO_PACK(aiv, l);
2455 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2456                 DO_BO_PACK(aiv, 64);
2457 #endif
2458                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2459             }
2460             break;
2461         case 'J':
2462             while (len-- > 0) {
2463                 fromstr = NEXTFROM;
2464                 auv = SvUV(fromstr);
2465 #if UVSIZE == INTSIZE
2466                 DO_BO_PACK(auv, i);
2467 #elif UVSIZE == LONGSIZE
2468                 DO_BO_PACK(auv, l);
2469 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2470                 DO_BO_PACK(auv, 64);
2471 #endif
2472                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2473             }
2474             break;
2475         case 'w':
2476             while (len-- > 0) {
2477                 fromstr = NEXTFROM;
2478                 anv = SvNV(fromstr);
2479
2480                 if (anv < 0)
2481                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2482
2483                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2484                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2485                    any negative IVs will have already been got by the croak()
2486                    above. IOK is untrue for fractions, so we test them
2487                    against UV_MAX_P1.  */
2488                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2489                 {
2490                     char   buf[(sizeof(UV)*8)/7+1];
2491                     char  *in = buf + sizeof(buf);
2492                     UV     auv = SvUV(fromstr);
2493
2494                     do {
2495                         *--in = (char)((auv & 0x7f) | 0x80);
2496                         auv >>= 7;
2497                     } while (auv);
2498                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2499                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2500                 }
2501                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2502                     char           *from, *result, *in;
2503                     SV             *norm;
2504                     STRLEN          len;
2505                     bool            done;
2506
2507                     /* Copy string and check for compliance */
2508                     from = SvPV(fromstr, len);
2509                     if ((norm = is_an_int(from, len)) == NULL)
2510                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2511
2512                     New('w', result, len, char);
2513                     in = result + len;
2514                     done = FALSE;
2515                     while (!done)
2516                         *--in = div128(norm, &done) | 0x80;
2517                     result[len - 1] &= 0x7F; /* clear continue bit */
2518                     sv_catpvn(cat, in, (result + len) - in);
2519                     Safefree(result);
2520                     SvREFCNT_dec(norm); /* free norm */
2521                 }
2522                 else if (SvNOKp(fromstr)) {
2523                     /* 10**NV_MAX_10_EXP is the largest power of 10
2524                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2525                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2526                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2527                        And with that many bytes only Inf can overflow.
2528                        Some C compilers are strict about integral constant
2529                        expressions so we conservatively divide by a slightly
2530                        smaller integer instead of multiplying by the exact
2531                        floating-point value.
2532                     */
2533 #ifdef NV_MAX_10_EXP
2534 /*                  char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2535                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2536 #else
2537 /*                  char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2538                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2539 #endif
2540                     char  *in = buf + sizeof(buf);
2541
2542                     anv = Perl_floor(anv);
2543                     do {
2544                         NV next = Perl_floor(anv / 128);
2545                         if (in <= buf)  /* this cannot happen ;-) */
2546                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2547                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2548                         anv = next;
2549                     } while (anv > 0);
2550                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2551                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2552                 }
2553                 else {
2554                     char           *from, *result, *in;
2555                     SV             *norm;
2556                     STRLEN          len;
2557                     bool            done;
2558
2559                     /* Copy string and check for compliance */
2560                     from = SvPV(fromstr, len);
2561                     if ((norm = is_an_int(from, len)) == NULL)
2562                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2563
2564                     New('w', result, len, char);
2565                     in = result + len;
2566                     done = FALSE;
2567                     while (!done)
2568                         *--in = div128(norm, &done) | 0x80;
2569                     result[len - 1] &= 0x7F; /* clear continue bit */
2570                     sv_catpvn(cat, in, (result + len) - in);
2571                     Safefree(result);
2572                     SvREFCNT_dec(norm); /* free norm */
2573                }
2574             }
2575             break;
2576         case 'i':
2577         case 'i' | TYPE_IS_SHRIEKING:
2578             while (len-- > 0) {
2579                 fromstr = NEXTFROM;
2580                 aint = SvIV(fromstr);
2581                 DO_BO_PACK(aint, i);
2582                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2583             }
2584             break;
2585         case 'N' | TYPE_IS_SHRIEKING:
2586         case 'N':
2587             while (len-- > 0) {
2588                 fromstr = NEXTFROM;
2589                 au32 = SvUV(fromstr);
2590 #ifdef HAS_HTONL
2591                 au32 = PerlSock_htonl(au32);
2592 #endif
2593                 CAT32(cat, &au32);
2594             }
2595             break;
2596         case 'V' | TYPE_IS_SHRIEKING:
2597         case 'V':
2598             while (len-- > 0) {
2599                 fromstr = NEXTFROM;
2600                 au32 = SvUV(fromstr);
2601 #ifdef HAS_HTOVL
2602                 au32 = htovl(au32);
2603 #endif
2604                 CAT32(cat, &au32);
2605             }
2606             break;
2607         case 'L' | TYPE_IS_SHRIEKING:
2608 #if LONGSIZE != SIZE32
2609             {
2610                 while (len-- > 0) {
2611                     fromstr = NEXTFROM;
2612                     aulong = SvUV(fromstr);
2613                     DO_BO_PACK(aulong, l);
2614                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2615                 }
2616             }
2617             break;
2618 #else
2619             /* Fall though! */
2620 #endif
2621         case 'L':
2622             {
2623                 while (len-- > 0) {
2624                     fromstr = NEXTFROM;
2625                     au32 = SvUV(fromstr);
2626                     DO_BO_PACK(au32, 32);
2627                     CAT32(cat, &au32);
2628                 }
2629             }
2630             break;
2631         case 'l' | TYPE_IS_SHRIEKING:
2632 #if LONGSIZE != SIZE32
2633             {
2634                 while (len-- > 0) {
2635                     fromstr = NEXTFROM;
2636                     along = SvIV(fromstr);
2637                     DO_BO_PACK(along, l);
2638                     sv_catpvn(cat, (char *)&along, sizeof(long));
2639                 }
2640             }
2641             break;
2642 #else
2643             /* Fall though! */
2644 #endif
2645         case 'l':
2646             while (len-- > 0) {
2647                 fromstr = NEXTFROM;
2648                 ai32 = SvIV(fromstr);
2649                 DO_BO_PACK(ai32, 32);
2650                 CAT32(cat, &ai32);
2651             }
2652             break;
2653 #ifdef HAS_QUAD
2654         case 'Q':
2655             while (len-- > 0) {
2656                 fromstr = NEXTFROM;
2657                 auquad = (Uquad_t)SvUV(fromstr);
2658                 DO_BO_PACK(auquad, 64);
2659                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2660             }
2661             break;
2662         case 'q':
2663             while (len-- > 0) {
2664                 fromstr = NEXTFROM;
2665                 aquad = (Quad_t)SvIV(fromstr);
2666                 DO_BO_PACK(aquad, 64);
2667                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2668             }
2669             break;
2670 #endif
2671         case 'P':
2672             len = 1;            /* assume SV is correct length */
2673             /* Fall through! */
2674         case 'p':
2675             while (len-- > 0) {
2676                 fromstr = NEXTFROM;
2677                 if (fromstr == &PL_sv_undef)
2678                     aptr = NULL;
2679                 else {
2680                     STRLEN n_a;
2681                     /* XXX better yet, could spirit away the string to
2682                      * a safe spot and hang on to it until the result
2683                      * of pack() (and all copies of the result) are
2684                      * gone.
2685                      */
2686                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2687                                                 || (SvPADTMP(fromstr)
2688                                                     && !SvREADONLY(fromstr))))
2689                     {
2690                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2691                                 "Attempt to pack pointer to temporary value");
2692                     }
2693                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2694                         aptr = SvPV(fromstr,n_a);
2695                     else
2696                         aptr = SvPV_force(fromstr,n_a);
2697                 }
2698                 DO_BO_PACK_P(aptr);
2699                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2700             }
2701             break;
2702         case 'u':
2703             fromstr = NEXTFROM;
2704             aptr = SvPV(fromstr, fromlen);
2705             SvGROW(cat, fromlen * 4 / 3);
2706             if (len <= 2)
2707                 len = 45;
2708             else
2709                 len = len / 3 * 3;
2710             while (fromlen > 0) {
2711                 I32 todo;
2712
2713                 if ((I32)fromlen > len)
2714                     todo = len;
2715                 else
2716                     todo = fromlen;
2717                 doencodes(cat, aptr, todo);
2718                 fromlen -= todo;
2719                 aptr += todo;
2720             }
2721             break;
2722         }
2723         *symptr = lookahead;
2724     }
2725     return beglist;
2726 }
2727 #undef NEXTFROM
2728
2729
2730 PP(pp_pack)
2731 {
2732     dSP; dMARK; dORIGMARK; dTARGET;
2733     register SV *cat = TARG;
2734     STRLEN fromlen;
2735     register char *pat = SvPVx(*++MARK, fromlen);
2736     register char *patend = pat + fromlen;
2737
2738     MARK++;
2739     sv_setpvn(cat, "", 0);
2740
2741     packlist(cat, pat, patend, MARK, SP + 1);
2742
2743     SvSETMAGIC(cat);
2744     SP = ORIGMARK;
2745     PUSHs(cat);
2746     RETURN;
2747 }
2748
2749 /*
2750  * Local variables:
2751  * c-indentation-style: bsd
2752  * c-basic-offset: 4
2753  * indent-tabs-mode: t
2754  * End:
2755  *
2756  * vim: expandtab shiftwidth=4:
2757 */