This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactor all the unpack checksum-or-not logic to avoid massive
[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 = NEWSV(35, len);
835             sv_setpvn(sv, s, len);
836             if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
837                 aptr = s;       /* borrow register */
838                 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
839                     s = SvPVX(sv);
840                     while (*s)
841                         s++;
842                     if (howlen == e_star) /* exact for 'Z*' */
843                         len = s - SvPVX(sv) + 1;
844                 }
845                 else {          /* 'A' strips both nulls and spaces */
846                     s = SvPVX(sv) + len - 1;
847                     while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
848                         s--;
849                     *++s = '\0';
850                 }
851                 SvCUR_set(sv, s - SvPVX(sv));
852                 s = aptr;       /* unborrow register */
853             }
854             s += len;
855             XPUSHs(sv_2mortal(sv));
856             break;
857         case 'B':
858         case 'b':
859             if (howlen == e_star || len > (strend - s) * 8)
860                 len = (strend - s) * 8;
861             if (checksum) {
862                 if (!PL_bitcount) {
863                     Newz(601, PL_bitcount, 256, char);
864                     for (bits = 1; bits < 256; bits++) {
865                         if (bits & 1)   PL_bitcount[bits]++;
866                         if (bits & 2)   PL_bitcount[bits]++;
867                         if (bits & 4)   PL_bitcount[bits]++;
868                         if (bits & 8)   PL_bitcount[bits]++;
869                         if (bits & 16)  PL_bitcount[bits]++;
870                         if (bits & 32)  PL_bitcount[bits]++;
871                         if (bits & 64)  PL_bitcount[bits]++;
872                         if (bits & 128) PL_bitcount[bits]++;
873                     }
874                 }
875                 while (len >= 8) {
876                     cuv += PL_bitcount[*(unsigned char*)s++];
877                     len -= 8;
878                 }
879                 if (len) {
880                     bits = *s;
881                     if (datumtype == 'b') {
882                         while (len-- > 0) {
883                             if (bits & 1) cuv++;
884                             bits >>= 1;
885                         }
886                     }
887                     else {
888                         while (len-- > 0) {
889                             if (bits & 128) cuv++;
890                             bits <<= 1;
891                         }
892                     }
893                 }
894                 break;
895             }
896             sv = NEWSV(35, len + 1);
897             SvCUR_set(sv, len);
898             SvPOK_on(sv);
899             str = SvPVX(sv);
900             if (datumtype == 'b') {
901                 aint = len;
902                 for (len = 0; len < aint; len++) {
903                     if (len & 7)                /*SUPPRESS 595*/
904                         bits >>= 1;
905                     else
906                         bits = *s++;
907                     *str++ = '0' + (bits & 1);
908                 }
909             }
910             else {
911                 aint = len;
912                 for (len = 0; len < aint; len++) {
913                     if (len & 7)
914                         bits <<= 1;
915                     else
916                         bits = *s++;
917                     *str++ = '0' + ((bits & 128) != 0);
918                 }
919             }
920             *str = '\0';
921             XPUSHs(sv_2mortal(sv));
922             break;
923         case 'H':
924         case 'h':
925             if (howlen == e_star || len > (strend - s) * 2)
926                 len = (strend - s) * 2;
927             sv = NEWSV(35, len + 1);
928             SvCUR_set(sv, len);
929             SvPOK_on(sv);
930             str = SvPVX(sv);
931             if (datumtype == 'h') {
932                 aint = len;
933                 for (len = 0; len < aint; len++) {
934                     if (len & 1)
935                         bits >>= 4;
936                     else
937                         bits = *s++;
938                     *str++ = PL_hexdigit[bits & 15];
939                 }
940             }
941             else {
942                 aint = len;
943                 for (len = 0; len < aint; len++) {
944                     if (len & 1)
945                         bits <<= 4;
946                     else
947                         bits = *s++;
948                     *str++ = PL_hexdigit[(bits >> 4) & 15];
949                 }
950             }
951             *str = '\0';
952             XPUSHs(sv_2mortal(sv));
953             break;
954         case 'c':
955             if (len > strend - s)
956                 len = strend - s;
957             if (!checksum) {
958                 if (len && unpack_only_one)
959                     len = 1;
960                 EXTEND(SP, len);
961                 EXTEND_MORTAL(len);
962             }
963             while (len-- > 0) {
964                 aint = *s++;
965                 if (aint >= 128)        /* fake up signed chars */
966                     aint -= 256;
967                 if (!checksum) {
968                     sv = NEWSV(36, 0);
969                     sv_setiv(sv, (IV)aint);
970                     PUSHs(sv_2mortal(sv));
971                 }
972                 else if (checksum > bits_in_uv)
973                     cdouble += (NV)aint;
974                 else
975                     cuv += aint;
976             }
977             break;
978         case 'C':
979         unpack_C: /* unpack U will jump here if not UTF-8 */
980             if (len == 0) {
981                 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
982                 break;
983             }
984             if (len > strend - s)
985                 len = strend - s;
986             if (checksum) {
987               uchar_checksum:
988                 while (len-- > 0) {
989                     auint = *s++ & 255;
990                     cuv += auint;
991                 }
992             }
993             else {
994                 if (len && unpack_only_one)
995                     len = 1;
996                 EXTEND(SP, len);
997                 EXTEND_MORTAL(len);
998                 while (len-- > 0) {
999                     auint = *s++ & 255;
1000                     sv = NEWSV(37, 0);
1001                     sv_setiv(sv, (IV)auint);
1002                     PUSHs(sv_2mortal(sv));
1003                 }
1004             }
1005             break;
1006         case 'U':
1007             if (len == 0) {
1008                 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1009                 break;
1010             }
1011             if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1012                  goto unpack_C;
1013             if (len > strend - s)
1014                 len = strend - s;
1015             if (!checksum) {
1016                 if (len && unpack_only_one)
1017                     len = 1;
1018                 EXTEND(SP, len);
1019                 EXTEND_MORTAL(len);
1020             }
1021             while (len-- > 0 && s < strend) {
1022                 STRLEN alen;
1023                 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1024                 along = alen;
1025                 s += along;
1026                 if (!checksum) {
1027                     sv = NEWSV(37, 0);
1028                     sv_setuv(sv, (UV)auint);
1029                     PUSHs(sv_2mortal(sv));
1030                 }
1031                 else if (checksum > bits_in_uv)
1032                     cdouble += (NV)auint;
1033                 else
1034                     cuv += auint;
1035             }
1036             break;
1037         case 's' | TYPE_IS_SHRIEKING:
1038 #if SHORTSIZE != SIZE16
1039             along = (strend - s) / sizeof(short);
1040             if (len > along)
1041                 len = along;
1042             if (!checksum) {
1043                 if (len && unpack_only_one)
1044                     len = 1;
1045                 EXTEND(SP, len);
1046                 EXTEND_MORTAL(len);
1047             }
1048             while (len-- > 0) {
1049                 COPYNN(s, &ashort, sizeof(short));
1050                 DO_BO_UNPACK(ashort, s);
1051                 s += sizeof(short);
1052                 if (!checksum) {
1053                     sv = NEWSV(38, 0);
1054                     sv_setiv(sv, (IV)ashort);
1055                     PUSHs(sv_2mortal(sv));
1056                 }
1057                 else if (checksum > bits_in_uv)
1058                     cdouble += (NV)ashort;
1059                 else
1060                     cuv += ashort;
1061             }
1062             break;
1063 #else
1064             /* Fallthrough! */
1065 #endif
1066         case 's':
1067             along = (strend - s) / SIZE16;
1068             if (len > along)
1069                 len = along;
1070             if (!checksum) {
1071                 if (len && unpack_only_one)
1072                     len = 1;
1073                 EXTEND(SP, len);
1074                 EXTEND_MORTAL(len);
1075             }
1076             while (len-- > 0) {
1077                 COPY16(s, &ai16);
1078                 DO_BO_UNPACK(ai16, 16);
1079 #if U16SIZE > SIZE16
1080                 if (ai16 > 32767)
1081                     ai16 -= 65536;
1082 #endif
1083                 s += SIZE16;
1084                 if (!checksum) {
1085                     sv = NEWSV(38, 0);
1086                     sv_setiv(sv, (IV)ai16);
1087                     PUSHs(sv_2mortal(sv));
1088                 }
1089                 else if (checksum > bits_in_uv)
1090                     cdouble += (NV)ai16;
1091                 else
1092                     cuv += ai16;
1093             }
1094             break;
1095         case 'S' | TYPE_IS_SHRIEKING:
1096 #if SHORTSIZE != SIZE16
1097             along = (strend - s) / sizeof(unsigned short);
1098             if (len > along)
1099                 len = along;
1100             if (!checksum) {
1101                 if (len && unpack_only_one)
1102                     len = 1;
1103                 EXTEND(SP, len);
1104                 EXTEND_MORTAL(len);
1105             }
1106             while (len-- > 0) {
1107                 COPYNN(s, &aushort, sizeof(unsigned short));
1108                 DO_BO_UNPACK(aushort, s);
1109                 s += sizeof(unsigned short);
1110                 if (!checksum) {
1111                     sv = NEWSV(39, 0);
1112                     sv_setiv(sv, (UV)aushort);
1113                     PUSHs(sv_2mortal(sv));
1114                 }
1115                 else if (checksum > bits_in_uv)
1116                     cdouble += (NV)aushort;
1117                 else
1118                     cuv += aushort;
1119             }
1120             break;
1121 #else
1122             /* Fallhrough! */
1123 #endif
1124         case 'v':
1125         case 'n':
1126         case 'S':
1127             along = (strend - s) / SIZE16;
1128             if (len > along)
1129                 len = along;
1130             if (!checksum) {
1131                 if (len && unpack_only_one)
1132                     len = 1;
1133                 EXTEND(SP, len);
1134                 EXTEND_MORTAL(len);
1135             }
1136             while (len-- > 0) {
1137                 COPY16(s, &au16);
1138                 DO_BO_UNPACK(au16, 16);
1139                 s += SIZE16;
1140 #ifdef HAS_NTOHS
1141                 if (datumtype == 'n')
1142                     au16 = PerlSock_ntohs(au16);
1143 #endif
1144 #ifdef HAS_VTOHS
1145                 if (datumtype == 'v')
1146                     au16 = vtohs(au16);
1147 #endif
1148                 if (!checksum) {
1149                     sv = NEWSV(39, 0);
1150                     sv_setiv(sv, (UV)au16);
1151                     PUSHs(sv_2mortal(sv));
1152                 }
1153                 else if (checksum > bits_in_uv)
1154                     cdouble += (NV)au16;
1155                 else
1156                     cuv += au16;
1157             }
1158             break;
1159         case 'v' | TYPE_IS_SHRIEKING:
1160         case 'n' | TYPE_IS_SHRIEKING:
1161             along = (strend - s) / SIZE16;
1162             if (len > along)
1163                 len = along;
1164             if (!checksum) {
1165                 if (len && unpack_only_one)
1166                     len = 1;
1167                 EXTEND(SP, len);
1168                 EXTEND_MORTAL(len);
1169             }
1170             while (len-- > 0) {
1171                 COPY16(s, &ai16);
1172                 s += SIZE16;
1173 #ifdef HAS_NTOHS
1174                 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1175                     ai16 = (I16)PerlSock_ntohs((U16)ai16);
1176 #endif
1177 #ifdef HAS_VTOHS
1178                 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1179                     ai16 = (I16)vtohs((U16)ai16);
1180 #endif
1181                 if (!checksum) {
1182                     sv = NEWSV(39, 0);
1183                     sv_setiv(sv, (IV)ai16);
1184                     PUSHs(sv_2mortal(sv));
1185                 }
1186                 else if (checksum > bits_in_uv)
1187                     cdouble += (NV)ai16;
1188                 else
1189                     cuv += ai16;
1190             }
1191             break;
1192         case 'i':
1193         case 'i' | TYPE_IS_SHRIEKING:
1194             along = (strend - s) / sizeof(int);
1195             if (len > along)
1196                 len = along;
1197             if (!checksum) {
1198                 if (len && unpack_only_one)
1199                     len = 1;
1200                 EXTEND(SP, len);
1201                 EXTEND_MORTAL(len);
1202             }
1203             while (len-- > 0) {
1204                 Copy(s, &aint, 1, int);
1205                 DO_BO_UNPACK(aint, i);
1206                 s += sizeof(int);
1207                 if (!checksum) {
1208                     sv = NEWSV(40, 0);
1209 #ifdef __osf__
1210                     /* Without the dummy below unpack("i", pack("i",-1))
1211                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1212                      * cc with optimization turned on.
1213                      *
1214                      * The bug was detected in
1215                      * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1216                      * with optimization (-O4) turned on.
1217                      * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1218                      * does not have this problem even with -O4.
1219                      *
1220                      * This bug was reported as DECC_BUGS 1431
1221                      * and tracked internally as GEM_BUGS 7775.
1222                      *
1223                      * The bug is fixed in
1224                      * Tru64 UNIX V5.0:      Compaq C V6.1-006 or later
1225                      * UNIX V4.0F support:   DEC C V5.9-006 or later
1226                      * UNIX V4.0E support:   DEC C V5.8-011 or later
1227                      * and also in DTK.
1228                      *
1229                      * See also few lines later for the same bug.
1230                      */
1231                     (aint) ?
1232                         sv_setiv(sv, (IV)aint) :
1233 #endif
1234                         sv_setiv(sv, (IV)aint);
1235                     PUSHs(sv_2mortal(sv));
1236                 }
1237                 else if (checksum > bits_in_uv)
1238                     cdouble += (NV)aint;
1239                 else
1240                     cuv += aint;
1241             }
1242             break;
1243         case 'I':
1244         case 'I' | TYPE_IS_SHRIEKING:
1245             along = (strend - s) / sizeof(unsigned int);
1246             if (len > along)
1247                 len = along;
1248             if (!checksum) {
1249                 if (len && unpack_only_one)
1250                     len = 1;
1251                 EXTEND(SP, len);
1252                 EXTEND_MORTAL(len);
1253             }
1254             while (len-- > 0) {
1255                 Copy(s, &auint, 1, unsigned int);
1256                 DO_BO_UNPACK(auint, i);
1257                 s += sizeof(unsigned int);
1258                 if (!checksum) {
1259                     sv = NEWSV(41, 0);
1260 #ifdef __osf__
1261                     /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1262                      * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1263                      * See details few lines earlier. */
1264                     (auint) ?
1265                         sv_setuv(sv, (UV)auint) :
1266 #endif
1267                     sv_setuv(sv, (UV)auint);
1268                     PUSHs(sv_2mortal(sv));
1269                 }
1270                 else if (checksum > bits_in_uv)
1271                     cdouble += (NV)auint;
1272                 else
1273                     cuv += auint;
1274             }
1275             break;
1276         case 'j':
1277             along = (strend - s) / IVSIZE;
1278             if (len > along)
1279                 len = along;
1280             if (!checksum) {
1281                 if (len && unpack_only_one)
1282                     len = 1;
1283                 EXTEND(SP, len);
1284                 EXTEND_MORTAL(len);
1285             }
1286             while (len-- > 0) {
1287                 Copy(s, &aiv, 1, IV);
1288 #if IVSIZE == INTSIZE
1289                 DO_BO_UNPACK(aiv, i);
1290 #elif IVSIZE == LONGSIZE
1291                 DO_BO_UNPACK(aiv, l);
1292 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1293                 DO_BO_UNPACK(aiv, 64);
1294 #endif
1295                 s += IVSIZE;
1296                 if (!checksum) {
1297                     sv = NEWSV(40, 0);
1298                     sv_setiv(sv, aiv);
1299                     PUSHs(sv_2mortal(sv));
1300                 }
1301                 else if (checksum > bits_in_uv)
1302                     cdouble += (NV)aiv;
1303                 else
1304                     cuv += aiv;
1305             }
1306             break;
1307         case 'J':
1308             along = (strend - s) / UVSIZE;
1309             if (len > along)
1310                 len = along;
1311             if (!checksum) {
1312                 if (len && unpack_only_one)
1313                     len = 1;
1314                 EXTEND(SP, len);
1315                 EXTEND_MORTAL(len);
1316             }
1317             while (len-- > 0) {
1318                 Copy(s, &auv, 1, UV);
1319 #if UVSIZE == INTSIZE
1320                 DO_BO_UNPACK(auv, i);
1321 #elif UVSIZE == LONGSIZE
1322                 DO_BO_UNPACK(auv, l);
1323 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1324                 DO_BO_UNPACK(auv, 64);
1325 #endif
1326                 s += UVSIZE;
1327                 if (!checksum) {
1328                     sv = NEWSV(41, 0);
1329                     sv_setuv(sv, auv);
1330                     PUSHs(sv_2mortal(sv));
1331                 }
1332                 else if (checksum > bits_in_uv)
1333                     cdouble += (NV)auv;
1334                 else
1335                     cuv += auv;
1336             }
1337             break;
1338         case 'l' | TYPE_IS_SHRIEKING:
1339 #if LONGSIZE != SIZE32
1340             along = (strend - s) / sizeof(long);
1341             if (len > along)
1342                 len = along;
1343             if (!checksum) {
1344                 if (len && unpack_only_one)
1345                     len = 1;
1346                 EXTEND(SP, len);
1347                 EXTEND_MORTAL(len);
1348             }
1349             while (len-- > 0) {
1350                 COPYNN(s, &along, sizeof(long));
1351                 DO_BO_UNPACK(along, l);
1352                 s += sizeof(long);
1353                 if (!checksum) {
1354                     sv = NEWSV(42, 0);
1355                     sv_setiv(sv, (IV)along);
1356                     PUSHs(sv_2mortal(sv));
1357                 }
1358                 else if (checksum > bits_in_uv)
1359                     cdouble += (NV)along;
1360                 else
1361                     cuv += along;
1362             }
1363             break;
1364 #else
1365             /* Fallthrough! */
1366 #endif
1367         case 'l':
1368             along = (strend - s) / SIZE32;
1369             if (len > along)
1370                 len = along;
1371             if (!checksum) {
1372                 if (len && unpack_only_one)
1373                     len = 1;
1374                 EXTEND(SP, len);
1375                 EXTEND_MORTAL(len);
1376             }
1377             while (len-- > 0) {
1378                 COPY32(s, &ai32);
1379                 DO_BO_UNPACK(ai32, 32);
1380 #if U32SIZE > SIZE32
1381                 if (ai32 > 2147483647)
1382                     ai32 -= 4294967296;
1383 #endif
1384                 s += SIZE32;
1385                 if (!checksum) {
1386                     sv = NEWSV(42, 0);
1387                     sv_setiv(sv, (IV)ai32);
1388                     PUSHs(sv_2mortal(sv));
1389                 }
1390                 else if (checksum > bits_in_uv)
1391                     cdouble += (NV)ai32;
1392                 else
1393                     cuv += ai32;
1394             }
1395             break;
1396         case 'L' | TYPE_IS_SHRIEKING:
1397 #if LONGSIZE != SIZE32
1398             along = (strend - s) / sizeof(unsigned long);
1399             if (len > along)
1400                 len = along;
1401             if (!checksum) {
1402                 if (len && unpack_only_one)
1403                     len = 1;
1404                 EXTEND(SP, len);
1405                 EXTEND_MORTAL(len);
1406             }
1407             while (len-- > 0) {
1408                 COPYNN(s, &aulong, sizeof(unsigned long));
1409                 DO_BO_UNPACK(aulong, l);
1410                 s += sizeof(unsigned long);
1411                 if (!checksum) {
1412                     sv = NEWSV(43, 0);
1413                     sv_setuv(sv, (UV)aulong);
1414                     PUSHs(sv_2mortal(sv));
1415                 }
1416                 else if (checksum > bits_in_uv)
1417                     cdouble += (NV)aulong;
1418                 else
1419                     cuv += aulong;
1420             }
1421             break;
1422 #else
1423             /* Fall through! */
1424 #endif
1425         case 'V':
1426         case 'N':
1427         case 'L':
1428             along = (strend - s) / SIZE32;
1429             if (len > along)
1430                 len = along;
1431             if (!checksum) {
1432                 if (len && unpack_only_one)
1433                     len = 1;
1434                 EXTEND(SP, len);
1435                 EXTEND_MORTAL(len);
1436             }
1437             while (len-- > 0) {
1438                 COPY32(s, &au32);
1439                 DO_BO_UNPACK(au32, 32);
1440                 s += SIZE32;
1441 #ifdef HAS_NTOHL
1442                 if (datumtype == 'N')
1443                     au32 = PerlSock_ntohl(au32);
1444 #endif
1445 #ifdef HAS_VTOHL
1446                 if (datumtype == 'V')
1447                     au32 = vtohl(au32);
1448 #endif
1449                  if (!checksum) {
1450                      sv = NEWSV(43, 0);
1451                      sv_setuv(sv, (UV)au32);
1452                      PUSHs(sv_2mortal(sv));
1453                  }
1454                  else if (checksum > bits_in_uv)
1455                      cdouble += (NV)au32;
1456                  else
1457                      cuv += au32;
1458             }
1459             break;
1460         case 'V' | TYPE_IS_SHRIEKING:
1461         case 'N' | TYPE_IS_SHRIEKING:
1462             along = (strend - s) / SIZE32;
1463             if (len > along)
1464                 len = along;
1465             if (!checksum) {
1466                 if (len && unpack_only_one)
1467                     len = 1;
1468                 EXTEND(SP, len);
1469                 EXTEND_MORTAL(len);
1470             }
1471             while (len-- > 0) {
1472                 COPY32(s, &ai32);
1473                 s += SIZE32;
1474 #ifdef HAS_NTOHL
1475                 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1476                     ai32 = (I32)PerlSock_ntohl((U32)ai32);
1477 #endif
1478 #ifdef HAS_VTOHL
1479                 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1480                     ai32 = (I32)vtohl((U32)ai32);
1481 #endif
1482                 if (!checksum) {
1483                     sv = NEWSV(43, 0);
1484                     sv_setiv(sv, (IV)ai32);
1485                     PUSHs(sv_2mortal(sv));
1486                 }
1487                 else if (checksum > bits_in_uv)
1488                     cdouble += (NV)ai32;
1489                 else
1490                     cuv += ai32;
1491             }
1492             break;
1493         case 'p':
1494             along = (strend - s) / sizeof(char*);
1495             if (len > along)
1496                 len = along;
1497             EXTEND(SP, len);
1498             EXTEND_MORTAL(len);
1499             while (len-- > 0) {
1500                 if (sizeof(char*) > strend - s)
1501                     break;
1502                 else {
1503                     Copy(s, &aptr, 1, char*);
1504                     DO_BO_UNPACK_P(aptr);
1505                     s += sizeof(char*);
1506                 }
1507                 sv = NEWSV(44, 0);
1508                 if (aptr)
1509                     sv_setpv(sv, aptr);
1510                 PUSHs(sv_2mortal(sv));
1511             }
1512             break;
1513         case 'w':
1514             if (len && unpack_only_one)
1515                 len = 1;
1516             EXTEND(SP, len);
1517             EXTEND_MORTAL(len);
1518             {
1519                 UV auv = 0;
1520                 U32 bytes = 0;
1521                 
1522                 while ((len > 0) && (s < strend)) {
1523                     auv = (auv << 7) | (*s & 0x7f);
1524                     /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1525                     if ((U8)(*s++) < 0x80) {
1526                         bytes = 0;
1527                         sv = NEWSV(40, 0);
1528                         sv_setuv(sv, auv);
1529                         PUSHs(sv_2mortal(sv));
1530                         len--;
1531                         auv = 0;
1532                     }
1533                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
1534                         char *t;
1535                         STRLEN n_a;
1536
1537                         sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1538                         while (s < strend) {
1539                             sv = mul128(sv, (U8)(*s & 0x7f));
1540                             if (!(*s++ & 0x80)) {
1541                                 bytes = 0;
1542                                 break;
1543                             }
1544                         }
1545                         t = SvPV(sv, n_a);
1546                         while (*t == '0')
1547                             t++;
1548                         sv_chop(sv, t);
1549                         PUSHs(sv_2mortal(sv));
1550                         len--;
1551                         auv = 0;
1552                     }
1553                 }
1554                 if ((s >= strend) && bytes)
1555                     Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1556             }
1557             break;
1558         case 'P':
1559             if (symptr->howlen == e_star)
1560                 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1561             EXTEND(SP, 1);
1562             if (sizeof(char*) > strend - s)
1563                 break;
1564             else {
1565                 Copy(s, &aptr, 1, char*);
1566                 DO_BO_UNPACK_P(aptr);
1567                 s += sizeof(char*);
1568             }
1569             sv = NEWSV(44, 0);
1570             if (aptr)
1571                 sv_setpvn(sv, aptr, len);
1572             PUSHs(sv_2mortal(sv));
1573             break;
1574 #ifdef HAS_QUAD
1575         case 'q':
1576             along = (strend - s) / sizeof(Quad_t);
1577             if (len > along)
1578                 len = along;
1579             if (!checksum) {
1580                 if (len && unpack_only_one)
1581                     len = 1;
1582                 EXTEND(SP, len);
1583                 EXTEND_MORTAL(len);
1584             }
1585             while (len-- > 0) {
1586                 if (s + sizeof(Quad_t) > strend) {
1587                     /* Surely this should never happen? NWC  */
1588                     aquad = 0;
1589                 }
1590                 else {
1591                     Copy(s, &aquad, 1, Quad_t);
1592                     DO_BO_UNPACK(aquad, 64);
1593                     s += sizeof(Quad_t);
1594                 }
1595                 if (!checksum) {
1596                     sv = NEWSV(42, 0);
1597                     if (aquad >= IV_MIN && aquad <= IV_MAX)
1598                         sv_setiv(sv, (IV)aquad);
1599                     else
1600                         sv_setnv(sv, (NV)aquad);
1601                     PUSHs(sv_2mortal(sv));
1602                 }
1603                 else if (checksum > bits_in_uv)
1604                     cdouble += (NV)aquad;
1605                 else
1606                     cuv += aquad;
1607             }
1608             break;
1609         case 'Q':
1610             along = (strend - s) / sizeof(Uquad_t);
1611             if (len > along)
1612                 len = along;
1613             if (!checksum) {
1614                 if (len && unpack_only_one)
1615                     len = 1;
1616                 EXTEND(SP, len);
1617                 EXTEND_MORTAL(len);
1618             }
1619             while (len-- > 0) {
1620                 if (s + sizeof(Uquad_t) > strend)
1621                     auquad = 0;
1622                 else {
1623                     Copy(s, &auquad, 1, Uquad_t);
1624                     DO_BO_UNPACK(auquad, 64);
1625                     s += sizeof(Uquad_t);
1626                 }
1627                 if (!checksum) {
1628                     sv = NEWSV(43, 0);
1629                     if (auquad <= UV_MAX)
1630                         sv_setuv(sv, (UV)auquad);
1631                     else
1632                         sv_setnv(sv, (NV)auquad);
1633                     PUSHs(sv_2mortal(sv));
1634                 }
1635                 else if (checksum > bits_in_uv)
1636                     cdouble += (NV)auquad;
1637                 else
1638                     cuv += auquad;
1639             }
1640             break;
1641 #endif
1642         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1643         case 'f':
1644             along = (strend - s) / sizeof(float);
1645             if (len > along)
1646                 len = along;
1647             if (!checksum) {
1648                 if (len && unpack_only_one)
1649                     len = 1;
1650                 EXTEND(SP, len);
1651                 EXTEND_MORTAL(len);
1652             }
1653             while (len-- > 0) {
1654                 Copy(s, &afloat, 1, float);
1655                 DO_BO_UNPACK_N(afloat, float);
1656                 s += sizeof(float);
1657                 if (!checksum) {
1658                     sv = NEWSV(47, 0);
1659                     sv_setnv(sv, (NV)afloat);
1660                     PUSHs(sv_2mortal(sv));
1661                 }
1662                 else {
1663                     cdouble += afloat;
1664                 }
1665             }
1666             break;
1667         case 'd':
1668             along = (strend - s) / sizeof(double);
1669             if (len > along)
1670                 len = along;
1671             if (!checksum) {
1672                 if (len && unpack_only_one)
1673                     len = 1;
1674                 EXTEND(SP, len);
1675                 EXTEND_MORTAL(len);
1676             }
1677             while (len-- > 0) {
1678                 Copy(s, &adouble, 1, double);
1679                 DO_BO_UNPACK_N(adouble, double);
1680                 s += sizeof(double);
1681                 if (!checksum) {
1682                     sv = NEWSV(48, 0);
1683                     sv_setnv(sv, (NV)adouble);
1684                     PUSHs(sv_2mortal(sv));
1685                 }
1686                 else {
1687                     cdouble += adouble;
1688                 }
1689             }
1690             break;
1691         case 'F':
1692             along = (strend - s) / NVSIZE;
1693             if (len > along)
1694                 len = along;
1695             if (!checksum) {
1696                 if (len && unpack_only_one)
1697                     len = 1;
1698                 EXTEND(SP, len);
1699                 EXTEND_MORTAL(len);
1700             }
1701             while (len-- > 0) {
1702                 Copy(s, &anv, 1, NV);
1703                 DO_BO_UNPACK_N(anv, NV);
1704                 s += NVSIZE;
1705                 if (!checksum) {
1706                     sv = NEWSV(48, 0);
1707                     sv_setnv(sv, anv);
1708                     PUSHs(sv_2mortal(sv));
1709                 }
1710                 else {
1711                     cdouble += anv;
1712                 }
1713             }
1714             break;
1715 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1716         case 'D':
1717             along = (strend - s) / LONG_DOUBLESIZE;
1718             if (len > along)
1719                 len = along;
1720             if (!checksum) {
1721                 if (len && unpack_only_one)
1722                     len = 1;
1723                 EXTEND(SP, len);
1724                 EXTEND_MORTAL(len);
1725             }
1726             while (len-- > 0) {
1727                 Copy(s, &aldouble, 1, long double);
1728                 DO_BO_UNPACK_N(aldouble, long double);
1729                 s += LONG_DOUBLESIZE;
1730                 if (!checksum) {
1731                     sv = NEWSV(48, 0);
1732                     sv_setnv(sv, (NV)aldouble);
1733                     PUSHs(sv_2mortal(sv));
1734                 }
1735                 else {cdouble += aldouble;
1736                 }
1737             }
1738             break;
1739 #endif
1740         case 'u':
1741             /* MKS:
1742              * Initialise the decode mapping.  By using a table driven
1743              * algorithm, the code will be character-set independent
1744              * (and just as fast as doing character arithmetic)
1745              */
1746             if (PL_uudmap['M'] == 0) {
1747                 int i;
1748
1749                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1750                     PL_uudmap[(U8)PL_uuemap[i]] = i;
1751                 /*
1752                  * Because ' ' and '`' map to the same value,
1753                  * we need to decode them both the same.
1754                  */
1755                 PL_uudmap[' '] = 0;
1756             }
1757
1758             along = (strend - s) * 3 / 4;
1759             sv = NEWSV(42, along);
1760             if (along)
1761                 SvPOK_on(sv);
1762             while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1763                 I32 a, b, c, d;
1764                 char hunk[4];
1765
1766                 hunk[3] = '\0';
1767                 len = PL_uudmap[*(U8*)s++] & 077;
1768                 while (len > 0) {
1769                     if (s < strend && ISUUCHAR(*s))
1770                         a = PL_uudmap[*(U8*)s++] & 077;
1771                     else
1772                         a = 0;
1773                     if (s < strend && ISUUCHAR(*s))
1774                         b = PL_uudmap[*(U8*)s++] & 077;
1775                     else
1776                         b = 0;
1777                     if (s < strend && ISUUCHAR(*s))
1778                         c = PL_uudmap[*(U8*)s++] & 077;
1779                     else
1780                         c = 0;
1781                     if (s < strend && ISUUCHAR(*s))
1782                         d = PL_uudmap[*(U8*)s++] & 077;
1783                     else
1784                         d = 0;
1785                     hunk[0] = (char)((a << 2) | (b >> 4));
1786                     hunk[1] = (char)((b << 4) | (c >> 2));
1787                     hunk[2] = (char)((c << 6) | d);
1788                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1789                     len -= 3;
1790                 }
1791                 if (*s == '\n')
1792                     s++;
1793                 else    /* possible checksum byte */
1794                     if (s + 1 < strend && s[1] == '\n')
1795                         s += 2;
1796             }
1797             XPUSHs(sv_2mortal(sv));
1798             break;
1799         }
1800
1801         if (checksum) {
1802             sv = NEWSV(42, 0);
1803             if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1804               (checksum > bits_in_uv &&
1805                strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1806                 NV trouble;
1807
1808                 adouble = (NV) (1 << (checksum & 15));
1809                 while (checksum >= 16) {
1810                     checksum -= 16;
1811                     adouble *= 65536.0;
1812                 }
1813                 while (cdouble < 0.0)
1814                     cdouble += adouble;
1815                 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1816                 sv_setnv(sv, cdouble);
1817             }
1818             else {
1819                 if (checksum < bits_in_uv) {
1820                     UV mask = ((UV)1 << checksum) - 1;
1821                     cuv &= mask;
1822                 }
1823                 sv_setuv(sv, cuv);
1824             }
1825             XPUSHs(sv_2mortal(sv));
1826             checksum = 0;
1827         }
1828     
1829         if (symptr->flags & FLAG_SLASH){
1830             if (SP - PL_stack_base - start_sp_offset <= 0)
1831                 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1832             if( next_symbol(symptr) ){
1833               if( symptr->howlen == e_number )
1834                 Perl_croak(aTHX_ "Count after length/code in unpack" );
1835               if( beyond ){
1836                 /* ...end of char buffer then no decent length available */
1837                 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1838               } else {
1839                 /* take top of stack (hope it's numeric) */
1840                 len = POPi;
1841                 if( len < 0 )
1842                     Perl_croak(aTHX_ "Negative '/' count in unpack" );
1843               }
1844             } else {
1845                 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1846             }
1847             datumtype = symptr->code;
1848             goto redo_switch;
1849         }
1850     }
1851
1852     if (new_s)
1853         *new_s = s;
1854     PUTBACK;
1855     return SP - PL_stack_base - start_sp_offset;
1856 }
1857
1858 PP(pp_unpack)
1859 {
1860     dSP;
1861     dPOPPOPssrl;
1862     I32 gimme = GIMME_V;
1863     STRLEN llen;
1864     STRLEN rlen;
1865     register char *pat = SvPV(left, llen);
1866 #ifdef PACKED_IS_OCTETS
1867     /* Packed side is assumed to be octets - so force downgrade if it
1868        has been UTF-8 encoded by accident
1869      */
1870     register char *s = SvPVbyte(right, rlen);
1871 #else
1872     register char *s = SvPV(right, rlen);
1873 #endif
1874     char *strend = s + rlen;
1875     register char *patend = pat + llen;
1876     register I32 cnt;
1877
1878     PUTBACK;
1879     cnt = unpackstring(pat, patend, s, strend,
1880                      ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1881                      | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1882
1883     SPAGAIN;
1884     if ( !cnt && gimme == G_SCALAR )
1885        PUSHs(&PL_sv_undef);
1886     RETURN;
1887 }
1888
1889 STATIC void
1890 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1891 {
1892     char hunk[5];
1893
1894     *hunk = PL_uuemap[len];
1895     sv_catpvn(sv, hunk, 1);
1896     hunk[4] = '\0';
1897     while (len > 2) {
1898         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1899         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1900         hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1901         hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1902         sv_catpvn(sv, hunk, 4);
1903         s += 3;
1904         len -= 3;
1905     }
1906     if (len > 0) {
1907         char r = (len > 1 ? s[1] : '\0');
1908         hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1909         hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1910         hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1911         hunk[3] = PL_uuemap[0];
1912         sv_catpvn(sv, hunk, 4);
1913     }
1914     sv_catpvn(sv, "\n", 1);
1915 }
1916
1917 STATIC SV *
1918 S_is_an_int(pTHX_ char *s, STRLEN l)
1919 {
1920   STRLEN         n_a;
1921   SV             *result = newSVpvn(s, l);
1922   char           *result_c = SvPV(result, n_a); /* convenience */
1923   char           *out = result_c;
1924   bool            skip = 1;
1925   bool            ignore = 0;
1926
1927   while (*s) {
1928     switch (*s) {
1929     case ' ':
1930       break;
1931     case '+':
1932       if (!skip) {
1933         SvREFCNT_dec(result);
1934         return (NULL);
1935       }
1936       break;
1937     case '0':
1938     case '1':
1939     case '2':
1940     case '3':
1941     case '4':
1942     case '5':
1943     case '6':
1944     case '7':
1945     case '8':
1946     case '9':
1947       skip = 0;
1948       if (!ignore) {
1949         *(out++) = *s;
1950       }
1951       break;
1952     case '.':
1953       ignore = 1;
1954       break;
1955     default:
1956       SvREFCNT_dec(result);
1957       return (NULL);
1958     }
1959     s++;
1960   }
1961   *(out++) = '\0';
1962   SvCUR_set(result, out - result_c);
1963   return (result);
1964 }
1965
1966 /* pnum must be '\0' terminated */
1967 STATIC int
1968 S_div128(pTHX_ SV *pnum, bool *done)
1969 {
1970   STRLEN          len;
1971   char           *s = SvPV(pnum, len);
1972   int             m = 0;
1973   int             r = 0;
1974   char           *t = s;
1975
1976   *done = 1;
1977   while (*t) {
1978     int             i;
1979
1980     i = m * 10 + (*t - '0');
1981     m = i & 0x7F;
1982     r = (i >> 7);               /* r < 10 */
1983     if (r) {
1984       *done = 0;
1985     }
1986     *(t++) = '0' + r;
1987   }
1988   *(t++) = '\0';
1989   SvCUR_set(pnum, (STRLEN) (t - s));
1990   return (m);
1991 }
1992
1993
1994
1995 /*
1996 =for apidoc pack_cat
1997
1998 The engine implementing pack() Perl function. Note: parameters next_in_list and
1999 flags are not used. This call should not be used; use packlist instead.
2000
2001 =cut */
2002
2003
2004 void
2005 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2006 {
2007     tempsym_t sym = { 0 };
2008     sym.patptr = pat;
2009     sym.patend = patend;
2010     sym.flags  = FLAG_PACK;
2011
2012     (void)pack_rec( cat, &sym, beglist, endlist );
2013 }
2014
2015
2016 /*
2017 =for apidoc packlist
2018
2019 The engine implementing pack() Perl function.
2020
2021 =cut */
2022
2023
2024 void
2025 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2026 {
2027     tempsym_t sym = { 0 };
2028     sym.patptr = pat;
2029     sym.patend = patend;
2030     sym.flags  = FLAG_PACK;
2031
2032     (void)pack_rec( cat, &sym, beglist, endlist );
2033 }
2034
2035
2036 STATIC
2037 SV **
2038 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
2039 {
2040     register I32 items;
2041     STRLEN fromlen;
2042     register I32 len = 0;
2043     SV *fromstr;
2044     /*SUPPRESS 442*/
2045     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2046     static char *space10 = "          ";
2047     bool found;
2048
2049     /* These must not be in registers: */
2050     char achar;
2051     I16 ai16;
2052     U16 au16;
2053     I32 ai32;
2054     U32 au32;
2055 #ifdef HAS_QUAD
2056     Quad_t aquad;
2057     Uquad_t auquad;
2058 #endif
2059 #if SHORTSIZE != SIZE16
2060     short ashort;
2061     unsigned short aushort;
2062 #endif
2063     int aint;
2064     unsigned int auint;
2065 #if LONGSIZE != SIZE32
2066     long along;
2067     unsigned long aulong;
2068 #endif
2069     char *aptr;
2070     float afloat;
2071     double adouble;
2072 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2073     long double aldouble;
2074 #endif
2075     IV aiv;
2076     UV auv;
2077     NV anv;
2078
2079     int strrelbeg = SvCUR(cat);
2080     tempsym_t lookahead;
2081
2082     items = endlist - beglist;
2083     found = next_symbol( symptr );
2084
2085 #ifndef PACKED_IS_OCTETS
2086     if (symptr->level == 0 && found && symptr->code == 'U' ){
2087         SvUTF8_on(cat);
2088     }
2089 #endif
2090
2091     while (found) {
2092         SV *lengthcode = Nullsv;
2093 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2094
2095         I32 datumtype = symptr->code;
2096         howlen_t howlen;
2097
2098         switch( howlen = symptr->howlen ){
2099         case e_no_len:
2100         case e_number:
2101             len = symptr->length;
2102             break;
2103         case e_star:
2104             len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items; 
2105             break;
2106         }
2107
2108         /* Look ahead for next symbol. Do we have code/code? */
2109         lookahead = *symptr;
2110         found = next_symbol(&lookahead);
2111         if ( symptr->flags & FLAG_SLASH ) {
2112             if (found){
2113                 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2114                      e_star != lookahead.howlen )
2115                     Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2116                 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2117                                                    ? *beglist : &PL_sv_no)
2118                                            + (lookahead.code == 'Z' ? 1 : 0)));
2119             } else {
2120                 Perl_croak(aTHX_ "Code missing after '/' in pack");
2121             }
2122         }
2123
2124         switch(TYPE_NO_ENDIANNESS(datumtype)) {
2125         default:
2126             Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2127         case '%':
2128             Perl_croak(aTHX_ "'%%' may not be used in pack");
2129         case '@':
2130             len += strrelbeg - SvCUR(cat);
2131             if (len > 0)
2132                 goto grow;
2133             len = -len;
2134             if (len > 0)
2135                 goto shrink;
2136             break;
2137         case '(':
2138         {
2139             tempsym_t savsym = *symptr;
2140             U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2141             symptr->flags |= group_modifiers;
2142             symptr->patend = savsym.grpend;
2143             symptr->level++;
2144             while (len--) {
2145                 symptr->patptr = savsym.grpbeg;
2146                 beglist = pack_rec(cat, symptr, beglist, endlist );
2147                 if (savsym.howlen == e_star && beglist == endlist)
2148                     break;              /* No way to continue */
2149             }
2150             symptr->flags &= ~group_modifiers;
2151             lookahead.flags = symptr->flags;
2152             *symptr = savsym;
2153             break;
2154         }
2155         case 'X' | TYPE_IS_SHRIEKING:
2156             if (!len)                   /* Avoid division by 0 */
2157                 len = 1;
2158             len = (SvCUR(cat)) % len;
2159             /* FALL THROUGH */
2160         case 'X':
2161           shrink:
2162             if ((I32)SvCUR(cat) < len)
2163                 Perl_croak(aTHX_ "'X' outside of string in pack");
2164             SvCUR(cat) -= len;
2165             *SvEND(cat) = '\0';
2166             break;
2167         case 'x' | TYPE_IS_SHRIEKING:
2168             if (!len)                   /* Avoid division by 0 */
2169                 len = 1;
2170             aint = (SvCUR(cat)) % len;
2171             if (aint)                   /* Other portable ways? */
2172                 len = len - aint;
2173             else
2174                 len = 0;
2175             /* FALL THROUGH */
2176
2177         case 'x':
2178           grow:
2179             while (len >= 10) {
2180                 sv_catpvn(cat, null10, 10);
2181                 len -= 10;
2182             }
2183             sv_catpvn(cat, null10, len);
2184             break;
2185         case 'A':
2186         case 'Z':
2187         case 'a':
2188             fromstr = NEXTFROM;
2189             aptr = SvPV(fromstr, fromlen);
2190             if (howlen == e_star) {   
2191                 len = fromlen;
2192                 if (datumtype == 'Z')
2193                     ++len;
2194             }
2195             if ((I32)fromlen >= len) {
2196                 sv_catpvn(cat, aptr, len);
2197                 if (datumtype == 'Z')
2198                     *(SvEND(cat)-1) = '\0';
2199             }
2200             else {
2201                 sv_catpvn(cat, aptr, fromlen);
2202                 len -= fromlen;
2203                 if (datumtype == 'A') {
2204                     while (len >= 10) {
2205                         sv_catpvn(cat, space10, 10);
2206                         len -= 10;
2207                     }
2208                     sv_catpvn(cat, space10, len);
2209                 }
2210                 else {
2211                     while (len >= 10) {
2212                         sv_catpvn(cat, null10, 10);
2213                         len -= 10;
2214                     }
2215                     sv_catpvn(cat, null10, len);
2216                 }
2217             }
2218             break;
2219         case 'B':
2220         case 'b':
2221             {
2222                 register char *str;
2223                 I32 saveitems;
2224
2225                 fromstr = NEXTFROM;
2226                 saveitems = items;
2227                 str = SvPV(fromstr, fromlen);
2228                 if (howlen == e_star)
2229                     len = fromlen;
2230                 aint = SvCUR(cat);
2231                 SvCUR(cat) += (len+7)/8;
2232                 SvGROW(cat, SvCUR(cat) + 1);
2233                 aptr = SvPVX(cat) + aint;
2234                 if (len > (I32)fromlen)
2235                     len = fromlen;
2236                 aint = len;
2237                 items = 0;
2238                 if (datumtype == 'B') {
2239                     for (len = 0; len++ < aint;) {
2240                         items |= *str++ & 1;
2241                         if (len & 7)
2242                             items <<= 1;
2243                         else {
2244                             *aptr++ = items & 0xff;
2245                             items = 0;
2246                         }
2247                     }
2248                 }
2249                 else {
2250                     for (len = 0; len++ < aint;) {
2251                         if (*str++ & 1)
2252                             items |= 128;
2253                         if (len & 7)
2254                             items >>= 1;
2255                         else {
2256                             *aptr++ = items & 0xff;
2257                             items = 0;
2258                         }
2259                     }
2260                 }
2261                 if (aint & 7) {
2262                     if (datumtype == 'B')
2263                         items <<= 7 - (aint & 7);
2264                     else
2265                         items >>= 7 - (aint & 7);
2266                     *aptr++ = items & 0xff;
2267                 }
2268                 str = SvPVX(cat) + SvCUR(cat);
2269                 while (aptr <= str)
2270                     *aptr++ = '\0';
2271
2272                 items = saveitems;
2273             }
2274             break;
2275         case 'H':
2276         case 'h':
2277             {
2278                 register char *str;
2279                 I32 saveitems;
2280
2281                 fromstr = NEXTFROM;
2282                 saveitems = items;
2283                 str = SvPV(fromstr, fromlen);
2284                 if (howlen == e_star)
2285                     len = fromlen;
2286                 aint = SvCUR(cat);
2287                 SvCUR(cat) += (len+1)/2;
2288                 SvGROW(cat, SvCUR(cat) + 1);
2289                 aptr = SvPVX(cat) + aint;
2290                 if (len > (I32)fromlen)
2291                     len = fromlen;
2292                 aint = len;
2293                 items = 0;
2294                 if (datumtype == 'H') {
2295                     for (len = 0; len++ < aint;) {
2296                         if (isALPHA(*str))
2297                             items |= ((*str++ & 15) + 9) & 15;
2298                         else
2299                             items |= *str++ & 15;
2300                         if (len & 1)
2301                             items <<= 4;
2302                         else {
2303                             *aptr++ = items & 0xff;
2304                             items = 0;
2305                         }
2306                     }
2307                 }
2308                 else {
2309                     for (len = 0; len++ < aint;) {
2310                         if (isALPHA(*str))
2311                             items |= (((*str++ & 15) + 9) & 15) << 4;
2312                         else
2313                             items |= (*str++ & 15) << 4;
2314                         if (len & 1)
2315                             items >>= 4;
2316                         else {
2317                             *aptr++ = items & 0xff;
2318                             items = 0;
2319                         }
2320                     }
2321                 }
2322                 if (aint & 1)
2323                     *aptr++ = items & 0xff;
2324                 str = SvPVX(cat) + SvCUR(cat);
2325                 while (aptr <= str)
2326                     *aptr++ = '\0';
2327
2328                 items = saveitems;
2329             }
2330             break;
2331         case 'C':
2332         case 'c':
2333             while (len-- > 0) {
2334                 fromstr = NEXTFROM;
2335                 switch (TYPE_NO_MODIFIERS(datumtype)) {
2336                 case 'C':
2337                     aint = SvIV(fromstr);
2338                     if ((aint < 0 || aint > 255) &&
2339                         ckWARN(WARN_PACK))
2340                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2341                                     "Character in 'C' format wrapped in pack");
2342                     achar = aint & 255;
2343                     sv_catpvn(cat, &achar, sizeof(char));
2344                     break;
2345                 case 'c':
2346                     aint = SvIV(fromstr);
2347                     if ((aint < -128 || aint > 127) &&
2348                         ckWARN(WARN_PACK))
2349                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2350                                     "Character in 'c' format wrapped in pack" );
2351                     achar = aint & 255;
2352                     sv_catpvn(cat, &achar, sizeof(char));
2353                     break;
2354                 }
2355             }
2356             break;
2357         case 'U':
2358             while (len-- > 0) {
2359                 fromstr = NEXTFROM;
2360                 auint = UNI_TO_NATIVE(SvUV(fromstr));
2361                 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2362                 SvCUR_set(cat,
2363                           (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2364                                                      auint,
2365                                                      ckWARN(WARN_UTF8) ?
2366                                                      0 : UNICODE_ALLOW_ANY)
2367                           - SvPVX(cat));
2368             }
2369             *SvEND(cat) = '\0';
2370             break;
2371         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
2372         case 'f':
2373             while (len-- > 0) {
2374                 fromstr = NEXTFROM;
2375 #ifdef __VOS__
2376 /* VOS does not automatically map a floating-point overflow
2377    during conversion from double to float into infinity, so we
2378    do it by hand.  This code should either be generalized for
2379    any OS that needs it, or removed if and when VOS implements
2380    posix-976 (suggestion to support mapping to infinity).
2381    Paul.Green@stratus.com 02-04-02.  */
2382                 if (SvNV(fromstr) > FLT_MAX)
2383                      afloat = _float_constants[0];   /* single prec. inf. */
2384                 else if (SvNV(fromstr) < -FLT_MAX)
2385                      afloat = _float_constants[0];   /* single prec. inf. */
2386                 else afloat = (float)SvNV(fromstr);
2387 #else
2388 # if defined(VMS) && !defined(__IEEE_FP)
2389 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2390  * on Alpha; fake it if we don't have them.
2391  */
2392                 if (SvNV(fromstr) > FLT_MAX)
2393                      afloat = FLT_MAX;
2394                 else if (SvNV(fromstr) < -FLT_MAX)
2395                      afloat = -FLT_MAX;
2396                 else afloat = (float)SvNV(fromstr);
2397 # else
2398                 afloat = (float)SvNV(fromstr);
2399 # endif
2400 #endif
2401                 DO_BO_PACK_N(afloat, float);
2402                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2403             }
2404             break;
2405         case 'd':
2406             while (len-- > 0) {
2407                 fromstr = NEXTFROM;
2408 #ifdef __VOS__
2409 /* VOS does not automatically map a floating-point overflow
2410    during conversion from long double to double into infinity,
2411    so we do it by hand.  This code should either be generalized
2412    for any OS that needs it, or removed if and when VOS
2413    implements posix-976 (suggestion to support mapping to
2414    infinity).  Paul.Green@stratus.com 02-04-02.  */
2415                 if (SvNV(fromstr) > DBL_MAX)
2416                      adouble = _double_constants[0];   /* double prec. inf. */
2417                 else if (SvNV(fromstr) < -DBL_MAX)
2418                      adouble = _double_constants[0];   /* double prec. inf. */
2419                 else adouble = (double)SvNV(fromstr);
2420 #else
2421 # if defined(VMS) && !defined(__IEEE_FP)
2422 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2423  * on Alpha; fake it if we don't have them.
2424  */
2425                 if (SvNV(fromstr) > DBL_MAX)
2426                      adouble = DBL_MAX;
2427                 else if (SvNV(fromstr) < -DBL_MAX)
2428                      adouble = -DBL_MAX;
2429                 else adouble = (double)SvNV(fromstr);
2430 # else
2431                 adouble = (double)SvNV(fromstr);
2432 # endif
2433 #endif
2434                 DO_BO_PACK_N(adouble, double);
2435                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2436             }
2437             break;
2438         case 'F':
2439             Zero(&anv, 1, NV); /* can be long double with unused bits */
2440             while (len-- > 0) {
2441                 fromstr = NEXTFROM;
2442                 anv = SvNV(fromstr);
2443                 DO_BO_PACK_N(anv, NV);
2444                 sv_catpvn(cat, (char *)&anv, NVSIZE);
2445             }
2446             break;
2447 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2448         case 'D':
2449             /* long doubles can have unused bits, which may be nonzero */
2450             Zero(&aldouble, 1, long double);
2451             while (len-- > 0) {
2452                 fromstr = NEXTFROM;
2453                 aldouble = (long double)SvNV(fromstr);
2454                 DO_BO_PACK_N(aldouble, long double);
2455                 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2456             }
2457             break;
2458 #endif
2459         case 'n' | TYPE_IS_SHRIEKING:
2460         case 'n':
2461             while (len-- > 0) {
2462                 fromstr = NEXTFROM;
2463                 ai16 = (I16)SvIV(fromstr);
2464 #ifdef HAS_HTONS
2465                 ai16 = PerlSock_htons(ai16);
2466 #endif
2467                 CAT16(cat, &ai16);
2468             }
2469             break;
2470         case 'v' | TYPE_IS_SHRIEKING:
2471         case 'v':
2472             while (len-- > 0) {
2473                 fromstr = NEXTFROM;
2474                 ai16 = (I16)SvIV(fromstr);
2475 #ifdef HAS_HTOVS
2476                 ai16 = htovs(ai16);
2477 #endif
2478                 CAT16(cat, &ai16);
2479             }
2480             break;
2481         case 'S' | TYPE_IS_SHRIEKING:
2482 #if SHORTSIZE != SIZE16
2483             {
2484                 while (len-- > 0) {
2485                     fromstr = NEXTFROM;
2486                     aushort = SvUV(fromstr);
2487                     DO_BO_PACK(aushort, s);
2488                     sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2489                 }
2490             }
2491             break;
2492 #else
2493             /* Fall through! */
2494 #endif
2495         case 'S':
2496             {
2497                 while (len-- > 0) {
2498                     fromstr = NEXTFROM;
2499                     au16 = (U16)SvUV(fromstr);
2500                     DO_BO_PACK(au16, 16);
2501                     CAT16(cat, &au16);
2502                 }
2503
2504             }
2505             break;
2506         case 's' | TYPE_IS_SHRIEKING:
2507 #if SHORTSIZE != SIZE16
2508             {
2509                 while (len-- > 0) {
2510                     fromstr = NEXTFROM;
2511                     ashort = SvIV(fromstr);
2512                     DO_BO_PACK(ashort, s);
2513                     sv_catpvn(cat, (char *)&ashort, sizeof(short));
2514                 }
2515             }
2516             break;
2517 #else
2518             /* Fall through! */
2519 #endif
2520         case 's':
2521             while (len-- > 0) {
2522                 fromstr = NEXTFROM;
2523                 ai16 = (I16)SvIV(fromstr);
2524                 DO_BO_PACK(ai16, 16);
2525                 CAT16(cat, &ai16);
2526             }
2527             break;
2528         case 'I':
2529         case 'I' | TYPE_IS_SHRIEKING:
2530             while (len-- > 0) {
2531                 fromstr = NEXTFROM;
2532                 auint = SvUV(fromstr);
2533                 DO_BO_PACK(auint, i);
2534                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2535             }
2536             break;
2537         case 'j':
2538             while (len-- > 0) {
2539                 fromstr = NEXTFROM;
2540                 aiv = SvIV(fromstr);
2541 #if IVSIZE == INTSIZE
2542                 DO_BO_PACK(aiv, i);
2543 #elif IVSIZE == LONGSIZE
2544                 DO_BO_PACK(aiv, l);
2545 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2546                 DO_BO_PACK(aiv, 64);
2547 #endif
2548                 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2549             }
2550             break;
2551         case 'J':
2552             while (len-- > 0) {
2553                 fromstr = NEXTFROM;
2554                 auv = SvUV(fromstr);
2555 #if UVSIZE == INTSIZE
2556                 DO_BO_PACK(auv, i);
2557 #elif UVSIZE == LONGSIZE
2558                 DO_BO_PACK(auv, l);
2559 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2560                 DO_BO_PACK(auv, 64);
2561 #endif
2562                 sv_catpvn(cat, (char*)&auv, UVSIZE);
2563             }
2564             break;
2565         case 'w':
2566             while (len-- > 0) {
2567                 fromstr = NEXTFROM;
2568                 anv = SvNV(fromstr);
2569
2570                 if (anv < 0)
2571                     Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2572
2573                 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2574                    which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2575                    any negative IVs will have already been got by the croak()
2576                    above. IOK is untrue for fractions, so we test them
2577                    against UV_MAX_P1.  */
2578                 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2579                 {
2580                     char   buf[(sizeof(UV)*8)/7+1];
2581                     char  *in = buf + sizeof(buf);
2582                     UV     auv = SvUV(fromstr);
2583
2584                     do {
2585                         *--in = (char)((auv & 0x7f) | 0x80);
2586                         auv >>= 7;
2587                     } while (auv);
2588                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2589                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2590                 }
2591                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
2592                     char           *from, *result, *in;
2593                     SV             *norm;
2594                     STRLEN          len;
2595                     bool            done;
2596
2597                     /* Copy string and check for compliance */
2598                     from = SvPV(fromstr, len);
2599                     if ((norm = is_an_int(from, len)) == NULL)
2600                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2601
2602                     New('w', result, len, char);
2603                     in = result + len;
2604                     done = FALSE;
2605                     while (!done)
2606                         *--in = div128(norm, &done) | 0x80;
2607                     result[len - 1] &= 0x7F; /* clear continue bit */
2608                     sv_catpvn(cat, in, (result + len) - in);
2609                     Safefree(result);
2610                     SvREFCNT_dec(norm); /* free norm */
2611                 }
2612                 else if (SvNOKp(fromstr)) {
2613                     /* 10**NV_MAX_10_EXP is the largest power of 10
2614                        so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2615                        given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2616                        x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2617                        And with that many bytes only Inf can overflow.
2618                        Some C compilers are strict about integral constant
2619                        expressions so we conservatively divide by a slightly
2620                        smaller integer instead of multiplying by the exact
2621                        floating-point value.
2622                     */
2623 #ifdef NV_MAX_10_EXP
2624 /*                  char   buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2625                     char   buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2626 #else
2627 /*                  char   buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2628                     char   buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2629 #endif
2630                     char  *in = buf + sizeof(buf);
2631
2632                     anv = Perl_floor(anv);
2633                     do {
2634                         NV next = Perl_floor(anv / 128);
2635                         if (in <= buf)  /* this cannot happen ;-) */
2636                             Perl_croak(aTHX_ "Cannot compress integer in pack");
2637                         *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2638                         anv = next;
2639                     } while (anv > 0);
2640                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2641                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2642                 }
2643                 else {
2644                     char           *from, *result, *in;
2645                     SV             *norm;
2646                     STRLEN          len;
2647                     bool            done;
2648
2649                     /* Copy string and check for compliance */
2650                     from = SvPV(fromstr, len);
2651                     if ((norm = is_an_int(from, len)) == NULL)
2652                         Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2653
2654                     New('w', result, len, char);
2655                     in = result + len;
2656                     done = FALSE;
2657                     while (!done)
2658                         *--in = div128(norm, &done) | 0x80;
2659                     result[len - 1] &= 0x7F; /* clear continue bit */
2660                     sv_catpvn(cat, in, (result + len) - in);
2661                     Safefree(result);
2662                     SvREFCNT_dec(norm); /* free norm */
2663                }
2664             }
2665             break;
2666         case 'i':
2667         case 'i' | TYPE_IS_SHRIEKING:
2668             while (len-- > 0) {
2669                 fromstr = NEXTFROM;
2670                 aint = SvIV(fromstr);
2671                 DO_BO_PACK(aint, i);
2672                 sv_catpvn(cat, (char*)&aint, sizeof(int));
2673             }
2674             break;
2675         case 'N' | TYPE_IS_SHRIEKING:
2676         case 'N':
2677             while (len-- > 0) {
2678                 fromstr = NEXTFROM;
2679                 au32 = SvUV(fromstr);
2680 #ifdef HAS_HTONL
2681                 au32 = PerlSock_htonl(au32);
2682 #endif
2683                 CAT32(cat, &au32);
2684             }
2685             break;
2686         case 'V' | TYPE_IS_SHRIEKING:
2687         case 'V':
2688             while (len-- > 0) {
2689                 fromstr = NEXTFROM;
2690                 au32 = SvUV(fromstr);
2691 #ifdef HAS_HTOVL
2692                 au32 = htovl(au32);
2693 #endif
2694                 CAT32(cat, &au32);
2695             }
2696             break;
2697         case 'L' | TYPE_IS_SHRIEKING:
2698 #if LONGSIZE != SIZE32
2699             {
2700                 while (len-- > 0) {
2701                     fromstr = NEXTFROM;
2702                     aulong = SvUV(fromstr);
2703                     DO_BO_PACK(aulong, l);
2704                     sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2705                 }
2706             }
2707             break;
2708 #else
2709             /* Fall though! */
2710 #endif
2711         case 'L':
2712             {
2713                 while (len-- > 0) {
2714                     fromstr = NEXTFROM;
2715                     au32 = SvUV(fromstr);
2716                     DO_BO_PACK(au32, 32);
2717                     CAT32(cat, &au32);
2718                 }
2719             }
2720             break;
2721         case 'l' | TYPE_IS_SHRIEKING:
2722 #if LONGSIZE != SIZE32
2723             {
2724                 while (len-- > 0) {
2725                     fromstr = NEXTFROM;
2726                     along = SvIV(fromstr);
2727                     DO_BO_PACK(along, l);
2728                     sv_catpvn(cat, (char *)&along, sizeof(long));
2729                 }
2730             }
2731             break;
2732 #else
2733             /* Fall though! */
2734 #endif
2735         case 'l':
2736             while (len-- > 0) {
2737                 fromstr = NEXTFROM;
2738                 ai32 = SvIV(fromstr);
2739                 DO_BO_PACK(ai32, 32);
2740                 CAT32(cat, &ai32);
2741             }
2742             break;
2743 #ifdef HAS_QUAD
2744         case 'Q':
2745             while (len-- > 0) {
2746                 fromstr = NEXTFROM;
2747                 auquad = (Uquad_t)SvUV(fromstr);
2748                 DO_BO_PACK(auquad, 64);
2749                 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2750             }
2751             break;
2752         case 'q':
2753             while (len-- > 0) {
2754                 fromstr = NEXTFROM;
2755                 aquad = (Quad_t)SvIV(fromstr);
2756                 DO_BO_PACK(aquad, 64);
2757                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2758             }
2759             break;
2760 #endif
2761         case 'P':
2762             len = 1;            /* assume SV is correct length */
2763             /* Fall through! */
2764         case 'p':
2765             while (len-- > 0) {
2766                 fromstr = NEXTFROM;
2767                 if (fromstr == &PL_sv_undef)
2768                     aptr = NULL;
2769                 else {
2770                     STRLEN n_a;
2771                     /* XXX better yet, could spirit away the string to
2772                      * a safe spot and hang on to it until the result
2773                      * of pack() (and all copies of the result) are
2774                      * gone.
2775                      */
2776                     if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2777                                                 || (SvPADTMP(fromstr)
2778                                                     && !SvREADONLY(fromstr))))
2779                     {
2780                         Perl_warner(aTHX_ packWARN(WARN_PACK),
2781                                 "Attempt to pack pointer to temporary value");
2782                     }
2783                     if (SvPOK(fromstr) || SvNIOK(fromstr))
2784                         aptr = SvPV(fromstr,n_a);
2785                     else
2786                         aptr = SvPV_force(fromstr,n_a);
2787                 }
2788                 DO_BO_PACK_P(aptr);
2789                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2790             }
2791             break;
2792         case 'u':
2793             fromstr = NEXTFROM;
2794             aptr = SvPV(fromstr, fromlen);
2795             SvGROW(cat, fromlen * 4 / 3);
2796             if (len <= 2)
2797                 len = 45;
2798             else
2799                 len = len / 3 * 3;
2800             while (fromlen > 0) {
2801                 I32 todo;
2802
2803                 if ((I32)fromlen > len)
2804                     todo = len;
2805                 else
2806                     todo = fromlen;
2807                 doencodes(cat, aptr, todo);
2808                 fromlen -= todo;
2809                 aptr += todo;
2810             }
2811             break;
2812         }
2813         *symptr = lookahead;
2814     }
2815     return beglist;
2816 }
2817 #undef NEXTFROM
2818
2819
2820 PP(pp_pack)
2821 {
2822     dSP; dMARK; dORIGMARK; dTARGET;
2823     register SV *cat = TARG;
2824     STRLEN fromlen;
2825     register char *pat = SvPVx(*++MARK, fromlen);
2826     register char *patend = pat + fromlen;
2827
2828     MARK++;
2829     sv_setpvn(cat, "", 0);
2830
2831     packlist(cat, pat, patend, MARK, SP + 1);
2832
2833     SvSETMAGIC(cat);
2834     SP = ORIGMARK;
2835     PUSHs(cat);
2836     RETURN;
2837 }
2838
2839 /*
2840  * Local variables:
2841  * c-indentation-style: bsd
2842  * c-basic-offset: 4
2843  * indent-tabs-mode: t
2844  * End:
2845  *
2846  * vim: expandtab shiftwidth=4:
2847 */