source: vendor/perl/5.8.8/pp_pack.c

Last change on this file was 3181, checked in by bird, 18 years ago

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