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