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