3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
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.
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,
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.
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.
31 #define PERL_IN_PP_PACK_C
35 * Offset for integer pack/unpack.
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.
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.) --???
49 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
50 defines are now in config.h. --Andy Dougherty April 1998
55 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
58 #if U16SIZE > SIZE16 || U32SIZE > SIZE32
59 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
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)
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)
83 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */
84 #define MAX_SUB_TEMPLATE_LEVEL 100
86 /* flags (note that type modifiers can also be used as flags!) */
87 #define FLAG_UNPACK_ONLY_ONE 0x10
88 #define FLAG_UNPACK_DO_UTF8 0x08
89 #define FLAG_SLASH 0x04
90 #define FLAG_COMMA 0x02
91 #define FLAG_PACK 0x01
94 S_mul128(pTHX_ SV *sv, U8 m)
97 char *s = SvPV(sv, len);
101 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
102 SV *tmpNew = newSVpvn("0000000000", 10);
104 sv_catsv(tmpNew, sv);
105 SvREFCNT_dec(sv); /* free old sv */
110 while (!*t) /* trailing '\0'? */
113 i = ((*t - '0') << 7) + m;
114 *(t--) = '0' + (char)(i % 10);
120 /* Explosives and implosives. */
122 #if 'I' == 73 && 'J' == 74
123 /* On an ASCII/ISO kind of system */
124 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
127 Some other sort of character set - use memchr() so we don't match
130 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
134 #define TYPE_IS_SHRIEKING 0x100
135 #define TYPE_IS_BIG_ENDIAN 0x200
136 #define TYPE_IS_LITTLE_ENDIAN 0x400
137 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
138 #define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK)
139 #define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
140 #define TYPE_MODIFIERS(t) ((t) & ~0xFF)
141 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
143 #define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP("
145 #define DO_BO_UNPACK(var, type) \
147 switch (TYPE_ENDIANNESS(datumtype)) { \
148 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
149 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
154 #define DO_BO_PACK(var, type) \
156 switch (TYPE_ENDIANNESS(datumtype)) { \
157 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
158 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
163 #define DO_BO_UNPACK_PTR(var, type, pre_cast) \
165 switch (TYPE_ENDIANNESS(datumtype)) { \
166 case TYPE_IS_BIG_ENDIAN: \
167 var = (void *) my_betoh ## type ((pre_cast) var); \
169 case TYPE_IS_LITTLE_ENDIAN: \
170 var = (void *) my_letoh ## type ((pre_cast) var); \
177 #define DO_BO_PACK_PTR(var, type, pre_cast) \
179 switch (TYPE_ENDIANNESS(datumtype)) { \
180 case TYPE_IS_BIG_ENDIAN: \
181 var = (void *) my_htobe ## type ((pre_cast) var); \
183 case TYPE_IS_LITTLE_ENDIAN: \
184 var = (void *) my_htole ## type ((pre_cast) var); \
191 #define BO_CANT_DOIT(action, type) \
193 switch (TYPE_ENDIANNESS(datumtype)) { \
194 case TYPE_IS_BIG_ENDIAN: \
195 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
196 "platform", #action, #type); \
198 case TYPE_IS_LITTLE_ENDIAN: \
199 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
200 "platform", #action, #type); \
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)
214 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
215 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
218 #if defined(my_htolen) && defined(my_letohn) && \
219 defined(my_htoben) && defined(my_betohn)
220 # define DO_BO_UNPACK_N(var, type) \
222 switch (TYPE_ENDIANNESS(datumtype)) { \
223 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
224 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
229 # define DO_BO_PACK_N(var, type) \
231 switch (TYPE_ENDIANNESS(datumtype)) { \
232 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
233 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
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)
242 /* Returns the sizeof() struct described by pat */
244 S_measure_struct(pTHX_ register tempsym_t* symptr)
246 register I32 len = 0;
247 register I32 total = 0;
252 while (next_symbol(symptr)) {
254 switch( symptr->howlen ){
257 len = symptr->length;
260 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
261 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
265 /* endianness doesn't influence the size of a type */
266 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
268 Perl_croak(aTHX_ "Invalid type '%c' in %s",
269 (int)TYPE_NO_MODIFIERS(symptr->code),
270 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
273 case 'U': /* XXXX Is it correct? */
276 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
278 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
284 tempsym_t savsym = *symptr;
285 symptr->patptr = savsym.grpbeg;
286 symptr->patend = savsym.grpend;
287 /* XXXX Theoretically, we need to measure many times at different
288 positions, since the subexpression may contain
289 alignment commands, but be not of aligned length.
290 Need to detect this and croak(). */
291 size = measure_struct(symptr);
295 case 'X' | TYPE_IS_SHRIEKING:
296 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
297 if (!len) /* Avoid division by 0 */
299 len = total % len; /* Assumed: the start is aligned. */
304 Perl_croak(aTHX_ "'X' outside of string in %s",
305 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
307 case 'x' | TYPE_IS_SHRIEKING:
308 if (!len) /* Avoid division by 0 */
310 star = total % len; /* Assumed: the start is aligned. */
311 if (star) /* Other portable ways? */
334 case 's' | TYPE_IS_SHRIEKING:
335 #if SHORTSIZE != SIZE16
336 size = sizeof(short);
344 case 'S' | TYPE_IS_SHRIEKING:
345 #if SHORTSIZE != SIZE16
346 size = sizeof(unsigned short);
351 case 'v' | TYPE_IS_SHRIEKING:
352 case 'n' | TYPE_IS_SHRIEKING:
358 case 'i' | TYPE_IS_SHRIEKING:
362 case 'I' | TYPE_IS_SHRIEKING:
364 size = sizeof(unsigned int);
372 case 'l' | TYPE_IS_SHRIEKING:
373 #if LONGSIZE != SIZE32
382 case 'L' | TYPE_IS_SHRIEKING:
383 #if LONGSIZE != SIZE32
384 size = sizeof(unsigned long);
389 case 'V' | TYPE_IS_SHRIEKING:
390 case 'N' | TYPE_IS_SHRIEKING:
400 size = sizeof(char*);
404 size = sizeof(Quad_t);
407 size = sizeof(Uquad_t);
411 size = sizeof(float);
414 size = sizeof(double);
419 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
421 size = LONG_DOUBLESIZE;
431 /* locate matching closing parenthesis or bracket
432 * returns char pointer to char after match, or NULL
435 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
437 while (patptr < patend) {
445 while (patptr < patend && *patptr != '\n')
449 patptr = group_end(patptr, patend, ')') + 1;
451 patptr = group_end(patptr, patend, ']') + 1;
453 Perl_croak(aTHX_ "No group ending character '%c' found in template",
459 /* Convert unsigned decimal number to binary.
460 * Expects a pointer to the first digit and address of length variable
461 * Advances char pointer to 1st non-digit char and returns number
464 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
466 I32 len = *patptr++ - '0';
467 while (isDIGIT(*patptr)) {
468 if (len >= 0x7FFFFFFF/10)
469 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
470 len = (len * 10) + (*patptr++ - '0');
476 /* The marvellous template parsing routine: Using state stored in *symptr,
477 * locates next template code and count
480 S_next_symbol(pTHX_ register tempsym_t* symptr )
482 register char* patptr = symptr->patptr;
483 register char* patend = symptr->patend;
485 symptr->flags &= ~FLAG_SLASH;
487 while (patptr < patend) {
488 if (isSPACE(*patptr))
490 else if (*patptr == '#') {
492 while (patptr < patend && *patptr != '\n')
497 /* We should have found a template code */
498 I32 code = *patptr++ & 0xFF;
499 U32 inherited_modifiers = 0;
501 if (code == ','){ /* grandfather in commas but with a warning */
502 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
503 symptr->flags |= FLAG_COMMA;
504 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
505 "Invalid type ',' in %s",
506 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
511 /* for '(', skip to ')' */
513 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
514 Perl_croak(aTHX_ "()-group starts with a count in %s",
515 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
516 symptr->grpbeg = patptr;
517 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
518 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
519 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
520 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
523 /* look for group modifiers to inherit */
524 if (TYPE_ENDIANNESS(symptr->flags)) {
525 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code)))
526 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags);
529 /* look for modifiers */
530 while (patptr < patend) {
535 modifier = TYPE_IS_SHRIEKING;
536 allowed = "sSiIlLxXnNvV";
539 modifier = TYPE_IS_BIG_ENDIAN;
540 allowed = ENDIANNESS_ALLOWED_TYPES;
543 modifier = TYPE_IS_LITTLE_ENDIAN;
544 allowed = ENDIANNESS_ALLOWED_TYPES;
553 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
554 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
555 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
557 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK)
558 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
559 (int) TYPE_NO_MODIFIERS(code),
560 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
561 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) ==
562 TYPE_ENDIANNESS_MASK)
563 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s",
564 *patptr, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
566 if (ckWARN(WARN_UNPACK)) {
568 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
569 "Duplicate modifier '%c' after '%c' in %s",
570 *patptr, (int) TYPE_NO_MODIFIERS(code),
571 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
578 /* inherit modifiers */
579 code |= inherited_modifiers;
581 /* look for count and/or / */
582 if (patptr < patend) {
583 if (isDIGIT(*patptr)) {
584 patptr = get_num( patptr, &symptr->length );
585 symptr->howlen = e_number;
587 } else if (*patptr == '*') {
589 symptr->howlen = e_star;
591 } else if (*patptr == '[') {
592 char* lenptr = ++patptr;
593 symptr->howlen = e_number;
594 patptr = group_end( patptr, patend, ']' ) + 1;
595 /* what kind of [] is it? */
596 if (isDIGIT(*lenptr)) {
597 lenptr = get_num( lenptr, &symptr->length );
599 Perl_croak(aTHX_ "Malformed integer in [] in %s",
600 symptr->flags & FLAG_PACK ? "pack" : "unpack");
602 tempsym_t savsym = *symptr;
603 symptr->patend = patptr-1;
604 symptr->patptr = lenptr;
605 savsym.length = measure_struct(symptr);
609 symptr->howlen = e_no_len;
614 while (patptr < patend) {
615 if (isSPACE(*patptr))
617 else if (*patptr == '#') {
619 while (patptr < patend && *patptr != '\n')
624 if (*patptr == '/') {
625 symptr->flags |= FLAG_SLASH;
627 if (patptr < patend &&
628 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '['))
629 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
630 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
636 /* at end - no count, no / */
637 symptr->howlen = e_no_len;
642 symptr->patptr = patptr;
646 symptr->patptr = patptr;
651 =for apidoc unpack_str
653 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
654 and ocnt are not used. This call should not be used, use unpackstring instead.
659 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
661 tempsym_t sym = { 0 };
666 return unpack_rec(&sym, s, s, strend, NULL );
670 =for apidoc unpackstring
672 The engine implementing unpack() Perl function. C<unpackstring> puts the
673 extracted list items on the stack and returns the number of elements.
674 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
679 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
681 tempsym_t sym = { 0 };
686 return unpack_rec(&sym, s, s, strend, NULL );
691 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
695 register I32 len = 0;
696 register I32 bits = 0;
699 I32 start_sp_offset = SP - PL_stack_base;
702 /* These must not be in registers: */
711 #if SHORTSIZE != SIZE16
713 unsigned short aushort;
718 #if LONGSIZE != SIZE32
719 unsigned long aulong;
724 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
725 long double aldouble;
734 const int bits_in_uv = 8 * sizeof(cuv);
737 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
739 while (next_symbol(symptr)) {
740 datumtype = symptr->code;
741 /* do first one only unless in list context
742 / is implemented by unpacking the count, then poping it from the
743 stack, so must check that we're not in the middle of a / */
745 && (SP - PL_stack_base == start_sp_offset + 1)
746 && (datumtype != '/') ) /* XXX can this be omitted */
749 switch( howlen = symptr->howlen ){
752 len = symptr->length;
755 len = strend - strbeg; /* long enough */
760 beyond = s >= strend;
761 switch(TYPE_NO_ENDIANNESS(datumtype)) {
763 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
766 if (howlen == e_no_len)
767 len = 16; /* len is not specified */
775 char *ss = s; /* Move from register */
776 tempsym_t savsym = *symptr;
777 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
778 symptr->flags |= group_modifiers;
779 symptr->patend = savsym.grpend;
783 symptr->patptr = savsym.grpbeg;
784 unpack_rec(symptr, ss, strbeg, strend, &ss );
785 if (ss == strend && savsym.howlen == e_star)
786 break; /* No way to continue */
790 symptr->flags &= ~group_modifiers;
791 savsym.flags = symptr->flags;
796 if (len > strend - strrelbeg)
797 Perl_croak(aTHX_ "'@' outside of string in unpack");
800 case 'X' | TYPE_IS_SHRIEKING:
801 if (!len) /* Avoid division by 0 */
803 len = (s - strbeg) % len;
806 if (len > s - strbeg)
807 Perl_croak(aTHX_ "'X' outside of string in unpack" );
810 case 'x' | TYPE_IS_SHRIEKING:
811 if (!len) /* Avoid division by 0 */
813 aint = (s - strbeg) % len;
814 if (aint) /* Other portable ways? */
820 if (len > strend - s)
821 Perl_croak(aTHX_ "'x' outside of string in unpack");
825 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
830 if (len > strend - s)
834 sv = newSVpvn(s, len);
835 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
836 aptr = s; /* borrow register */
837 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
841 if (howlen == e_star) /* exact for 'Z*' */
842 len = s - SvPVX(sv) + 1;
844 else { /* 'A' strips both nulls and spaces */
845 s = SvPVX(sv) + len - 1;
846 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
850 SvCUR_set(sv, s - SvPVX(sv));
851 s = aptr; /* unborrow register */
854 XPUSHs(sv_2mortal(sv));
858 if (howlen == e_star || len > (strend - s) * 8)
859 len = (strend - s) * 8;
862 Newz(601, PL_bitcount, 256, char);
863 for (bits = 1; bits < 256; bits++) {
864 if (bits & 1) PL_bitcount[bits]++;
865 if (bits & 2) PL_bitcount[bits]++;
866 if (bits & 4) PL_bitcount[bits]++;
867 if (bits & 8) PL_bitcount[bits]++;
868 if (bits & 16) PL_bitcount[bits]++;
869 if (bits & 32) PL_bitcount[bits]++;
870 if (bits & 64) PL_bitcount[bits]++;
871 if (bits & 128) PL_bitcount[bits]++;
875 cuv += PL_bitcount[*(unsigned char*)s++];
880 if (datumtype == 'b') {
888 if (bits & 128) cuv++;
895 sv = NEWSV(35, len + 1);
899 if (datumtype == 'b') {
901 for (len = 0; len < aint; len++) {
902 if (len & 7) /*SUPPRESS 595*/
906 *str++ = '0' + (bits & 1);
911 for (len = 0; len < aint; len++) {
916 *str++ = '0' + ((bits & 128) != 0);
920 XPUSHs(sv_2mortal(sv));
924 if (howlen == e_star || len > (strend - s) * 2)
925 len = (strend - s) * 2;
926 sv = NEWSV(35, len + 1);
930 if (datumtype == 'h') {
932 for (len = 0; len < aint; len++) {
937 *str++ = PL_hexdigit[bits & 15];
942 for (len = 0; len < aint; len++) {
947 *str++ = PL_hexdigit[(bits >> 4) & 15];
951 XPUSHs(sv_2mortal(sv));
954 if (len > strend - s)
957 if (len && unpack_only_one)
964 if (aint >= 128) /* fake up signed chars */
967 PUSHs(sv_2mortal(newSViv((IV)aint)));
969 else if (checksum > bits_in_uv)
976 unpack_C: /* unpack U will jump here if not UTF-8 */
978 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
981 if (len > strend - s)
991 if (len && unpack_only_one)
997 PUSHs(sv_2mortal(newSViv((IV)auint)));
1003 symptr->flags |= FLAG_UNPACK_DO_UTF8;
1006 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
1008 if (len > strend - s)
1011 if (len && unpack_only_one)
1016 while (len-- > 0 && s < strend) {
1018 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1022 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1024 else if (checksum > bits_in_uv)
1025 cdouble += (NV)auint;
1030 case 's' | TYPE_IS_SHRIEKING:
1031 #if SHORTSIZE != SIZE16
1032 along = (strend - s) / sizeof(short);
1036 if (len && unpack_only_one)
1042 COPYNN(s, &ashort, sizeof(short));
1043 DO_BO_UNPACK(ashort, s);
1046 PUSHs(sv_2mortal(newSViv((IV)ashort)));
1048 else if (checksum > bits_in_uv)
1049 cdouble += (NV)ashort;
1058 along = (strend - s) / SIZE16;
1062 if (len && unpack_only_one)
1069 DO_BO_UNPACK(ai16, 16);
1070 #if U16SIZE > SIZE16
1076 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1078 else if (checksum > bits_in_uv)
1079 cdouble += (NV)ai16;
1084 case 'S' | TYPE_IS_SHRIEKING:
1085 #if SHORTSIZE != SIZE16
1086 along = (strend - s) / sizeof(unsigned short);
1090 if (len && unpack_only_one)
1096 COPYNN(s, &aushort, sizeof(unsigned short));
1097 DO_BO_UNPACK(aushort, s);
1098 s += sizeof(unsigned short);
1100 PUSHs(sv_2mortal(newSViv((UV)aushort)));
1102 else if (checksum > bits_in_uv)
1103 cdouble += (NV)aushort;
1114 along = (strend - s) / SIZE16;
1118 if (len && unpack_only_one)
1125 DO_BO_UNPACK(au16, 16);
1128 if (datumtype == 'n')
1129 au16 = PerlSock_ntohs(au16);
1132 if (datumtype == 'v')
1136 PUSHs(sv_2mortal(newSViv((UV)au16)));
1138 else if (checksum > bits_in_uv)
1139 cdouble += (NV)au16;
1144 case 'v' | TYPE_IS_SHRIEKING:
1145 case 'n' | TYPE_IS_SHRIEKING:
1146 along = (strend - s) / SIZE16;
1150 if (len && unpack_only_one)
1159 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1160 ai16 = (I16)PerlSock_ntohs((U16)ai16);
1163 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1164 ai16 = (I16)vtohs((U16)ai16);
1167 PUSHs(sv_2mortal(newSViv((IV)ai16)));
1169 else if (checksum > bits_in_uv)
1170 cdouble += (NV)ai16;
1176 case 'i' | TYPE_IS_SHRIEKING:
1177 along = (strend - s) / sizeof(int);
1181 if (len && unpack_only_one)
1187 Copy(s, &aint, 1, int);
1188 DO_BO_UNPACK(aint, i);
1191 PUSHs(sv_2mortal(newSViv((IV)aint)));
1193 else if (checksum > bits_in_uv)
1194 cdouble += (NV)aint;
1200 case 'I' | TYPE_IS_SHRIEKING:
1201 along = (strend - s) / sizeof(unsigned int);
1205 if (len && unpack_only_one)
1211 Copy(s, &auint, 1, unsigned int);
1212 DO_BO_UNPACK(auint, i);
1213 s += sizeof(unsigned int);
1215 PUSHs(sv_2mortal(newSVuv((UV)auint)));
1217 else if (checksum > bits_in_uv)
1218 cdouble += (NV)auint;
1224 along = (strend - s) / IVSIZE;
1228 if (len && unpack_only_one)
1234 Copy(s, &aiv, 1, IV);
1235 #if IVSIZE == INTSIZE
1236 DO_BO_UNPACK(aiv, i);
1237 #elif IVSIZE == LONGSIZE
1238 DO_BO_UNPACK(aiv, l);
1239 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1240 DO_BO_UNPACK(aiv, 64);
1244 PUSHs(sv_2mortal(newSViv(aiv)));
1246 else if (checksum > bits_in_uv)
1253 along = (strend - s) / UVSIZE;
1257 if (len && unpack_only_one)
1263 Copy(s, &auv, 1, UV);
1264 #if UVSIZE == INTSIZE
1265 DO_BO_UNPACK(auv, i);
1266 #elif UVSIZE == LONGSIZE
1267 DO_BO_UNPACK(auv, l);
1268 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1269 DO_BO_UNPACK(auv, 64);
1273 PUSHs(sv_2mortal(newSVuv(auv)));
1275 else if (checksum > bits_in_uv)
1281 case 'l' | TYPE_IS_SHRIEKING:
1282 #if LONGSIZE != SIZE32
1283 along = (strend - s) / sizeof(long);
1287 if (len && unpack_only_one)
1293 COPYNN(s, &along, sizeof(long));
1294 DO_BO_UNPACK(along, l);
1297 PUSHs(sv_2mortal(newSViv((IV)along)));
1299 else if (checksum > bits_in_uv)
1300 cdouble += (NV)along;
1309 along = (strend - s) / SIZE32;
1313 if (len && unpack_only_one)
1320 DO_BO_UNPACK(ai32, 32);
1321 #if U32SIZE > SIZE32
1322 if (ai32 > 2147483647)
1327 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1329 else if (checksum > bits_in_uv)
1330 cdouble += (NV)ai32;
1335 case 'L' | TYPE_IS_SHRIEKING:
1336 #if LONGSIZE != SIZE32
1337 along = (strend - s) / sizeof(unsigned long);
1341 if (len && unpack_only_one)
1347 COPYNN(s, &aulong, sizeof(unsigned long));
1348 DO_BO_UNPACK(aulong, l);
1349 s += sizeof(unsigned long);
1351 PUSHs(sv_2mortal(newSVuv((UV)aulong)));
1353 else if (checksum > bits_in_uv)
1354 cdouble += (NV)aulong;
1365 along = (strend - s) / SIZE32;
1369 if (len && unpack_only_one)
1376 DO_BO_UNPACK(au32, 32);
1379 if (datumtype == 'N')
1380 au32 = PerlSock_ntohl(au32);
1383 if (datumtype == 'V')
1387 PUSHs(sv_2mortal(newSVuv((UV)au32)));
1389 else if (checksum > bits_in_uv)
1390 cdouble += (NV)au32;
1395 case 'V' | TYPE_IS_SHRIEKING:
1396 case 'N' | TYPE_IS_SHRIEKING:
1397 along = (strend - s) / SIZE32;
1401 if (len && unpack_only_one)
1410 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1411 ai32 = (I32)PerlSock_ntohl((U32)ai32);
1414 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1415 ai32 = (I32)vtohl((U32)ai32);
1418 PUSHs(sv_2mortal(newSViv((IV)ai32)));
1420 else if (checksum > bits_in_uv)
1421 cdouble += (NV)ai32;
1427 along = (strend - s) / sizeof(char*);
1433 if (sizeof(char*) > strend - s)
1436 Copy(s, &aptr, 1, char*);
1437 DO_BO_UNPACK_P(aptr);
1440 /* newSVpv generates undef if aptr is NULL */
1441 PUSHs(sv_2mortal(newSVpv(aptr, 0)));
1445 if (len && unpack_only_one)
1453 while ((len > 0) && (s < strend)) {
1454 auv = (auv << 7) | (*s & 0x7f);
1455 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1456 if ((U8)(*s++) < 0x80) {
1458 PUSHs(sv_2mortal(newSVuv(auv)));
1462 else if (++bytes >= sizeof(UV)) { /* promote to string */
1466 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1467 while (s < strend) {
1468 sv = mul128(sv, (U8)(*s & 0x7f));
1469 if (!(*s++ & 0x80)) {
1478 PUSHs(sv_2mortal(sv));
1483 if ((s >= strend) && bytes)
1484 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1488 if (symptr->howlen == e_star)
1489 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1491 if (sizeof(char*) > strend - s)
1494 Copy(s, &aptr, 1, char*);
1495 DO_BO_UNPACK_P(aptr);
1498 /* newSVpvn generates undef if aptr is NULL */
1499 PUSHs(sv_2mortal(newSVpvn(aptr, len)));
1503 along = (strend - s) / sizeof(Quad_t);
1507 if (len && unpack_only_one)
1513 assert (s + sizeof(Quad_t) <= strend);
1514 Copy(s, &aquad, 1, Quad_t);
1515 DO_BO_UNPACK(aquad, 64);
1516 s += sizeof(Quad_t);
1518 PUSHs(sv_2mortal((aquad >= IV_MIN && aquad <= IV_MAX) ?
1519 newSViv((IV)aquad) : newSVnv((NV)aquad)));
1521 else if (checksum > bits_in_uv)
1522 cdouble += (NV)aquad;
1528 along = (strend - s) / sizeof(Uquad_t);
1532 if (len && unpack_only_one)
1538 assert (s + sizeof(Uquad_t) <= strend);
1539 Copy(s, &auquad, 1, Uquad_t);
1540 DO_BO_UNPACK(auquad, 64);
1541 s += sizeof(Uquad_t);
1543 PUSHs(sv_2mortal((auquad <= UV_MAX) ?
1544 newSVuv((UV)auquad) : newSVnv((NV)auquad)));
1546 else if (checksum > bits_in_uv)
1547 cdouble += (NV)auquad;
1553 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1555 along = (strend - s) / sizeof(float);
1559 if (len && unpack_only_one)
1565 Copy(s, &afloat, 1, float);
1566 DO_BO_UNPACK_N(afloat, float);
1569 PUSHs(sv_2mortal(newSVnv((NV)afloat)));
1577 along = (strend - s) / sizeof(double);
1581 if (len && unpack_only_one)
1587 Copy(s, &adouble, 1, double);
1588 DO_BO_UNPACK_N(adouble, double);
1589 s += sizeof(double);
1591 PUSHs(sv_2mortal(newSVnv((NV)adouble)));
1599 along = (strend - s) / NVSIZE;
1603 if (len && unpack_only_one)
1609 Copy(s, &anv, 1, NV);
1610 DO_BO_UNPACK_N(anv, NV);
1613 PUSHs(sv_2mortal(newSVnv(anv)));
1620 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1622 along = (strend - s) / LONG_DOUBLESIZE;
1626 if (len && unpack_only_one)
1632 Copy(s, &aldouble, 1, long double);
1633 DO_BO_UNPACK_N(aldouble, long double);
1634 s += LONG_DOUBLESIZE;
1636 PUSHs(sv_2mortal(newSVnv((NV)aldouble)));
1638 else {cdouble += aldouble;
1645 * Initialise the decode mapping. By using a table driven
1646 * algorithm, the code will be character-set independent
1647 * (and just as fast as doing character arithmetic)
1649 if (PL_uudmap['M'] == 0) {
1652 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1653 PL_uudmap[(U8)PL_uuemap[i]] = i;
1655 * Because ' ' and '`' map to the same value,
1656 * we need to decode them both the same.
1661 along = (strend - s) * 3 / 4;
1662 sv = NEWSV(42, along);
1665 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1670 len = PL_uudmap[*(U8*)s++] & 077;
1672 if (s < strend && ISUUCHAR(*s))
1673 a = PL_uudmap[*(U8*)s++] & 077;
1676 if (s < strend && ISUUCHAR(*s))
1677 b = PL_uudmap[*(U8*)s++] & 077;
1680 if (s < strend && ISUUCHAR(*s))
1681 c = PL_uudmap[*(U8*)s++] & 077;
1684 if (s < strend && ISUUCHAR(*s))
1685 d = PL_uudmap[*(U8*)s++] & 077;
1688 hunk[0] = (char)((a << 2) | (b >> 4));
1689 hunk[1] = (char)((b << 4) | (c >> 2));
1690 hunk[2] = (char)((c << 6) | d);
1691 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1696 else /* possible checksum byte */
1697 if (s + 1 < strend && s[1] == '\n')
1700 XPUSHs(sv_2mortal(sv));
1705 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1706 (checksum > bits_in_uv &&
1707 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1710 adouble = (NV) (1 << (checksum & 15));
1711 while (checksum >= 16) {
1715 while (cdouble < 0.0)
1717 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1718 sv = newSVnv(cdouble);
1721 if (checksum < bits_in_uv) {
1722 UV mask = ((UV)1 << checksum) - 1;
1727 XPUSHs(sv_2mortal(sv));
1731 if (symptr->flags & FLAG_SLASH){
1732 if (SP - PL_stack_base - start_sp_offset <= 0)
1733 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1734 if( next_symbol(symptr) ){
1735 if( symptr->howlen == e_number )
1736 Perl_croak(aTHX_ "Count after length/code in unpack" );
1738 /* ...end of char buffer then no decent length available */
1739 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1741 /* take top of stack (hope it's numeric) */
1744 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1747 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1749 datumtype = symptr->code;
1757 return SP - PL_stack_base - start_sp_offset;
1764 I32 gimme = GIMME_V;
1767 register char *pat = SvPV(left, llen);
1768 #ifdef PACKED_IS_OCTETS
1769 /* Packed side is assumed to be octets - so force downgrade if it
1770 has been UTF-8 encoded by accident
1772 register char *s = SvPVbyte(right, rlen);
1774 register char *s = SvPV(right, rlen);
1776 char *strend = s + rlen;
1777 register char *patend = pat + llen;
1781 cnt = unpackstring(pat, patend, s, strend,
1782 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
1783 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
1786 if ( !cnt && gimme == G_SCALAR )
1787 PUSHs(&PL_sv_undef);
1792 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
1796 *hunk = PL_uuemap[len];
1797 sv_catpvn(sv, hunk, 1);
1800 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1801 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
1802 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
1803 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
1804 sv_catpvn(sv, hunk, 4);
1809 char r = (len > 1 ? s[1] : '\0');
1810 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
1811 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
1812 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
1813 hunk[3] = PL_uuemap[0];
1814 sv_catpvn(sv, hunk, 4);
1816 sv_catpvn(sv, "\n", 1);
1820 S_is_an_int(pTHX_ char *s, STRLEN l)
1823 SV *result = newSVpvn(s, l);
1824 char *result_c = SvPV(result, n_a); /* convenience */
1825 char *out = result_c;
1835 SvREFCNT_dec(result);
1858 SvREFCNT_dec(result);
1864 SvCUR_set(result, out - result_c);
1868 /* pnum must be '\0' terminated */
1870 S_div128(pTHX_ SV *pnum, bool *done)
1873 char *s = SvPV(pnum, len);
1882 i = m * 10 + (*t - '0');
1884 r = (i >> 7); /* r < 10 */
1891 SvCUR_set(pnum, (STRLEN) (t - s));
1898 =for apidoc pack_cat
1900 The engine implementing pack() Perl function. Note: parameters next_in_list and
1901 flags are not used. This call should not be used; use packlist instead.
1907 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
1909 tempsym_t sym = { 0 };
1911 sym.patend = patend;
1912 sym.flags = FLAG_PACK;
1914 (void)pack_rec( cat, &sym, beglist, endlist );
1919 =for apidoc packlist
1921 The engine implementing pack() Perl function.
1927 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
1929 tempsym_t sym = { 0 };
1931 sym.patend = patend;
1932 sym.flags = FLAG_PACK;
1934 (void)pack_rec( cat, &sym, beglist, endlist );
1940 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
1944 register I32 len = 0;
1947 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
1948 static char *space10 = " ";
1951 /* These must not be in registers: */
1961 #if SHORTSIZE != SIZE16
1963 unsigned short aushort;
1967 #if LONGSIZE != SIZE32
1969 unsigned long aulong;
1974 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1975 long double aldouble;
1981 int strrelbeg = SvCUR(cat);
1982 tempsym_t lookahead;
1984 items = endlist - beglist;
1985 found = next_symbol( symptr );
1987 #ifndef PACKED_IS_OCTETS
1988 if (symptr->level == 0 && found && symptr->code == 'U' ){
1994 SV *lengthcode = Nullsv;
1995 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
1997 I32 datumtype = symptr->code;
2000 switch( howlen = symptr->howlen ){
2003 len = symptr->length;
2006 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2010 /* Look ahead for next symbol. Do we have code/code? */
2011 lookahead = *symptr;
2012 found = next_symbol(&lookahead);
2013 if ( symptr->flags & FLAG_SLASH ) {
2015 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2016 e_star != lookahead.howlen )
2017 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2018 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2019 ? *beglist : &PL_sv_no)
2020 + (lookahead.code == 'Z' ? 1 : 0)));
2022 Perl_croak(aTHX_ "Code missing after '/' in pack");
2026 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2028 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2030 Perl_croak(aTHX_ "'%%' may not be used in pack");
2032 len += strrelbeg - SvCUR(cat);
2041 tempsym_t savsym = *symptr;
2042 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags);
2043 symptr->flags |= group_modifiers;
2044 symptr->patend = savsym.grpend;
2047 symptr->patptr = savsym.grpbeg;
2048 beglist = pack_rec(cat, symptr, beglist, endlist );
2049 if (savsym.howlen == e_star && beglist == endlist)
2050 break; /* No way to continue */
2052 symptr->flags &= ~group_modifiers;
2053 lookahead.flags = symptr->flags;
2057 case 'X' | TYPE_IS_SHRIEKING:
2058 if (!len) /* Avoid division by 0 */
2060 len = (SvCUR(cat)) % len;
2064 if ((I32)SvCUR(cat) < len)
2065 Perl_croak(aTHX_ "'X' outside of string in pack");
2069 case 'x' | TYPE_IS_SHRIEKING:
2070 if (!len) /* Avoid division by 0 */
2072 aint = (SvCUR(cat)) % len;
2073 if (aint) /* Other portable ways? */
2082 sv_catpvn(cat, null10, 10);
2085 sv_catpvn(cat, null10, len);
2091 aptr = SvPV(fromstr, fromlen);
2092 if (howlen == e_star) {
2094 if (datumtype == 'Z')
2097 if ((I32)fromlen >= len) {
2098 sv_catpvn(cat, aptr, len);
2099 if (datumtype == 'Z')
2100 *(SvEND(cat)-1) = '\0';
2103 sv_catpvn(cat, aptr, fromlen);
2105 if (datumtype == 'A') {
2107 sv_catpvn(cat, space10, 10);
2110 sv_catpvn(cat, space10, len);
2114 sv_catpvn(cat, null10, 10);
2117 sv_catpvn(cat, null10, len);
2129 str = SvPV(fromstr, fromlen);
2130 if (howlen == e_star)
2133 SvCUR(cat) += (len+7)/8;
2134 SvGROW(cat, SvCUR(cat) + 1);
2135 aptr = SvPVX(cat) + aint;
2136 if (len > (I32)fromlen)
2140 if (datumtype == 'B') {
2141 for (len = 0; len++ < aint;) {
2142 items |= *str++ & 1;
2146 *aptr++ = items & 0xff;
2152 for (len = 0; len++ < aint;) {
2158 *aptr++ = items & 0xff;
2164 if (datumtype == 'B')
2165 items <<= 7 - (aint & 7);
2167 items >>= 7 - (aint & 7);
2168 *aptr++ = items & 0xff;
2170 str = SvPVX(cat) + SvCUR(cat);
2185 str = SvPV(fromstr, fromlen);
2186 if (howlen == e_star)
2189 SvCUR(cat) += (len+1)/2;
2190 SvGROW(cat, SvCUR(cat) + 1);
2191 aptr = SvPVX(cat) + aint;
2192 if (len > (I32)fromlen)
2196 if (datumtype == 'H') {
2197 for (len = 0; len++ < aint;) {
2199 items |= ((*str++ & 15) + 9) & 15;
2201 items |= *str++ & 15;
2205 *aptr++ = items & 0xff;
2211 for (len = 0; len++ < aint;) {
2213 items |= (((*str++ & 15) + 9) & 15) << 4;
2215 items |= (*str++ & 15) << 4;
2219 *aptr++ = items & 0xff;
2225 *aptr++ = items & 0xff;
2226 str = SvPVX(cat) + SvCUR(cat);
2237 switch (TYPE_NO_MODIFIERS(datumtype)) {
2239 aint = SvIV(fromstr);
2240 if ((aint < 0 || aint > 255) &&
2242 Perl_warner(aTHX_ packWARN(WARN_PACK),
2243 "Character in 'C' format wrapped in pack");
2245 sv_catpvn(cat, &achar, sizeof(char));
2248 aint = SvIV(fromstr);
2249 if ((aint < -128 || aint > 127) &&
2251 Perl_warner(aTHX_ packWARN(WARN_PACK),
2252 "Character in 'c' format wrapped in pack" );
2254 sv_catpvn(cat, &achar, sizeof(char));
2262 auint = UNI_TO_NATIVE(SvUV(fromstr));
2263 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2265 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2268 0 : UNICODE_ALLOW_ANY)
2273 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2278 /* VOS does not automatically map a floating-point overflow
2279 during conversion from double to float into infinity, so we
2280 do it by hand. This code should either be generalized for
2281 any OS that needs it, or removed if and when VOS implements
2282 posix-976 (suggestion to support mapping to infinity).
2283 Paul.Green@stratus.com 02-04-02. */
2284 if (SvNV(fromstr) > FLT_MAX)
2285 afloat = _float_constants[0]; /* single prec. inf. */
2286 else if (SvNV(fromstr) < -FLT_MAX)
2287 afloat = _float_constants[0]; /* single prec. inf. */
2288 else afloat = (float)SvNV(fromstr);
2290 # if defined(VMS) && !defined(__IEEE_FP)
2291 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2292 * on Alpha; fake it if we don't have them.
2294 if (SvNV(fromstr) > FLT_MAX)
2296 else if (SvNV(fromstr) < -FLT_MAX)
2298 else afloat = (float)SvNV(fromstr);
2300 afloat = (float)SvNV(fromstr);
2303 DO_BO_PACK_N(afloat, float);
2304 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2311 /* VOS does not automatically map a floating-point overflow
2312 during conversion from long double to double into infinity,
2313 so we do it by hand. This code should either be generalized
2314 for any OS that needs it, or removed if and when VOS
2315 implements posix-976 (suggestion to support mapping to
2316 infinity). Paul.Green@stratus.com 02-04-02. */
2317 if (SvNV(fromstr) > DBL_MAX)
2318 adouble = _double_constants[0]; /* double prec. inf. */
2319 else if (SvNV(fromstr) < -DBL_MAX)
2320 adouble = _double_constants[0]; /* double prec. inf. */
2321 else adouble = (double)SvNV(fromstr);
2323 # if defined(VMS) && !defined(__IEEE_FP)
2324 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2325 * on Alpha; fake it if we don't have them.
2327 if (SvNV(fromstr) > DBL_MAX)
2329 else if (SvNV(fromstr) < -DBL_MAX)
2331 else adouble = (double)SvNV(fromstr);
2333 adouble = (double)SvNV(fromstr);
2336 DO_BO_PACK_N(adouble, double);
2337 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2341 Zero(&anv, 1, NV); /* can be long double with unused bits */
2344 anv = SvNV(fromstr);
2345 DO_BO_PACK_N(anv, NV);
2346 sv_catpvn(cat, (char *)&anv, NVSIZE);
2349 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2351 /* long doubles can have unused bits, which may be nonzero */
2352 Zero(&aldouble, 1, long double);
2355 aldouble = (long double)SvNV(fromstr);
2356 DO_BO_PACK_N(aldouble, long double);
2357 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2361 case 'n' | TYPE_IS_SHRIEKING:
2365 ai16 = (I16)SvIV(fromstr);
2367 ai16 = PerlSock_htons(ai16);
2372 case 'v' | TYPE_IS_SHRIEKING:
2376 ai16 = (I16)SvIV(fromstr);
2383 case 'S' | TYPE_IS_SHRIEKING:
2384 #if SHORTSIZE != SIZE16
2388 aushort = SvUV(fromstr);
2389 DO_BO_PACK(aushort, s);
2390 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2401 au16 = (U16)SvUV(fromstr);
2402 DO_BO_PACK(au16, 16);
2408 case 's' | TYPE_IS_SHRIEKING:
2409 #if SHORTSIZE != SIZE16
2413 ashort = SvIV(fromstr);
2414 DO_BO_PACK(ashort, s);
2415 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2425 ai16 = (I16)SvIV(fromstr);
2426 DO_BO_PACK(ai16, 16);
2431 case 'I' | TYPE_IS_SHRIEKING:
2434 auint = SvUV(fromstr);
2435 DO_BO_PACK(auint, i);
2436 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2442 aiv = SvIV(fromstr);
2443 #if IVSIZE == INTSIZE
2445 #elif IVSIZE == LONGSIZE
2447 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2448 DO_BO_PACK(aiv, 64);
2450 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2456 auv = SvUV(fromstr);
2457 #if UVSIZE == INTSIZE
2459 #elif UVSIZE == LONGSIZE
2461 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2462 DO_BO_PACK(auv, 64);
2464 sv_catpvn(cat, (char*)&auv, UVSIZE);
2470 anv = SvNV(fromstr);
2473 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2475 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2476 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2477 any negative IVs will have already been got by the croak()
2478 above. IOK is untrue for fractions, so we test them
2479 against UV_MAX_P1. */
2480 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2482 char buf[(sizeof(UV)*8)/7+1];
2483 char *in = buf + sizeof(buf);
2484 UV auv = SvUV(fromstr);
2487 *--in = (char)((auv & 0x7f) | 0x80);
2490 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2491 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2493 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2494 char *from, *result, *in;
2499 /* Copy string and check for compliance */
2500 from = SvPV(fromstr, len);
2501 if ((norm = is_an_int(from, len)) == NULL)
2502 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2504 New('w', result, len, char);
2508 *--in = div128(norm, &done) | 0x80;
2509 result[len - 1] &= 0x7F; /* clear continue bit */
2510 sv_catpvn(cat, in, (result + len) - in);
2512 SvREFCNT_dec(norm); /* free norm */
2514 else if (SvNOKp(fromstr)) {
2515 /* 10**NV_MAX_10_EXP is the largest power of 10
2516 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2517 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2518 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2519 And with that many bytes only Inf can overflow.
2520 Some C compilers are strict about integral constant
2521 expressions so we conservatively divide by a slightly
2522 smaller integer instead of multiplying by the exact
2523 floating-point value.
2525 #ifdef NV_MAX_10_EXP
2526 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2527 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2529 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2530 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2532 char *in = buf + sizeof(buf);
2534 anv = Perl_floor(anv);
2536 NV next = Perl_floor(anv / 128);
2537 if (in <= buf) /* this cannot happen ;-) */
2538 Perl_croak(aTHX_ "Cannot compress integer in pack");
2539 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2542 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2543 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2546 char *from, *result, *in;
2551 /* Copy string and check for compliance */
2552 from = SvPV(fromstr, len);
2553 if ((norm = is_an_int(from, len)) == NULL)
2554 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2556 New('w', result, len, char);
2560 *--in = div128(norm, &done) | 0x80;
2561 result[len - 1] &= 0x7F; /* clear continue bit */
2562 sv_catpvn(cat, in, (result + len) - in);
2564 SvREFCNT_dec(norm); /* free norm */
2569 case 'i' | TYPE_IS_SHRIEKING:
2572 aint = SvIV(fromstr);
2573 DO_BO_PACK(aint, i);
2574 sv_catpvn(cat, (char*)&aint, sizeof(int));
2577 case 'N' | TYPE_IS_SHRIEKING:
2581 au32 = SvUV(fromstr);
2583 au32 = PerlSock_htonl(au32);
2588 case 'V' | TYPE_IS_SHRIEKING:
2592 au32 = SvUV(fromstr);
2599 case 'L' | TYPE_IS_SHRIEKING:
2600 #if LONGSIZE != SIZE32
2604 aulong = SvUV(fromstr);
2605 DO_BO_PACK(aulong, l);
2606 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2617 au32 = SvUV(fromstr);
2618 DO_BO_PACK(au32, 32);
2623 case 'l' | TYPE_IS_SHRIEKING:
2624 #if LONGSIZE != SIZE32
2628 along = SvIV(fromstr);
2629 DO_BO_PACK(along, l);
2630 sv_catpvn(cat, (char *)&along, sizeof(long));
2640 ai32 = SvIV(fromstr);
2641 DO_BO_PACK(ai32, 32);
2649 auquad = (Uquad_t)SvUV(fromstr);
2650 DO_BO_PACK(auquad, 64);
2651 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2657 aquad = (Quad_t)SvIV(fromstr);
2658 DO_BO_PACK(aquad, 64);
2659 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2664 len = 1; /* assume SV is correct length */
2669 if (fromstr == &PL_sv_undef)
2673 /* XXX better yet, could spirit away the string to
2674 * a safe spot and hang on to it until the result
2675 * of pack() (and all copies of the result) are
2678 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2679 || (SvPADTMP(fromstr)
2680 && !SvREADONLY(fromstr))))
2682 Perl_warner(aTHX_ packWARN(WARN_PACK),
2683 "Attempt to pack pointer to temporary value");
2685 if (SvPOK(fromstr) || SvNIOK(fromstr))
2686 aptr = SvPV(fromstr,n_a);
2688 aptr = SvPV_force(fromstr,n_a);
2691 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2696 aptr = SvPV(fromstr, fromlen);
2697 SvGROW(cat, fromlen * 4 / 3);
2702 while (fromlen > 0) {
2705 if ((I32)fromlen > len)
2709 doencodes(cat, aptr, todo);
2715 *symptr = lookahead;
2724 dSP; dMARK; dORIGMARK; dTARGET;
2725 register SV *cat = TARG;
2727 register char *pat = SvPVx(*++MARK, fromlen);
2728 register char *patend = pat + fromlen;
2731 sv_setpvn(cat, "", 0);
2733 packlist(cat, pat, patend, MARK, SP + 1);
2743 * c-indentation-style: bsd
2745 * indent-tabs-mode: t
2748 * vim: expandtab shiftwidth=4: