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