3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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,
20 #define PERL_IN_PP_PACK_C
24 * The compiler on Concurrent CX/UX systems has a subtle bug which only
25 * seems to show up when compiling pp.c - it generates the wrong double
26 * precision constant value for (double)UV_MAX when used inline in the body
27 * of the code below, so this makes a static variable up front (which the
28 * compiler seems to get correct) and uses it in place of UV_MAX below.
30 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
31 static double UV_MAX_cxux = ((double)UV_MAX);
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
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) == ' ')
133 #define TYPE_IS_SHRIEKING 0x100
134 #define TYPE_IS_BIG_ENDIAN 0x200
135 #define TYPE_IS_LITTLE_ENDIAN 0x400
136 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN)
137 #define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK)
138 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF)
140 #define DO_BO_UNPACK(var, type) \
142 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
143 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \
144 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \
149 #define DO_BO_PACK(var, type) \
151 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
152 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \
153 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \
158 #define DO_BO_UNPACK_PTR(var, type, pre_cast) \
160 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
161 case TYPE_IS_BIG_ENDIAN: \
162 var = (void *) my_betoh ## type ((pre_cast) var); \
164 case TYPE_IS_LITTLE_ENDIAN: \
165 var = (void *) my_letoh ## type ((pre_cast) var); \
172 #define DO_BO_PACK_PTR(var, type, pre_cast) \
174 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
175 case TYPE_IS_BIG_ENDIAN: \
176 var = (void *) my_htobe ## type ((pre_cast) var); \
178 case TYPE_IS_LITTLE_ENDIAN: \
179 var = (void *) my_htole ## type ((pre_cast) var); \
186 #define BO_CANT_DOIT(action, type) \
188 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
189 case TYPE_IS_BIG_ENDIAN: \
190 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \
191 "platform", #action, #type); \
193 case TYPE_IS_LITTLE_ENDIAN: \
194 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \
195 "platform", #action, #type); \
202 #if PTRSIZE == INTSIZE
203 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int)
204 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int)
205 #elif PTRSIZE == LONGSIZE
206 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long)
207 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long)
209 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer)
210 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer)
213 #if defined(my_htolen) && defined(my_letohn) && \
214 defined(my_htoben) && defined(my_betohn)
215 # define DO_BO_UNPACK_N(var, type) \
217 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
218 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\
219 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\
224 # define DO_BO_PACK_N(var, type) \
226 switch (datumtype & TYPE_ENDIANNESS_MASK) { \
227 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\
228 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\
233 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type)
234 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type)
237 /* Returns the sizeof() struct described by pat */
239 S_measure_struct(pTHX_ register tempsym_t* symptr)
241 register I32 len = 0;
242 register I32 total = 0;
247 while (next_symbol(symptr)) {
249 switch( symptr->howlen ){
252 len = symptr->length;
255 Perl_croak(aTHX_ "Within []-length '*' not allowed in %s",
256 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
260 /* endianness doesn't influence the size of a type */
261 switch(TYPE_NO_ENDIANNESS(symptr->code)) {
263 Perl_croak(aTHX_ "Invalid type '%c' in %s",
264 (int)TYPE_NO_MODIFIERS(symptr->code),
265 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
268 case 'U': /* XXXX Is it correct? */
271 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s",
273 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
279 tempsym_t savsym = *symptr;
280 symptr->patptr = savsym.grpbeg;
281 symptr->patend = savsym.grpend;
282 /* XXXX Theoretically, we need to measure many times at different
283 positions, since the subexpression may contain
284 alignment commands, but be not of aligned length.
285 Need to detect this and croak(). */
286 size = measure_struct(symptr);
290 case 'X' | TYPE_IS_SHRIEKING:
291 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */
292 if (!len) /* Avoid division by 0 */
294 len = total % len; /* Assumed: the start is aligned. */
299 Perl_croak(aTHX_ "'X' outside of string in %s",
300 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
302 case 'x' | TYPE_IS_SHRIEKING:
303 if (!len) /* Avoid division by 0 */
305 star = total % len; /* Assumed: the start is aligned. */
306 if (star) /* Other portable ways? */
329 case 's' | TYPE_IS_SHRIEKING:
330 #if SHORTSIZE != SIZE16
331 size = sizeof(short);
339 case 'S' | TYPE_IS_SHRIEKING:
340 #if SHORTSIZE != SIZE16
341 size = sizeof(unsigned short);
346 case 'v' | TYPE_IS_SHRIEKING:
347 case 'n' | TYPE_IS_SHRIEKING:
353 case 'i' | TYPE_IS_SHRIEKING:
357 case 'I' | TYPE_IS_SHRIEKING:
359 size = sizeof(unsigned int);
367 case 'l' | TYPE_IS_SHRIEKING:
368 #if LONGSIZE != SIZE32
377 case 'L' | TYPE_IS_SHRIEKING:
378 #if LONGSIZE != SIZE32
379 size = sizeof(unsigned long);
384 case 'V' | TYPE_IS_SHRIEKING:
385 case 'N' | TYPE_IS_SHRIEKING:
395 size = sizeof(char*);
399 size = sizeof(Quad_t);
402 size = sizeof(Uquad_t);
406 size = sizeof(float);
409 size = sizeof(double);
414 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
416 size = LONG_DOUBLESIZE;
426 /* locate matching closing parenthesis or bracket
427 * returns char pointer to char after match, or NULL
430 S_group_end(pTHX_ register char *patptr, register char *patend, char ender)
432 while (patptr < patend) {
440 while (patptr < patend && *patptr != '\n')
444 patptr = group_end(patptr, patend, ')') + 1;
446 patptr = group_end(patptr, patend, ']') + 1;
448 Perl_croak(aTHX_ "No group ending character '%c' found in template",
454 /* Convert unsigned decimal number to binary.
455 * Expects a pointer to the first digit and address of length variable
456 * Advances char pointer to 1st non-digit char and returns number
459 S_get_num(pTHX_ register char *patptr, I32 *lenptr )
461 I32 len = *patptr++ - '0';
462 while (isDIGIT(*patptr)) {
463 if (len >= 0x7FFFFFFF/10)
464 Perl_croak(aTHX_ "pack/unpack repeat count overflow");
465 len = (len * 10) + (*patptr++ - '0');
471 /* The marvellous template parsing routine: Using state stored in *symptr,
472 * locates next template code and count
475 S_next_symbol(pTHX_ register tempsym_t* symptr )
477 register char* patptr = symptr->patptr;
478 register char* patend = symptr->patend;
480 symptr->flags &= ~FLAG_SLASH;
482 while (patptr < patend) {
483 if (isSPACE(*patptr))
485 else if (*patptr == '#') {
487 while (patptr < patend && *patptr != '\n')
492 /* We should have found a template code */
493 I32 code = *patptr++ & 0xFF;
495 if (code == ','){ /* grandfather in commas but with a warning */
496 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){
497 symptr->flags |= FLAG_COMMA;
498 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
499 "Invalid type ',' in %s",
500 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
505 /* for '(', skip to ')' */
507 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' )
508 Perl_croak(aTHX_ "()-group starts with a count in %s",
509 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
510 symptr->grpbeg = patptr;
511 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') );
512 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL )
513 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s",
514 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
517 /* look for modifiers */
518 while (patptr < patend) {
523 modifier = TYPE_IS_SHRIEKING;
524 allowed = "sSiIlLxXnNvV";
527 modifier = TYPE_IS_BIG_ENDIAN;
528 allowed = "sSiIlLqQjJfFdDpP";
531 modifier = TYPE_IS_LITTLE_ENDIAN;
532 allowed = "sSiIlLqQjJfFdDpP";
539 if (!strchr(allowed, TYPE_NO_MODIFIERS(code)))
540 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr,
541 allowed, symptr->flags & FLAG_PACK ? "pack" : "unpack" );
542 if ((code | modifier) == (code | TYPE_IS_BIG_ENDIAN | TYPE_IS_LITTLE_ENDIAN))
543 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s",
544 (int) TYPE_NO_MODIFIERS(code),
545 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
546 if (ckWARN(WARN_UNPACK)) {
548 Perl_warner(aTHX_ packWARN(WARN_UNPACK),
549 "Duplicate modifier '%c' after '%c' in %s",
550 *patptr, (int) TYPE_NO_MODIFIERS(code),
551 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
557 /* look for count and/or / */
558 if (patptr < patend) {
559 if (isDIGIT(*patptr)) {
560 patptr = get_num( patptr, &symptr->length );
561 symptr->howlen = e_number;
563 } else if (*patptr == '*') {
565 symptr->howlen = e_star;
567 } else if (*patptr == '[') {
568 char* lenptr = ++patptr;
569 symptr->howlen = e_number;
570 patptr = group_end( patptr, patend, ']' ) + 1;
571 /* what kind of [] is it? */
572 if (isDIGIT(*lenptr)) {
573 lenptr = get_num( lenptr, &symptr->length );
575 Perl_croak(aTHX_ "Malformed integer in [] in %s",
576 symptr->flags & FLAG_PACK ? "pack" : "unpack");
578 tempsym_t savsym = *symptr;
579 symptr->patend = patptr-1;
580 symptr->patptr = lenptr;
581 savsym.length = measure_struct(symptr);
585 symptr->howlen = e_no_len;
590 while (patptr < patend) {
591 if (isSPACE(*patptr))
593 else if (*patptr == '#') {
595 while (patptr < patend && *patptr != '\n')
600 if( *patptr == '/' ){
601 symptr->flags |= FLAG_SLASH;
603 if( patptr < patend &&
604 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') )
605 Perl_croak(aTHX_ "'/' does not take a repeat count in %s",
606 symptr->flags & FLAG_PACK ? "pack" : "unpack" );
612 /* at end - no count, no / */
613 symptr->howlen = e_no_len;
618 symptr->patptr = patptr;
622 symptr->patptr = patptr;
627 =for apidoc unpack_str
629 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s
630 and ocnt are not used. This call should not be used, use unpackstring instead.
635 Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags)
637 tempsym_t sym = { 0 };
642 return unpack_rec(&sym, s, s, strend, NULL );
646 =for apidoc unpackstring
648 The engine implementing unpack() Perl function. C<unpackstring> puts the
649 extracted list items on the stack and returns the number of elements.
650 Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function.
655 Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags)
657 tempsym_t sym = { 0 };
662 return unpack_rec(&sym, s, s, strend, NULL );
667 S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s )
671 register I32 len = 0;
672 register I32 bits = 0;
675 I32 start_sp_offset = SP - PL_stack_base;
678 /* These must not be in registers: */
698 const int bits_in_uv = 8 * sizeof(cuv);
701 bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0;
706 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
707 long double aldouble;
710 while (next_symbol(symptr)) {
711 datumtype = symptr->code;
712 /* do first one only unless in list context
713 / is implemented by unpacking the count, then poping it from the
714 stack, so must check that we're not in the middle of a / */
716 && (SP - PL_stack_base == start_sp_offset + 1)
717 && (datumtype != '/') ) /* XXX can this be omitted */
720 switch( howlen = symptr->howlen ){
723 len = symptr->length;
726 len = strend - strbeg; /* long enough */
731 beyond = s >= strend;
732 switch(TYPE_NO_ENDIANNESS(datumtype)) {
734 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) );
737 if (howlen == e_no_len)
738 len = 16; /* len is not specified */
746 char *ss = s; /* Move from register */
747 tempsym_t savsym = *symptr;
748 symptr->patend = savsym.grpend;
752 symptr->patptr = savsym.grpbeg;
753 unpack_rec(symptr, ss, strbeg, strend, &ss );
754 if (ss == strend && savsym.howlen == e_star)
755 break; /* No way to continue */
759 savsym.flags = symptr->flags;
764 if (len > strend - strrelbeg)
765 Perl_croak(aTHX_ "'@' outside of string in unpack");
768 case 'X' | TYPE_IS_SHRIEKING:
769 if (!len) /* Avoid division by 0 */
771 len = (s - strbeg) % len;
774 if (len > s - strbeg)
775 Perl_croak(aTHX_ "'X' outside of string in unpack" );
778 case 'x' | TYPE_IS_SHRIEKING:
779 if (!len) /* Avoid division by 0 */
781 aint = (s - strbeg) % len;
782 if (aint) /* Other portable ways? */
788 if (len > strend - s)
789 Perl_croak(aTHX_ "'x' outside of string in unpack");
793 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
798 if (len > strend - s)
803 sv_setpvn(sv, s, len);
804 if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) {
805 aptr = s; /* borrow register */
806 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
810 if (howlen == e_star) /* exact for 'Z*' */
811 len = s - SvPVX(sv) + 1;
813 else { /* 'A' strips both nulls and spaces */
814 s = SvPVX(sv) + len - 1;
815 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
819 SvCUR_set(sv, s - SvPVX(sv));
820 s = aptr; /* unborrow register */
823 XPUSHs(sv_2mortal(sv));
827 if (howlen == e_star || len > (strend - s) * 8)
828 len = (strend - s) * 8;
831 Newz(601, PL_bitcount, 256, char);
832 for (bits = 1; bits < 256; bits++) {
833 if (bits & 1) PL_bitcount[bits]++;
834 if (bits & 2) PL_bitcount[bits]++;
835 if (bits & 4) PL_bitcount[bits]++;
836 if (bits & 8) PL_bitcount[bits]++;
837 if (bits & 16) PL_bitcount[bits]++;
838 if (bits & 32) PL_bitcount[bits]++;
839 if (bits & 64) PL_bitcount[bits]++;
840 if (bits & 128) PL_bitcount[bits]++;
844 cuv += PL_bitcount[*(unsigned char*)s++];
849 if (datumtype == 'b') {
857 if (bits & 128) cuv++;
864 sv = NEWSV(35, len + 1);
868 if (datumtype == 'b') {
870 for (len = 0; len < aint; len++) {
871 if (len & 7) /*SUPPRESS 595*/
875 *str++ = '0' + (bits & 1);
880 for (len = 0; len < aint; len++) {
885 *str++ = '0' + ((bits & 128) != 0);
889 XPUSHs(sv_2mortal(sv));
893 if (howlen == e_star || len > (strend - s) * 2)
894 len = (strend - s) * 2;
895 sv = NEWSV(35, len + 1);
899 if (datumtype == 'h') {
901 for (len = 0; len < aint; len++) {
906 *str++ = PL_hexdigit[bits & 15];
911 for (len = 0; len < aint; len++) {
916 *str++ = PL_hexdigit[(bits >> 4) & 15];
920 XPUSHs(sv_2mortal(sv));
923 if (len > strend - s)
928 if (aint >= 128) /* fake up signed chars */
930 if (checksum > bits_in_uv)
937 if (len && unpack_only_one)
943 if (aint >= 128) /* fake up signed chars */
946 sv_setiv(sv, (IV)aint);
947 PUSHs(sv_2mortal(sv));
952 unpack_C: /* unpack U will jump here if not UTF-8 */
954 symptr->flags &= ~FLAG_UNPACK_DO_UTF8;
957 if (len > strend - s)
967 if (len && unpack_only_one)
974 sv_setiv(sv, (IV)auint);
975 PUSHs(sv_2mortal(sv));
981 symptr->flags |= FLAG_UNPACK_DO_UTF8;
984 if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0)
986 if (len > strend - s)
989 while (len-- > 0 && s < strend) {
991 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
994 if (checksum > bits_in_uv)
995 cdouble += (NV)auint;
1001 if (len && unpack_only_one)
1005 while (len-- > 0 && s < strend) {
1007 auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
1011 sv_setuv(sv, (UV)auint);
1012 PUSHs(sv_2mortal(sv));
1016 case 's' | TYPE_IS_SHRIEKING:
1017 #if SHORTSIZE != SIZE16
1018 along = (strend - s) / sizeof(short);
1024 COPYNN(s, &ashort, sizeof(short));
1025 DO_BO_UNPACK(ashort, s);
1027 if (checksum > bits_in_uv)
1028 cdouble += (NV)ashort;
1035 if (len && unpack_only_one)
1040 COPYNN(s, &ashort, sizeof(short));
1041 DO_BO_UNPACK(ashort, s);
1044 sv_setiv(sv, (IV)ashort);
1045 PUSHs(sv_2mortal(sv));
1053 along = (strend - s) / SIZE16;
1058 COPY16(s, &asshort);
1059 DO_BO_UNPACK(asshort, 16);
1060 #if U16SIZE > SIZE16
1061 if (asshort > 32767)
1065 if (checksum > bits_in_uv)
1066 cdouble += (NV)asshort;
1072 if (len && unpack_only_one)
1078 COPY16(s, &asshort);
1079 DO_BO_UNPACK(asshort, 16);
1080 #if U16SIZE > SIZE16
1081 if (asshort > 32767)
1086 sv_setiv(sv, (IV)asshort);
1087 PUSHs(sv_2mortal(sv));
1091 case 'S' | TYPE_IS_SHRIEKING:
1092 #if SHORTSIZE != SIZE16
1093 along = (strend - s) / sizeof(unsigned short);
1097 unsigned short aushort;
1099 COPYNN(s, &aushort, sizeof(unsigned short));
1100 DO_BO_UNPACK(aushort, s);
1101 s += sizeof(unsigned short);
1102 if (checksum > bits_in_uv)
1103 cdouble += (NV)aushort;
1109 if (len && unpack_only_one)
1114 unsigned short aushort;
1115 COPYNN(s, &aushort, sizeof(unsigned short));
1116 DO_BO_UNPACK(aushort, s);
1117 s += sizeof(unsigned short);
1119 sv_setiv(sv, (UV)aushort);
1120 PUSHs(sv_2mortal(sv));
1130 along = (strend - s) / SIZE16;
1135 COPY16(s, &aushort);
1136 DO_BO_UNPACK(aushort, 16);
1139 if (datumtype == 'n')
1140 aushort = PerlSock_ntohs(aushort);
1143 if (datumtype == 'v')
1144 aushort = vtohs(aushort);
1146 if (checksum > bits_in_uv)
1147 cdouble += (NV)aushort;
1153 if (len && unpack_only_one)
1158 COPY16(s, &aushort);
1159 DO_BO_UNPACK(aushort, 16);
1163 if (datumtype == 'n')
1164 aushort = PerlSock_ntohs(aushort);
1167 if (datumtype == 'v')
1168 aushort = vtohs(aushort);
1170 sv_setiv(sv, (UV)aushort);
1171 PUSHs(sv_2mortal(sv));
1175 case 'v' | TYPE_IS_SHRIEKING:
1176 case 'n' | TYPE_IS_SHRIEKING:
1177 along = (strend - s) / SIZE16;
1182 COPY16(s, &asshort);
1185 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1186 asshort = (I16)PerlSock_ntohs((U16)asshort);
1189 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1190 asshort = (I16)vtohs((U16)asshort);
1192 if (checksum > bits_in_uv)
1193 cdouble += (NV)asshort;
1199 if (len && unpack_only_one)
1204 COPY16(s, &asshort);
1207 if (datumtype == ('n' | TYPE_IS_SHRIEKING))
1208 asshort = (I16)PerlSock_ntohs((U16)asshort);
1211 if (datumtype == ('v' | TYPE_IS_SHRIEKING))
1212 asshort = (I16)vtohs((U16)asshort);
1215 sv_setiv(sv, (IV)asshort);
1216 PUSHs(sv_2mortal(sv));
1221 case 'i' | TYPE_IS_SHRIEKING:
1222 along = (strend - s) / sizeof(int);
1227 Copy(s, &aint, 1, int);
1228 DO_BO_UNPACK(aint, i);
1230 if (checksum > bits_in_uv)
1231 cdouble += (NV)aint;
1237 if (len && unpack_only_one)
1242 Copy(s, &aint, 1, int);
1243 DO_BO_UNPACK(aint, i);
1247 /* Without the dummy below unpack("i", pack("i",-1))
1248 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
1249 * cc with optimization turned on.
1251 * The bug was detected in
1252 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
1253 * with optimization (-O4) turned on.
1254 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
1255 * does not have this problem even with -O4.
1257 * This bug was reported as DECC_BUGS 1431
1258 * and tracked internally as GEM_BUGS 7775.
1260 * The bug is fixed in
1261 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
1262 * UNIX V4.0F support: DEC C V5.9-006 or later
1263 * UNIX V4.0E support: DEC C V5.8-011 or later
1266 * See also few lines later for the same bug.
1269 sv_setiv(sv, (IV)aint) :
1271 sv_setiv(sv, (IV)aint);
1272 PUSHs(sv_2mortal(sv));
1277 case 'I' | TYPE_IS_SHRIEKING:
1278 along = (strend - s) / sizeof(unsigned int);
1283 Copy(s, &auint, 1, unsigned int);
1284 DO_BO_UNPACK(auint, i);
1285 s += sizeof(unsigned int);
1286 if (checksum > bits_in_uv)
1287 cdouble += (NV)auint;
1293 if (len && unpack_only_one)
1298 Copy(s, &auint, 1, unsigned int);
1299 DO_BO_UNPACK(auint, i);
1300 s += sizeof(unsigned int);
1303 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
1304 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
1305 * See details few lines earlier. */
1307 sv_setuv(sv, (UV)auint) :
1309 sv_setuv(sv, (UV)auint);
1310 PUSHs(sv_2mortal(sv));
1315 along = (strend - s) / IVSIZE;
1320 Copy(s, &aiv, 1, IV);
1321 #if IVSIZE == INTSIZE
1322 DO_BO_UNPACK(aiv, i);
1323 #elif IVSIZE == LONGSIZE
1324 DO_BO_UNPACK(aiv, l);
1325 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1326 DO_BO_UNPACK(aiv, 64);
1329 if (checksum > bits_in_uv)
1336 if (len && unpack_only_one)
1341 Copy(s, &aiv, 1, IV);
1342 #if IVSIZE == INTSIZE
1343 DO_BO_UNPACK(aiv, i);
1344 #elif IVSIZE == LONGSIZE
1345 DO_BO_UNPACK(aiv, l);
1346 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
1347 DO_BO_UNPACK(aiv, 64);
1352 PUSHs(sv_2mortal(sv));
1357 along = (strend - s) / UVSIZE;
1362 Copy(s, &auv, 1, UV);
1363 #if UVSIZE == INTSIZE
1364 DO_BO_UNPACK(auv, i);
1365 #elif UVSIZE == LONGSIZE
1366 DO_BO_UNPACK(auv, l);
1367 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1368 DO_BO_UNPACK(auv, 64);
1371 if (checksum > bits_in_uv)
1378 if (len && unpack_only_one)
1383 Copy(s, &auv, 1, UV);
1384 #if UVSIZE == INTSIZE
1385 DO_BO_UNPACK(auv, i);
1386 #elif UVSIZE == LONGSIZE
1387 DO_BO_UNPACK(auv, l);
1388 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
1389 DO_BO_UNPACK(auv, 64);
1394 PUSHs(sv_2mortal(sv));
1398 case 'l' | TYPE_IS_SHRIEKING:
1399 #if LONGSIZE != SIZE32
1400 along = (strend - s) / sizeof(long);
1405 COPYNN(s, &along, sizeof(long));
1406 DO_BO_UNPACK(along, l);
1408 if (checksum > bits_in_uv)
1409 cdouble += (NV)along;
1415 if (len && unpack_only_one)
1420 COPYNN(s, &along, sizeof(long));
1421 DO_BO_UNPACK(along, l);
1424 sv_setiv(sv, (IV)along);
1425 PUSHs(sv_2mortal(sv));
1433 along = (strend - s) / SIZE32;
1438 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1442 DO_BO_UNPACK(along, 32);
1443 #if LONGSIZE > SIZE32
1444 if (along > 2147483647)
1445 along -= 4294967296;
1448 if (checksum > bits_in_uv)
1449 cdouble += (NV)along;
1455 if (len && unpack_only_one)
1460 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
1464 DO_BO_UNPACK(along, 32);
1465 #if LONGSIZE > SIZE32
1466 if (along > 2147483647)
1467 along -= 4294967296;
1471 sv_setiv(sv, (IV)along);
1472 PUSHs(sv_2mortal(sv));
1476 case 'L' | TYPE_IS_SHRIEKING:
1477 #if LONGSIZE != SIZE32
1478 along = (strend - s) / sizeof(unsigned long);
1483 unsigned long aulong;
1484 COPYNN(s, &aulong, sizeof(unsigned long));
1485 DO_BO_UNPACK(aulong, l);
1486 s += sizeof(unsigned long);
1487 if (checksum > bits_in_uv)
1488 cdouble += (NV)aulong;
1494 if (len && unpack_only_one)
1499 unsigned long aulong;
1500 COPYNN(s, &aulong, sizeof(unsigned long));
1501 DO_BO_UNPACK(aulong, l);
1502 s += sizeof(unsigned long);
1504 sv_setuv(sv, (UV)aulong);
1505 PUSHs(sv_2mortal(sv));
1515 along = (strend - s) / SIZE32;
1521 DO_BO_UNPACK(aulong, 32);
1524 if (datumtype == 'N')
1525 aulong = PerlSock_ntohl(aulong);
1528 if (datumtype == 'V')
1529 aulong = vtohl(aulong);
1531 if (checksum > bits_in_uv)
1532 cdouble += (NV)aulong;
1538 if (len && unpack_only_one)
1544 DO_BO_UNPACK(aulong, 32);
1547 if (datumtype == 'N')
1548 aulong = PerlSock_ntohl(aulong);
1551 if (datumtype == 'V')
1552 aulong = vtohl(aulong);
1555 sv_setuv(sv, (UV)aulong);
1556 PUSHs(sv_2mortal(sv));
1560 case 'V' | TYPE_IS_SHRIEKING:
1561 case 'N' | TYPE_IS_SHRIEKING:
1562 along = (strend - s) / SIZE32;
1570 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1571 aslong = (I32)PerlSock_ntohl((U32)aslong);
1574 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1575 aslong = (I32)vtohl((U32)aslong);
1577 if (checksum > bits_in_uv)
1578 cdouble += (NV)aslong;
1584 if (len && unpack_only_one)
1592 if (datumtype == ('N' | TYPE_IS_SHRIEKING))
1593 aslong = (I32)PerlSock_ntohl((U32)aslong);
1596 if (datumtype == ('V' | TYPE_IS_SHRIEKING))
1597 aslong = (I32)vtohl((U32)aslong);
1600 sv_setiv(sv, (IV)aslong);
1601 PUSHs(sv_2mortal(sv));
1606 along = (strend - s) / sizeof(char*);
1612 if (sizeof(char*) > strend - s)
1615 Copy(s, &aptr, 1, char*);
1616 DO_BO_UNPACK_P(aptr);
1622 PUSHs(sv_2mortal(sv));
1626 if (len && unpack_only_one)
1634 while ((len > 0) && (s < strend)) {
1635 auv = (auv << 7) | (*s & 0x7f);
1636 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
1637 if ((U8)(*s++) < 0x80) {
1641 PUSHs(sv_2mortal(sv));
1645 else if (++bytes >= sizeof(UV)) { /* promote to string */
1649 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
1650 while (s < strend) {
1651 sv = mul128(sv, (U8)(*s & 0x7f));
1652 if (!(*s++ & 0x80)) {
1661 PUSHs(sv_2mortal(sv));
1666 if ((s >= strend) && bytes)
1667 Perl_croak(aTHX_ "Unterminated compressed integer in unpack");
1671 if (symptr->howlen == e_star)
1672 Perl_croak(aTHX_ "'P' must have an explicit size in unpack");
1674 if (sizeof(char*) > strend - s)
1677 Copy(s, &aptr, 1, char*);
1678 DO_BO_UNPACK_P(aptr);
1683 sv_setpvn(sv, aptr, len);
1684 PUSHs(sv_2mortal(sv));
1688 along = (strend - s) / sizeof(Quad_t);
1693 Copy(s, &aquad, 1, Quad_t);
1694 DO_BO_UNPACK(aquad, 64);
1695 s += sizeof(Quad_t);
1696 if (checksum > bits_in_uv)
1697 cdouble += (NV)aquad;
1703 if (len && unpack_only_one)
1708 if (s + sizeof(Quad_t) > strend)
1711 Copy(s, &aquad, 1, Quad_t);
1712 DO_BO_UNPACK(aquad, 64);
1713 s += sizeof(Quad_t);
1716 if (aquad >= IV_MIN && aquad <= IV_MAX)
1717 sv_setiv(sv, (IV)aquad);
1719 sv_setnv(sv, (NV)aquad);
1720 PUSHs(sv_2mortal(sv));
1725 along = (strend - s) / sizeof(Uquad_t);
1730 Copy(s, &auquad, 1, Uquad_t);
1731 DO_BO_UNPACK(auquad, 64);
1732 s += sizeof(Uquad_t);
1733 if (checksum > bits_in_uv)
1734 cdouble += (NV)auquad;
1740 if (len && unpack_only_one)
1745 if (s + sizeof(Uquad_t) > strend)
1748 Copy(s, &auquad, 1, Uquad_t);
1749 DO_BO_UNPACK(auquad, 64);
1750 s += sizeof(Uquad_t);
1753 if (auquad <= UV_MAX)
1754 sv_setuv(sv, (UV)auquad);
1756 sv_setnv(sv, (NV)auquad);
1757 PUSHs(sv_2mortal(sv));
1762 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
1764 along = (strend - s) / sizeof(float);
1769 Copy(s, &afloat, 1, float);
1770 DO_BO_UNPACK_N(afloat, float);
1776 if (len && unpack_only_one)
1781 Copy(s, &afloat, 1, float);
1782 DO_BO_UNPACK_N(afloat, float);
1785 sv_setnv(sv, (NV)afloat);
1786 PUSHs(sv_2mortal(sv));
1791 along = (strend - s) / sizeof(double);
1796 Copy(s, &adouble, 1, double);
1797 DO_BO_UNPACK_N(adouble, double);
1798 s += sizeof(double);
1803 if (len && unpack_only_one)
1808 Copy(s, &adouble, 1, double);
1809 DO_BO_UNPACK_N(adouble, double);
1810 s += sizeof(double);
1812 sv_setnv(sv, (NV)adouble);
1813 PUSHs(sv_2mortal(sv));
1818 along = (strend - s) / NVSIZE;
1823 Copy(s, &anv, 1, NV);
1824 DO_BO_UNPACK_N(anv, NV);
1830 if (len && unpack_only_one)
1835 Copy(s, &anv, 1, NV);
1836 DO_BO_UNPACK_N(anv, NV);
1840 PUSHs(sv_2mortal(sv));
1844 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
1846 along = (strend - s) / LONG_DOUBLESIZE;
1851 Copy(s, &aldouble, 1, long double);
1852 DO_BO_UNPACK_N(aldouble, long double);
1853 s += LONG_DOUBLESIZE;
1854 cdouble += aldouble;
1858 if (len && unpack_only_one)
1863 Copy(s, &aldouble, 1, long double);
1864 DO_BO_UNPACK_N(aldouble, long double);
1865 s += LONG_DOUBLESIZE;
1867 sv_setnv(sv, (NV)aldouble);
1868 PUSHs(sv_2mortal(sv));
1875 * Initialise the decode mapping. By using a table driven
1876 * algorithm, the code will be character-set independent
1877 * (and just as fast as doing character arithmetic)
1879 if (PL_uudmap['M'] == 0) {
1882 for (i = 0; i < sizeof(PL_uuemap); i += 1)
1883 PL_uudmap[(U8)PL_uuemap[i]] = i;
1885 * Because ' ' and '`' map to the same value,
1886 * we need to decode them both the same.
1891 along = (strend - s) * 3 / 4;
1892 sv = NEWSV(42, along);
1895 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
1900 len = PL_uudmap[*(U8*)s++] & 077;
1902 if (s < strend && ISUUCHAR(*s))
1903 a = PL_uudmap[*(U8*)s++] & 077;
1906 if (s < strend && ISUUCHAR(*s))
1907 b = PL_uudmap[*(U8*)s++] & 077;
1910 if (s < strend && ISUUCHAR(*s))
1911 c = PL_uudmap[*(U8*)s++] & 077;
1914 if (s < strend && ISUUCHAR(*s))
1915 d = PL_uudmap[*(U8*)s++] & 077;
1918 hunk[0] = (char)((a << 2) | (b >> 4));
1919 hunk[1] = (char)((b << 4) | (c >> 2));
1920 hunk[2] = (char)((c << 6) | d);
1921 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
1926 else /* possible checksum byte */
1927 if (s + 1 < strend && s[1] == '\n')
1930 XPUSHs(sv_2mortal(sv));
1936 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) ||
1937 (checksum > bits_in_uv &&
1938 strchr("csSiIlLnNUvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) {
1941 adouble = (NV) (1 << (checksum & 15));
1942 while (checksum >= 16) {
1946 while (cdouble < 0.0)
1948 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
1949 sv_setnv(sv, cdouble);
1952 if (checksum < bits_in_uv) {
1953 UV mask = ((UV)1 << checksum) - 1;
1958 XPUSHs(sv_2mortal(sv));
1962 if (symptr->flags & FLAG_SLASH){
1963 if (SP - PL_stack_base - start_sp_offset <= 0)
1964 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack");
1965 if( next_symbol(symptr) ){
1966 if( symptr->howlen == e_number )
1967 Perl_croak(aTHX_ "Count after length/code in unpack" );
1969 /* ...end of char buffer then no decent length available */
1970 Perl_croak(aTHX_ "length/code after end of string in unpack" );
1972 /* take top of stack (hope it's numeric) */
1975 Perl_croak(aTHX_ "Negative '/' count in unpack" );
1978 Perl_croak(aTHX_ "Code missing after '/' in unpack" );
1980 datumtype = symptr->code;
1988 return SP - PL_stack_base - start_sp_offset;
1995 I32 gimme = GIMME_V;
1998 register char *pat = SvPV(left, llen);
1999 #ifdef PACKED_IS_OCTETS
2000 /* Packed side is assumed to be octets - so force downgrade if it
2001 has been UTF-8 encoded by accident
2003 register char *s = SvPVbyte(right, rlen);
2005 register char *s = SvPV(right, rlen);
2007 char *strend = s + rlen;
2008 register char *patend = pat + llen;
2012 cnt = unpackstring(pat, patend, s, strend,
2013 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0)
2014 | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0));
2017 if ( !cnt && gimme == G_SCALAR )
2018 PUSHs(&PL_sv_undef);
2023 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
2027 *hunk = PL_uuemap[len];
2028 sv_catpvn(sv, hunk, 1);
2031 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2032 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
2033 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
2034 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
2035 sv_catpvn(sv, hunk, 4);
2040 char r = (len > 1 ? s[1] : '\0');
2041 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
2042 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
2043 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
2044 hunk[3] = PL_uuemap[0];
2045 sv_catpvn(sv, hunk, 4);
2047 sv_catpvn(sv, "\n", 1);
2051 S_is_an_int(pTHX_ char *s, STRLEN l)
2054 SV *result = newSVpvn(s, l);
2055 char *result_c = SvPV(result, n_a); /* convenience */
2056 char *out = result_c;
2066 SvREFCNT_dec(result);
2089 SvREFCNT_dec(result);
2095 SvCUR_set(result, out - result_c);
2099 /* pnum must be '\0' terminated */
2101 S_div128(pTHX_ SV *pnum, bool *done)
2104 char *s = SvPV(pnum, len);
2113 i = m * 10 + (*t - '0');
2115 r = (i >> 7); /* r < 10 */
2122 SvCUR_set(pnum, (STRLEN) (t - s));
2129 =for apidoc pack_cat
2131 The engine implementing pack() Perl function. Note: parameters next_in_list and
2132 flags are not used. This call should not be used; use packlist instead.
2138 Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
2140 tempsym_t sym = { 0 };
2142 sym.patend = patend;
2143 sym.flags = FLAG_PACK;
2145 (void)pack_rec( cat, &sym, beglist, endlist );
2150 =for apidoc packlist
2152 The engine implementing pack() Perl function.
2158 Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist )
2160 tempsym_t sym = { 0 };
2162 sym.patend = patend;
2163 sym.flags = FLAG_PACK;
2165 (void)pack_rec( cat, &sym, beglist, endlist );
2171 S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist )
2175 register I32 len = 0;
2178 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
2179 static char *space10 = " ";
2182 /* These must not be in registers: */
2192 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2193 long double aldouble;
2202 int strrelbeg = SvCUR(cat);
2203 tempsym_t lookahead;
2205 items = endlist - beglist;
2206 found = next_symbol( symptr );
2208 #ifndef PACKED_IS_OCTETS
2209 if (symptr->level == 0 && found && symptr->code == 'U' ){
2215 SV *lengthcode = Nullsv;
2216 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no)
2218 I32 datumtype = symptr->code;
2221 switch( howlen = symptr->howlen ){
2224 len = symptr->length;
2227 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 0 : items;
2231 /* Look ahead for next symbol. Do we have code/code? */
2232 lookahead = *symptr;
2233 found = next_symbol(&lookahead);
2234 if ( symptr->flags & FLAG_SLASH ) {
2236 if ( 0 == strchr( "aAZ", lookahead.code ) ||
2237 e_star != lookahead.howlen )
2238 Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack");
2239 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
2240 ? *beglist : &PL_sv_no)
2241 + (lookahead.code == 'Z' ? 1 : 0)));
2243 Perl_croak(aTHX_ "Code missing after '/' in pack");
2247 switch(TYPE_NO_ENDIANNESS(datumtype)) {
2249 Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)TYPE_NO_MODIFIERS(datumtype));
2251 Perl_croak(aTHX_ "'%%' may not be used in pack");
2253 len += strrelbeg - SvCUR(cat);
2262 tempsym_t savsym = *symptr;
2263 symptr->patend = savsym.grpend;
2266 symptr->patptr = savsym.grpbeg;
2267 beglist = pack_rec(cat, symptr, beglist, endlist );
2268 if (savsym.howlen == e_star && beglist == endlist)
2269 break; /* No way to continue */
2271 lookahead.flags = symptr->flags;
2275 case 'X' | TYPE_IS_SHRIEKING:
2276 if (!len) /* Avoid division by 0 */
2278 len = (SvCUR(cat)) % len;
2282 if ((I32)SvCUR(cat) < len)
2283 Perl_croak(aTHX_ "'X' outside of string in pack");
2287 case 'x' | TYPE_IS_SHRIEKING:
2288 if (!len) /* Avoid division by 0 */
2290 aint = (SvCUR(cat)) % len;
2291 if (aint) /* Other portable ways? */
2300 sv_catpvn(cat, null10, 10);
2303 sv_catpvn(cat, null10, len);
2309 aptr = SvPV(fromstr, fromlen);
2310 if (howlen == e_star) {
2312 if (datumtype == 'Z')
2315 if ((I32)fromlen >= len) {
2316 sv_catpvn(cat, aptr, len);
2317 if (datumtype == 'Z')
2318 *(SvEND(cat)-1) = '\0';
2321 sv_catpvn(cat, aptr, fromlen);
2323 if (datumtype == 'A') {
2325 sv_catpvn(cat, space10, 10);
2328 sv_catpvn(cat, space10, len);
2332 sv_catpvn(cat, null10, 10);
2335 sv_catpvn(cat, null10, len);
2347 str = SvPV(fromstr, fromlen);
2348 if (howlen == e_star)
2351 SvCUR(cat) += (len+7)/8;
2352 SvGROW(cat, SvCUR(cat) + 1);
2353 aptr = SvPVX(cat) + aint;
2354 if (len > (I32)fromlen)
2358 if (datumtype == 'B') {
2359 for (len = 0; len++ < aint;) {
2360 items |= *str++ & 1;
2364 *aptr++ = items & 0xff;
2370 for (len = 0; len++ < aint;) {
2376 *aptr++ = items & 0xff;
2382 if (datumtype == 'B')
2383 items <<= 7 - (aint & 7);
2385 items >>= 7 - (aint & 7);
2386 *aptr++ = items & 0xff;
2388 str = SvPVX(cat) + SvCUR(cat);
2403 str = SvPV(fromstr, fromlen);
2404 if (howlen == e_star)
2407 SvCUR(cat) += (len+1)/2;
2408 SvGROW(cat, SvCUR(cat) + 1);
2409 aptr = SvPVX(cat) + aint;
2410 if (len > (I32)fromlen)
2414 if (datumtype == 'H') {
2415 for (len = 0; len++ < aint;) {
2417 items |= ((*str++ & 15) + 9) & 15;
2419 items |= *str++ & 15;
2423 *aptr++ = items & 0xff;
2429 for (len = 0; len++ < aint;) {
2431 items |= (((*str++ & 15) + 9) & 15) << 4;
2433 items |= (*str++ & 15) << 4;
2437 *aptr++ = items & 0xff;
2443 *aptr++ = items & 0xff;
2444 str = SvPVX(cat) + SvCUR(cat);
2455 switch (TYPE_NO_MODIFIERS(datumtype)) {
2457 aint = SvIV(fromstr);
2458 if ((aint < 0 || aint > 255) &&
2460 Perl_warner(aTHX_ packWARN(WARN_PACK),
2461 "Character in 'C' format wrapped in pack");
2463 sv_catpvn(cat, &achar, sizeof(char));
2466 aint = SvIV(fromstr);
2467 if ((aint < -128 || aint > 127) &&
2469 Perl_warner(aTHX_ packWARN(WARN_PACK),
2470 "Character in 'c' format wrapped in pack" );
2472 sv_catpvn(cat, &achar, sizeof(char));
2480 auint = UNI_TO_NATIVE(SvUV(fromstr));
2481 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
2483 (char*)uvchr_to_utf8_flags((U8*)SvEND(cat),
2486 0 : UNICODE_ALLOW_ANY)
2491 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
2496 /* VOS does not automatically map a floating-point overflow
2497 during conversion from double to float into infinity, so we
2498 do it by hand. This code should either be generalized for
2499 any OS that needs it, or removed if and when VOS implements
2500 posix-976 (suggestion to support mapping to infinity).
2501 Paul.Green@stratus.com 02-04-02. */
2502 if (SvNV(fromstr) > FLT_MAX)
2503 afloat = _float_constants[0]; /* single prec. inf. */
2504 else if (SvNV(fromstr) < -FLT_MAX)
2505 afloat = _float_constants[0]; /* single prec. inf. */
2506 else afloat = (float)SvNV(fromstr);
2508 # if defined(VMS) && !defined(__IEEE_FP)
2509 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2510 * on Alpha; fake it if we don't have them.
2512 if (SvNV(fromstr) > FLT_MAX)
2514 else if (SvNV(fromstr) < -FLT_MAX)
2516 else afloat = (float)SvNV(fromstr);
2518 afloat = (float)SvNV(fromstr);
2521 DO_BO_PACK_N(afloat, float);
2522 sv_catpvn(cat, (char *)&afloat, sizeof (float));
2529 /* VOS does not automatically map a floating-point overflow
2530 during conversion from long double to double into infinity,
2531 so we do it by hand. This code should either be generalized
2532 for any OS that needs it, or removed if and when VOS
2533 implements posix-976 (suggestion to support mapping to
2534 infinity). Paul.Green@stratus.com 02-04-02. */
2535 if (SvNV(fromstr) > DBL_MAX)
2536 adouble = _double_constants[0]; /* double prec. inf. */
2537 else if (SvNV(fromstr) < -DBL_MAX)
2538 adouble = _double_constants[0]; /* double prec. inf. */
2539 else adouble = (double)SvNV(fromstr);
2541 # if defined(VMS) && !defined(__IEEE_FP)
2542 /* IEEE fp overflow shenanigans are unavailable on VAX and optional
2543 * on Alpha; fake it if we don't have them.
2545 if (SvNV(fromstr) > DBL_MAX)
2547 else if (SvNV(fromstr) < -DBL_MAX)
2549 else adouble = (double)SvNV(fromstr);
2551 adouble = (double)SvNV(fromstr);
2554 DO_BO_PACK_N(adouble, double);
2555 sv_catpvn(cat, (char *)&adouble, sizeof (double));
2559 Zero(&anv, 1, NV); /* can be long double with unused bits */
2562 anv = SvNV(fromstr);
2563 DO_BO_PACK_N(anv, NV);
2564 sv_catpvn(cat, (char *)&anv, NVSIZE);
2567 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
2569 /* long doubles can have unused bits, which may be nonzero */
2570 Zero(&aldouble, 1, long double);
2573 aldouble = (long double)SvNV(fromstr);
2574 DO_BO_PACK_N(aldouble, long double);
2575 sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE);
2579 case 'n' | TYPE_IS_SHRIEKING:
2583 ashort = (I16)SvIV(fromstr);
2585 ashort = PerlSock_htons(ashort);
2587 CAT16(cat, &ashort);
2590 case 'v' | TYPE_IS_SHRIEKING:
2594 ashort = (I16)SvIV(fromstr);
2596 ashort = htovs(ashort);
2598 CAT16(cat, &ashort);
2601 case 'S' | TYPE_IS_SHRIEKING:
2602 #if SHORTSIZE != SIZE16
2604 unsigned short aushort;
2608 aushort = SvUV(fromstr);
2609 DO_BO_PACK(aushort, s);
2610 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
2623 aushort = (U16)SvUV(fromstr);
2624 DO_BO_PACK(aushort, 16);
2625 CAT16(cat, &aushort);
2630 case 's' | TYPE_IS_SHRIEKING:
2631 #if SHORTSIZE != SIZE16
2637 ashort = SvIV(fromstr);
2638 DO_BO_PACK(ashort, s);
2639 sv_catpvn(cat, (char *)&ashort, sizeof(short));
2649 ashort = (I16)SvIV(fromstr);
2650 DO_BO_PACK(ashort, 16);
2651 CAT16(cat, &ashort);
2655 case 'I' | TYPE_IS_SHRIEKING:
2658 auint = SvUV(fromstr);
2659 DO_BO_PACK(auint, i);
2660 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
2666 aiv = SvIV(fromstr);
2667 #if IVSIZE == INTSIZE
2669 #elif IVSIZE == LONGSIZE
2671 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE
2672 DO_BO_PACK(aiv, 64);
2674 sv_catpvn(cat, (char*)&aiv, IVSIZE);
2680 auv = SvUV(fromstr);
2681 #if UVSIZE == INTSIZE
2683 #elif UVSIZE == LONGSIZE
2685 #elif defined(HAS_QUAD) && UVSIZE == U64SIZE
2686 DO_BO_PACK(auv, 64);
2688 sv_catpvn(cat, (char*)&auv, UVSIZE);
2694 anv = SvNV(fromstr);
2697 Perl_croak(aTHX_ "Cannot compress negative numbers in pack");
2699 /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0,
2700 which is == UV_MAX_P1. IOK is fine (instead of UV_only), as
2701 any negative IVs will have already been got by the croak()
2702 above. IOK is untrue for fractions, so we test them
2703 against UV_MAX_P1. */
2704 if (SvIOK(fromstr) || anv < UV_MAX_P1)
2706 char buf[(sizeof(UV)*8)/7+1];
2707 char *in = buf + sizeof(buf);
2708 UV auv = SvUV(fromstr);
2711 *--in = (char)((auv & 0x7f) | 0x80);
2714 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2715 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2717 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
2718 char *from, *result, *in;
2723 /* Copy string and check for compliance */
2724 from = SvPV(fromstr, len);
2725 if ((norm = is_an_int(from, len)) == NULL)
2726 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2728 New('w', result, len, char);
2732 *--in = div128(norm, &done) | 0x80;
2733 result[len - 1] &= 0x7F; /* clear continue bit */
2734 sv_catpvn(cat, in, (result + len) - in);
2736 SvREFCNT_dec(norm); /* free norm */
2738 else if (SvNOKp(fromstr)) {
2739 /* 10**NV_MAX_10_EXP is the largest power of 10
2740 so 10**(NV_MAX_10_EXP+1) is definately unrepresentable
2741 given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x:
2742 x = (NV_MAX_10_EXP+1) * log (10) / log (128)
2743 And with that many bytes only Inf can overflow.
2744 Some C compilers are strict about integral constant
2745 expressions so we conservatively divide by a slightly
2746 smaller integer instead of multiplying by the exact
2747 floating-point value.
2749 #ifdef NV_MAX_10_EXP
2750 /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */
2751 char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */
2753 /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */
2754 char buf[1 + (int)((308 + 1) / 2)]; /* valid C */
2756 char *in = buf + sizeof(buf);
2758 anv = Perl_floor(anv);
2760 NV next = Perl_floor(anv / 128);
2761 if (in <= buf) /* this cannot happen ;-) */
2762 Perl_croak(aTHX_ "Cannot compress integer in pack");
2763 *--in = (unsigned char)(anv - (next * 128)) | 0x80;
2766 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
2767 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
2770 char *from, *result, *in;
2775 /* Copy string and check for compliance */
2776 from = SvPV(fromstr, len);
2777 if ((norm = is_an_int(from, len)) == NULL)
2778 Perl_croak(aTHX_ "Can only compress unsigned integers in pack");
2780 New('w', result, len, char);
2784 *--in = div128(norm, &done) | 0x80;
2785 result[len - 1] &= 0x7F; /* clear continue bit */
2786 sv_catpvn(cat, in, (result + len) - in);
2788 SvREFCNT_dec(norm); /* free norm */
2793 case 'i' | TYPE_IS_SHRIEKING:
2796 aint = SvIV(fromstr);
2797 DO_BO_PACK(aint, i);
2798 sv_catpvn(cat, (char*)&aint, sizeof(int));
2801 case 'N' | TYPE_IS_SHRIEKING:
2805 aulong = SvUV(fromstr);
2807 aulong = PerlSock_htonl(aulong);
2809 CAT32(cat, &aulong);
2812 case 'V' | TYPE_IS_SHRIEKING:
2816 aulong = SvUV(fromstr);
2818 aulong = htovl(aulong);
2820 CAT32(cat, &aulong);
2823 case 'L' | TYPE_IS_SHRIEKING:
2824 #if LONGSIZE != SIZE32
2826 unsigned long aulong;
2830 aulong = SvUV(fromstr);
2831 DO_BO_PACK(aulong, l);
2832 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
2843 aulong = SvUV(fromstr);
2844 DO_BO_PACK(aulong, 32);
2845 CAT32(cat, &aulong);
2849 case 'l' | TYPE_IS_SHRIEKING:
2850 #if LONGSIZE != SIZE32
2856 along = SvIV(fromstr);
2857 DO_BO_PACK(along, l);
2858 sv_catpvn(cat, (char *)&along, sizeof(long));
2868 along = SvIV(fromstr);
2869 DO_BO_PACK(along, 32);
2877 auquad = (Uquad_t)SvUV(fromstr);
2878 DO_BO_PACK(auquad, 64);
2879 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
2885 aquad = (Quad_t)SvIV(fromstr);
2886 DO_BO_PACK(aquad, 64);
2887 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
2892 len = 1; /* assume SV is correct length */
2897 if (fromstr == &PL_sv_undef)
2901 /* XXX better yet, could spirit away the string to
2902 * a safe spot and hang on to it until the result
2903 * of pack() (and all copies of the result) are
2906 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
2907 || (SvPADTMP(fromstr)
2908 && !SvREADONLY(fromstr))))
2910 Perl_warner(aTHX_ packWARN(WARN_PACK),
2911 "Attempt to pack pointer to temporary value");
2913 if (SvPOK(fromstr) || SvNIOK(fromstr))
2914 aptr = SvPV(fromstr,n_a);
2916 aptr = SvPV_force(fromstr,n_a);
2919 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
2924 aptr = SvPV(fromstr, fromlen);
2925 SvGROW(cat, fromlen * 4 / 3);
2930 while (fromlen > 0) {
2933 if ((I32)fromlen > len)
2937 doencodes(cat, aptr, todo);
2943 *symptr = lookahead;
2952 dSP; dMARK; dORIGMARK; dTARGET;
2953 register SV *cat = TARG;
2955 register char *pat = SvPVx(*++MARK, fromlen);
2956 register char *patend = pat + fromlen;
2959 sv_setpvn(cat, "", 0);
2961 packlist(cat, pat, patend, MARK, SP + 1);