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