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