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 /* Types used by pack/unpack */ 35 typedef enum { 36 e_no_len, /* no length */ 37 e_number, /* number, [] */ 38 e_star /* asterisk */ 39 } howlen_t; 40 41 typedef struct tempsym { 42 const char* patptr; /* current template char */ 43 const char* patend; /* one after last char */ 44 const char* grpbeg; /* 1st char of ()-group */ 45 const char* grpend; /* end of ()-group */ 46 I32 code; /* template code (!<>) */ 47 I32 length; /* length/repeat count */ 48 howlen_t howlen; /* how length is given */ 49 int level; /* () nesting level */ 50 U32 flags; /* /=4, comma=2, pack=1 */ 51 /* and group modifiers */ 52 STRLEN strbeg; /* offset of group start */ 53 struct tempsym *previous; /* previous group */ 54 } tempsym_t; 55 56 #define TEMPSYM_INIT(symptr, p, e, f) \ 57 STMT_START { \ 58 (symptr)->patptr = (p); \ 59 (symptr)->patend = (e); \ 60 (symptr)->grpbeg = NULL; \ 61 (symptr)->grpend = NULL; \ 62 (symptr)->grpend = NULL; \ 63 (symptr)->code = 0; \ 64 (symptr)->length = 0; \ 65 (symptr)->howlen = 0; \ 66 (symptr)->level = 0; \ 67 (symptr)->flags = (f); \ 68 (symptr)->strbeg = 0; \ 69 (symptr)->previous = NULL; \ 70 } STMT_END 71 72 #if PERL_VERSION >= 9 73 # define PERL_PACK_CAN_BYTEORDER 74 # define PERL_PACK_CAN_SHRIEKSIGN 75 #endif 76 77 #ifndef CHAR_BIT 78 # define CHAR_BIT 8 79 #endif 80 /* Maximum number of bytes to which a byte can grow due to upgrade */ 81 #define UTF8_EXPAND 2 82 83 /* 84 * Offset for integer pack/unpack. 85 * 86 * On architectures where I16 and I32 aren't really 16 and 32 bits, 87 * which for now are all Crays, pack and unpack have to play games. 88 */ 89 90 /* 91 * These values are required for portability of pack() output. 92 * If they're not right on your machine, then pack() and unpack() 93 * wouldn't work right anyway; you'll need to apply the Cray hack. 94 * (I'd like to check them with #if, but you can't use sizeof() in 95 * the preprocessor.) --??? 96 */ 97 /* 98 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE 99 defines are now in config.h. --Andy Dougherty April 1998 100 */ 101 #define SIZE16 2 102 #define SIZE32 4 103 104 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). 105 --jhi Feb 1999 */ 106 107 #if U16SIZE > SIZE16 || U32SIZE > SIZE32 108 # if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 /* little-endian */ 109 # define OFF16(p) ((char*)(p)) 110 # define OFF32(p) ((char*)(p)) 111 # else 112 # if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321 /* big-endian */ 113 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) 114 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) 115 # else 116 ++++ bad cray byte order 117 # endif 118 # endif 119 #else 120 # define OFF16(p) ((char *) (p)) 121 # define OFF32(p) ((char *) (p)) 122 #endif 123 124 /* Only to be used inside a loop (see the break) */ 125 #define SHIFT16(utf8, s, strend, p, datumtype) STMT_START { \ 126 if (utf8) { \ 127 if (!uni_to_bytes(aTHX_ &(s), strend, OFF16(p), SIZE16, datumtype)) break; \ 128 } else { \ 129 Copy(s, OFF16(p), SIZE16, char); \ 130 (s) += SIZE16; \ 131 } \ 132 } STMT_END 133 134 /* Only to be used inside a loop (see the break) */ 135 #define SHIFT32(utf8, s, strend, p, datumtype) STMT_START { \ 136 if (utf8) { \ 137 if (!uni_to_bytes(aTHX_ &(s), strend, OFF32(p), SIZE32, datumtype)) break; \ 138 } else { \ 139 Copy(s, OFF32(p), SIZE32, char); \ 140 (s) += SIZE32; \ 141 } \ 142 } STMT_END 143 144 #define PUSH16(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF16(p), SIZE16) 145 #define PUSH32(utf8, cur, p) PUSH_BYTES(utf8, cur, OFF32(p), SIZE32) 146 147 /* Only to be used inside a loop (see the break) */ 148 #define SHIFT_VAR(utf8, s, strend, var, datumtype) \ 149 STMT_START { \ 150 if (utf8) { \ 151 if (!uni_to_bytes(aTHX_ &s, strend, \ 152 (char *) &var, sizeof(var), datumtype)) break;\ 153 } else { \ 154 Copy(s, (char *) &var, sizeof(var), char); \ 155 s += sizeof(var); \ 156 } \ 157 } STMT_END 158 159 #define PUSH_VAR(utf8, aptr, var) \ 160 PUSH_BYTES(utf8, aptr, &(var), sizeof(var)) 161 162 /* Avoid stack overflow due to pathological templates. 100 should be plenty. */ 163 #define MAX_SUB_TEMPLATE_LEVEL 100 164 165 /* flags (note that type modifiers can also be used as flags!) */ 166 #define FLAG_WAS_UTF8 0x40 167 #define FLAG_PARSE_UTF8 0x20 /* Parse as utf8 */ 168 #define FLAG_UNPACK_ONLY_ONE 0x10 169 #define FLAG_DO_UTF8 0x08 /* The underlying string is utf8 */ 170 #define FLAG_SLASH 0x04 171 #define FLAG_COMMA 0x02 172 #define FLAG_PACK 0x01 173 174 STATIC SV * 175 S_mul128(pTHX_ SV *sv, U8 m) 176 185 { 177 185 STRLEN len; 178 185 char *s = SvPV(sv, len); 179 185 char *t; 180 181 185 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ 182 47 SV *tmpNew = newSVpvn("0000000000", 10); 183 184 47 sv_catsv(tmpNew, sv); 185 47 SvREFCNT_dec(sv); /* free old sv */ 186 47 sv = tmpNew; 187 47 s = SvPV(sv, len); 188 } 189 185 t = s + len - 1; 190 185 while (!*t) /* trailing '\0'? */ 191 ###### t--; 192 24580 while (t > s) { 193 24395 const U32 i = ((*t - '0') << 7) + m; 194 24395 *(t--) = '0' + (char)(i % 10); 195 24395 m = (char)(i / 10); 196 } 197 185 return (sv); 198 } 199 200 /* Explosives and implosives. */ 201 202 #if 'I' == 73 && 'J' == 74 203 /* On an ASCII/ISO kind of system */ 204 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') 205 #else 206 /* 207 Some other sort of character set - use memchr() so we don't match 208 the null byte. 209 */ 210 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') 211 #endif 212 213 /* type modifiers */ 214 #define TYPE_IS_SHRIEKING 0x100 215 #define TYPE_IS_BIG_ENDIAN 0x200 216 #define TYPE_IS_LITTLE_ENDIAN 0x400 217 #define TYPE_IS_PACK 0x800 218 #define TYPE_ENDIANNESS_MASK (TYPE_IS_BIG_ENDIAN|TYPE_IS_LITTLE_ENDIAN) 219 #define TYPE_MODIFIERS(t) ((t) & ~0xFF) 220 #define TYPE_NO_MODIFIERS(t) ((t) & 0xFF) 221 222 #ifdef PERL_PACK_CAN_SHRIEKSIGN 223 # define SHRIEKING_ALLOWED_TYPES "sSiIlLxXnNvV@." 224 #else 225 # define SHRIEKING_ALLOWED_TYPES "sSiIlLxX" 226 #endif 227 228 #ifndef PERL_PACK_CAN_BYTEORDER 229 /* Put "can't" first because it is shorter */ 230 # define TYPE_ENDIANNESS(t) 0 231 # define TYPE_NO_ENDIANNESS(t) (t) 232 233 # define ENDIANNESS_ALLOWED_TYPES "" 234 235 # define DO_BO_UNPACK(var, type) 236 # define DO_BO_PACK(var, type) 237 # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) 238 # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) 239 # define DO_BO_UNPACK_N(var, type) 240 # define DO_BO_PACK_N(var, type) 241 # define DO_BO_UNPACK_P(var) 242 # define DO_BO_PACK_P(var) 243 244 #else /* PERL_PACK_CAN_BYTEORDER */ 245 246 # define TYPE_ENDIANNESS(t) ((t) & TYPE_ENDIANNESS_MASK) 247 # define TYPE_NO_ENDIANNESS(t) ((t) & ~TYPE_ENDIANNESS_MASK) 248 249 # define ENDIANNESS_ALLOWED_TYPES "sSiIlLqQjJfFdDpP(" 250 251 # define DO_BO_UNPACK(var, type) \ 252 STMT_START { \ 253 switch (TYPE_ENDIANNESS(datumtype)) { \ 254 case TYPE_IS_BIG_ENDIAN: var = my_betoh ## type (var); break; \ 255 case TYPE_IS_LITTLE_ENDIAN: var = my_letoh ## type (var); break; \ 256 default: break; \ 257 } \ 258 } STMT_END 259 260 # define DO_BO_PACK(var, type) \ 261 STMT_START { \ 262 switch (TYPE_ENDIANNESS(datumtype)) { \ 263 case TYPE_IS_BIG_ENDIAN: var = my_htobe ## type (var); break; \ 264 case TYPE_IS_LITTLE_ENDIAN: var = my_htole ## type (var); break; \ 265 default: break; \ 266 } \ 267 } STMT_END 268 269 # define DO_BO_UNPACK_PTR(var, type, pre_cast, post_cast) \ 270 STMT_START { \ 271 switch (TYPE_ENDIANNESS(datumtype)) { \ 272 case TYPE_IS_BIG_ENDIAN: \ 273 var = (post_cast*) my_betoh ## type ((pre_cast) var); \ 274 break; \ 275 case TYPE_IS_LITTLE_ENDIAN: \ 276 var = (post_cast *) my_letoh ## type ((pre_cast) var); \ 277 break; \ 278 default: \ 279 break; \ 280 } \ 281 } STMT_END 282 283 # define DO_BO_PACK_PTR(var, type, pre_cast, post_cast) \ 284 STMT_START { \ 285 switch (TYPE_ENDIANNESS(datumtype)) { \ 286 case TYPE_IS_BIG_ENDIAN: \ 287 var = (post_cast *) my_htobe ## type ((pre_cast) var); \ 288 break; \ 289 case TYPE_IS_LITTLE_ENDIAN: \ 290 var = (post_cast *) my_htole ## type ((pre_cast) var); \ 291 break; \ 292 default: \ 293 break; \ 294 } \ 295 } STMT_END 296 297 # define BO_CANT_DOIT(action, type) \ 298 STMT_START { \ 299 switch (TYPE_ENDIANNESS(datumtype)) { \ 300 case TYPE_IS_BIG_ENDIAN: \ 301 Perl_croak(aTHX_ "Can't %s big-endian %ss on this " \ 302 "platform", #action, #type); \ 303 break; \ 304 case TYPE_IS_LITTLE_ENDIAN: \ 305 Perl_croak(aTHX_ "Can't %s little-endian %ss on this " \ 306 "platform", #action, #type); \ 307 break; \ 308 default: \ 309 break; \ 310 } \ 311 } STMT_END 312 313 # if PTRSIZE == INTSIZE 314 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, i, int, void) 315 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, i, int, void) 316 # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, i, int, char) 317 # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, i, int, char) 318 # elif PTRSIZE == LONGSIZE 319 # define DO_BO_UNPACK_P(var) DO_BO_UNPACK_PTR(var, l, long, void) 320 # define DO_BO_PACK_P(var) DO_BO_PACK_PTR(var, l, long, void) 321 # define DO_BO_UNPACK_PC(var) DO_BO_UNPACK_PTR(var, l, long, char) 322 # define DO_BO_PACK_PC(var) DO_BO_PACK_PTR(var, l, long, char) 323 # else 324 # define DO_BO_UNPACK_P(var) BO_CANT_DOIT(unpack, pointer) 325 # define DO_BO_PACK_P(var) BO_CANT_DOIT(pack, pointer) 326 # endif 327 328 # if defined(my_htolen) && defined(my_letohn) && \ 329 defined(my_htoben) && defined(my_betohn) 330 # define DO_BO_UNPACK_N(var, type) \ 331 STMT_START { \ 332 switch (TYPE_ENDIANNESS(datumtype)) { \ 333 case TYPE_IS_BIG_ENDIAN: my_betohn(&var, sizeof(type)); break;\ 334 case TYPE_IS_LITTLE_ENDIAN: my_letohn(&var, sizeof(type)); break;\ 335 default: break; \ 336 } \ 337 } STMT_END 338 339 # define DO_BO_PACK_N(var, type) \ 340 STMT_START { \ 341 switch (TYPE_ENDIANNESS(datumtype)) { \ 342 case TYPE_IS_BIG_ENDIAN: my_htoben(&var, sizeof(type)); break;\ 343 case TYPE_IS_LITTLE_ENDIAN: my_htolen(&var, sizeof(type)); break;\ 344 default: break; \ 345 } \ 346 } STMT_END 347 # else 348 # define DO_BO_UNPACK_N(var, type) BO_CANT_DOIT(unpack, type) 349 # define DO_BO_PACK_N(var, type) BO_CANT_DOIT(pack, type) 350 # endif 351 352 #endif /* PERL_PACK_CAN_BYTEORDER */ 353 354 #define PACK_SIZE_CANNOT_CSUM 0x80 355 #define PACK_SIZE_UNPREDICTABLE 0x40 /* Not a fixed size element */ 356 #define PACK_SIZE_MASK 0x3F 357 358 /* These tables are regenerated by genpacksizetables.pl (and then hand pasted 359 in). You're unlikely ever to need to regenerate them. */ 360 361 #if TYPE_IS_SHRIEKING != 0x100 362 ++++shriek offset should be 256 363 #endif 364 365 typedef U8 packprops_t; 366 #if 'J'-'I' == 1 367 /* ASCII */ 368 const packprops_t packprops[512] = { 369 /* normal */ 370 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 371 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 372 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 373 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 374 0, 0, 0, 375 /* C */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, 376 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 377 /* D */ LONG_DOUBLESIZE, 378 #else 379 0, 380 #endif 381 0, 382 /* F */ NVSIZE, 383 0, 0, 384 /* I */ sizeof(unsigned int), 385 /* J */ UVSIZE, 386 0, 387 /* L */ SIZE32, 388 0, 389 /* N */ SIZE32, 390 0, 0, 391 #if defined(HAS_QUAD) 392 /* Q */ sizeof(Uquad_t), 393 #else 394 0, 395 #endif 396 0, 397 /* S */ SIZE16, 398 0, 399 /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE, 400 /* V */ SIZE32, 401 /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, 402 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 403 /* c */ sizeof(char), 404 /* d */ sizeof(double), 405 0, 406 /* f */ sizeof(float), 407 0, 0, 408 /* i */ sizeof(int), 409 /* j */ IVSIZE, 410 0, 411 /* l */ SIZE32, 412 0, 413 /* n */ SIZE16, 414 0, 415 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM, 416 #if defined(HAS_QUAD) 417 /* q */ sizeof(Quad_t), 418 #else 419 0, 420 #endif 421 0, 422 /* s */ SIZE16, 423 0, 0, 424 /* v */ SIZE16, 425 /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM, 426 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 427 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 428 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 429 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 430 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 431 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 432 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 433 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 434 0, 0, 0, 0, 0, 0, 0, 0, 435 /* shrieking */ 436 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 437 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 438 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 439 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 440 0, 0, 0, 0, 0, 0, 0, 0, 0, 441 /* I */ sizeof(unsigned int), 442 0, 0, 443 /* L */ sizeof(unsigned long), 444 0, 445 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 446 /* N */ SIZE32, 447 #else 448 0, 449 #endif 450 0, 0, 0, 0, 451 /* S */ sizeof(unsigned short), 452 0, 0, 453 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 454 /* V */ SIZE32, 455 #else 456 0, 457 #endif 458 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 459 0, 0, 460 /* i */ sizeof(int), 461 0, 0, 462 /* l */ sizeof(long), 463 0, 464 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 465 /* n */ SIZE16, 466 #else 467 0, 468 #endif 469 0, 0, 0, 0, 470 /* s */ sizeof(short), 471 0, 0, 472 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 473 /* v */ SIZE16, 474 #else 475 0, 476 #endif 477 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 478 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 479 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 480 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 481 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 482 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 483 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 484 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 485 0, 0, 0, 0, 0, 0, 0, 0, 0 486 }; 487 #else 488 /* EBCDIC (or bust) */ 489 const packprops_t packprops[512] = { 490 /* normal */ 491 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 492 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 493 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 494 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 495 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 496 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 497 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 498 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 499 0, 0, 0, 500 /* c */ sizeof(char), 501 /* d */ sizeof(double), 502 0, 503 /* f */ sizeof(float), 504 0, 0, 505 /* i */ sizeof(int), 506 0, 0, 0, 0, 0, 0, 0, 507 /* j */ IVSIZE, 508 0, 509 /* l */ SIZE32, 510 0, 511 /* n */ SIZE16, 512 0, 513 /* p */ sizeof(char *) | PACK_SIZE_CANNOT_CSUM, 514 #if defined(HAS_QUAD) 515 /* q */ sizeof(Quad_t), 516 #else 517 0, 518 #endif 519 0, 0, 0, 0, 0, 0, 0, 0, 0, 520 /* s */ SIZE16, 521 0, 0, 522 /* v */ SIZE16, 523 /* w */ sizeof(char) | PACK_SIZE_UNPREDICTABLE | PACK_SIZE_CANNOT_CSUM, 524 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 525 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 526 /* C */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, 527 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 528 /* D */ LONG_DOUBLESIZE, 529 #else 530 0, 531 #endif 532 0, 533 /* F */ NVSIZE, 534 0, 0, 535 /* I */ sizeof(unsigned int), 536 0, 0, 0, 0, 0, 0, 0, 537 /* J */ UVSIZE, 538 0, 539 /* L */ SIZE32, 540 0, 541 /* N */ SIZE32, 542 0, 0, 543 #if defined(HAS_QUAD) 544 /* Q */ sizeof(Uquad_t), 545 #else 546 0, 547 #endif 548 0, 0, 0, 0, 0, 0, 0, 0, 0, 549 /* S */ SIZE16, 550 0, 551 /* U */ sizeof(char) | PACK_SIZE_UNPREDICTABLE, 552 /* V */ SIZE32, 553 /* W */ sizeof(unsigned char) | PACK_SIZE_UNPREDICTABLE, 554 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 555 0, 0, 0, 0, 0, 0, 0, 0, 0, 556 /* shrieking */ 557 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 558 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 559 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 560 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 561 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 562 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 563 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 564 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 565 0, 0, 0, 0, 0, 0, 0, 0, 0, 566 /* i */ sizeof(int), 567 0, 0, 0, 0, 0, 0, 0, 0, 0, 568 /* l */ sizeof(long), 569 0, 570 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 571 /* n */ SIZE16, 572 #else 573 0, 574 #endif 575 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 576 /* s */ sizeof(short), 577 0, 0, 578 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 579 /* v */ SIZE16, 580 #else 581 0, 582 #endif 583 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 584 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 585 0, 0, 0, 586 /* I */ sizeof(unsigned int), 587 0, 0, 0, 0, 0, 0, 0, 0, 0, 588 /* L */ sizeof(unsigned long), 589 0, 590 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 591 /* N */ SIZE32, 592 #else 593 0, 594 #endif 595 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 596 /* S */ sizeof(unsigned short), 597 0, 0, 598 #if defined(PERL_PACK_CAN_SHRIEKSIGN) 599 /* V */ SIZE32, 600 #else 601 0, 602 #endif 603 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 604 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 605 }; 606 #endif 607 608 STATIC U8 609 uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) 610 22 { 611 22 UV val; 612 22 STRLEN retlen; 613 22 val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, 614 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 615 /* We try to process malformed UTF-8 as much as possible (preferrably with 616 warnings), but these two mean we make no progress in the string and 617 might enter an infinite loop */ 618 22 if (retlen == (STRLEN) -1 || retlen == 0) 619 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack", 620 (int) TYPE_NO_MODIFIERS(datumtype)); 621 22 if (val >= 0x100) { 622 ###### if (ckWARN(WARN_UNPACK)) 623 ###### Perl_warner(aTHX_ packWARN(WARN_UNPACK), 624 "Character in '%c' format wrapped in unpack", 625 (int) TYPE_NO_MODIFIERS(datumtype)); 626 ###### val &= 0xff; 627 } 628 22 *s += retlen; 629 22 return (U8)val; 630 } 631 632 #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \ 633 uni_to_byte(aTHX_ &(s), (strend), (datumtype)) : \ 634 *(U8 *)(s)++) 635 636 STATIC bool 637 uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len, I32 datumtype) 638 308 { 639 308 UV val; 640 308 STRLEN retlen; 641 308 const char *from = *s; 642 308 int bad = 0; 643 308 const U32 flags = ckWARN(WARN_UTF8) ? 644 308 UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY); 645 2406 for (;buf_len > 0; buf_len--) { 646 1049 if (from >= end) return FALSE; 647 1049 val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags); 648 1049 if (retlen == (STRLEN) -1 || retlen == 0) { 649 ###### from += UTF8SKIP(from); 650 ###### bad |= 1; 651 1049 } else from += retlen; 652 1049 if (val >= 0x100) { 653 ###### bad |= 2; 654 ###### val &= 0xff; 655 } 656 1049 *(U8 *)buf++ = (U8)val; 657 } 658 /* We have enough characters for the buffer. Did we have problems ? */ 659 308 if (bad) { 660 ###### if (bad & 1) { 661 /* Rewalk the string fragment while warning */ 662 ###### const char *ptr; 663 ###### const int flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; 664 ###### for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) { 665 ###### if (ptr >= end) break; 666 ###### utf8n_to_uvuni((U8 *) ptr, end-ptr, &retlen, flags); 667 } 668 ###### if (from > end) from = end; 669 } 670 ###### if ((bad & 2) && ckWARN(WARN_UNPACK)) 671 ###### Perl_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? 672 WARN_PACK : WARN_UNPACK), 673 "Character(s) in '%c' format wrapped in %s", 674 (int) TYPE_NO_MODIFIERS(datumtype), 675 datumtype & TYPE_IS_PACK ? "pack" : "unpack"); 676 } 677 308 *s = from; 678 308 return TRUE; 679 } 680 681 STATIC bool 682 next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) 683 18 { 684 18 UV val; 685 18 STRLEN retlen; 686 18 val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); 687 18 if (val >= 0x100 || !ISUUCHAR(val) || 688 retlen == (STRLEN) -1 || retlen == 0) { 689 1 *out = 0; 690 1 return FALSE; 691 } 692 17 *out = PL_uudmap[val] & 077; 693 17 *s += retlen; 694 17 return TRUE; 695 } 696 697 STATIC void 698 292 bytes_to_uni(pTHX_ const U8 *start, STRLEN len, char **dest) { 699 292 U8 buffer[UTF8_MAXLEN]; 700 292 const U8 *end = start + len; 701 292 char *d = *dest; 702 1363 while (start < end) { 703 1071 const int length = 704 1071 uvuni_to_utf8_flags(buffer, NATIVE_TO_UNI(*start), 0) - buffer; 705 1071 switch(length) { 706 case 1: 707 834 *d++ = buffer[0]; 708 834 break; 709 case 2: 710 237 *d++ = buffer[0]; 711 237 *d++ = buffer[1]; 712 237 break; 713 default: 714 ###### Perl_croak(aTHX_ "Perl bug: value %d UTF-8 expands to %d bytes", 715 *start, length); 716 } 717 1071 start++; 718 } 719 292 *dest = d; 720 } 721 722 #define PUSH_BYTES(utf8, cur, buf, len) \ 723 STMT_START { \ 724 if (utf8) bytes_to_uni(aTHX_ (U8 *) buf, len, &(cur)); \ 725 else { \ 726 Copy(buf, cur, len, char); \ 727 (cur) += (len); \ 728 } \ 729 } STMT_END 730 731 #define GROWING(utf8, cat, start, cur, in_len) \ 732 STMT_START { \ 733 STRLEN glen = (in_len); \ 734 if (utf8) glen *= UTF8_EXPAND; \ 735 if ((cur) + glen >= (start) + SvLEN(cat)) { \ 736 (start) = sv_exp_grow(aTHX_ cat, glen); \ 737 (cur) = (start) + SvCUR(cat); \ 738 } \ 739 } STMT_END 740 741 #define PUSH_GROWING_BYTES(utf8, cat, start, cur, buf, in_len) \ 742 STMT_START { \ 743 const STRLEN glen = (in_len); \ 744 STRLEN gl = glen; \ 745 if (utf8) gl *= UTF8_EXPAND; \ 746 if ((cur) + gl >= (start) + SvLEN(cat)) { \ 747 *cur = '\0'; \ 748 SvCUR_set((cat), (cur) - (start)); \ 749 (start) = sv_exp_grow(aTHX_ cat, gl); \ 750 (cur) = (start) + SvCUR(cat); \ 751 } \ 752 PUSH_BYTES(utf8, cur, buf, glen); \ 753 } STMT_END 754 755 #define PUSH_BYTE(utf8, s, byte) \ 756 STMT_START { \ 757 if (utf8) { \ 758 const U8 au8 = (byte); \ 759 bytes_to_uni(aTHX_ &au8, 1, &(s)); \ 760 } else *(U8 *)(s)++ = (byte); \ 761 } STMT_END 762 763 /* Only to be used inside a loop (see the break) */ 764 #define NEXT_UNI_VAL(val, cur, str, end, utf8_flags) \ 765 STMT_START { \ 766 STRLEN retlen; \ 767 if (str >= end) break; \ 768 val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \ 769 if (retlen == (STRLEN) -1 || retlen == 0) { \ 770 *cur = '\0'; \ 771 Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \ 772 } \ 773 str += retlen; \ 774 } STMT_END 775 776 static const char *_action( const tempsym_t* symptr ) 777 135 { 778 135 return ( symptr->flags & FLAG_PACK ) ? "pack" : "unpack"; 779 } 780 781 /* Returns the sizeof() struct described by pat */ 782 STATIC I32 783 S_measure_struct(pTHX_ tempsym_t* symptr) 784 7335 { 785 7335 I32 total = 0; 786 787 18323 while (next_symbol(symptr)) { 788 10989 I32 len; 789 10989 int size; 790 791 10989 switch (symptr->howlen) { 792 case e_star: 793 ###### Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", 794 _action( symptr ) ); 795 10989 break; 796 default: 797 /* e_no_len and e_number */ 798 10989 len = symptr->length; 799 10989 break; 800 } 801 802 10989 size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK; 803 10989 if (!size) { 804 7159 int star; 805 /* endianness doesn't influence the size of a type */ 806 7159 switch(TYPE_NO_ENDIANNESS(symptr->code)) { 807 default: 808 ###### Perl_croak(aTHX_ "Invalid type '%c' in %s", 809 (int)TYPE_NO_MODIFIERS(symptr->code), 810 _action( symptr ) ); 811 #ifdef PERL_PACK_CAN_SHRIEKSIGN 812 case '.' | TYPE_IS_SHRIEKING: 813 case '@' | TYPE_IS_SHRIEKING: 814 #endif 815 case '@': 816 case '.': 817 case '/': 818 case 'U': /* XXXX Is it correct? */ 819 case 'w': 820 case 'u': 821 1 Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s", 822 (int) TYPE_NO_MODIFIERS(symptr->code), 823 _action( symptr ) ); 824 case '%': 825 ###### size = 0; 826 ###### break; 827 case '(': 828 { 829 2916 tempsym_t savsym = *symptr; 830 2916 symptr->patptr = savsym.grpbeg; 831 2916 symptr->patend = savsym.grpend; 832 /* XXXX Theoretically, we need to measure many times at 833 different positions, since the subexpression may contain 834 alignment commands, but be not of aligned length. 835 Need to detect this and croak(). */ 836 2916 size = measure_struct(symptr); 837 2916 *symptr = savsym; 838 2916 break; 839 } 840 case 'X' | TYPE_IS_SHRIEKING: 841 /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. 842 */ 843 729 if (!len) /* Avoid division by 0 */ 844 13 len = 1; 845 729 len = total % len; /* Assumed: the start is aligned. */ 846 /* FALL THROUGH */ 847 case 'X': 848 1458 size = -1; 849 1458 if (total < len) 850 ###### Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) ); 851 732 break; 852 case 'x' | TYPE_IS_SHRIEKING: 853 732 if (!len) /* Avoid division by 0 */ 854 ###### len = 1; 855 732 star = total % len; /* Assumed: the start is aligned. */ 856 732 if (star) /* Other portable ways? */ 857 312 len = len - star; 858 else 859 420 len = 0; 860 /* FALL THROUGH */ 861 case 'x': 862 case 'A': 863 case 'Z': 864 case 'a': 865 2406 size = 1; 866 2406 break; 867 case 'B': 868 case 'b': 869 108 len = (len + 7)/8; 870 108 size = 1; 871 108 break; 872 case 'H': 873 case 'h': 874 108 len = (len + 1)/2; 875 108 size = 1; 876 108 break; 877 878 case 'P': 879 162 len = 1; 880 162 size = sizeof(char*); 881 10988 break; 882 } 883 } 884 10988 total += len * size; 885 } 886 7334 return total; 887 } 888 889 890 /* locate matching closing parenthesis or bracket 891 * returns char pointer to char after match, or NULL 892 */ 893 STATIC const char * 894 S_group_end(pTHX_ register const char *patptr, register const char *patend, char ender) 895 35541 { 896 137398 while (patptr < patend) { 897 137398 const char c = *patptr++; 898 899 137398 if (isSPACE(c)) 900 111587 continue; 901 111587 else if (c == ender) 902 35541 return patptr-1; 903 76046 else if (c == '#') { 904 ###### while (patptr < patend && *patptr != '\n') 905 ###### patptr++; 906 76046 continue; 907 76046 } else if (c == '(') 908 8449 patptr = group_end(patptr, patend, ')') + 1; 909 67597 else if (c == '[') 910 5052 patptr = group_end(patptr, patend, ']') + 1; 911 } 912 ###### Perl_croak(aTHX_ "No group ending character '%c' found in template", 913 ender); 914 35541 return 0; 915 } 916 917 918 /* Convert unsigned decimal number to binary. 919 * Expects a pointer to the first digit and address of length variable 920 * Advances char pointer to 1st non-digit char and returns number 921 */ 922 STATIC const char * 923 S_get_num(pTHX_ register const char *patptr, I32 *lenptr ) 924 162505 { 925 162505 I32 len = *patptr++ - '0'; 926 175415 while (isDIGIT(*patptr)) { 927 12910 if (len >= 0x7FFFFFFF/10) 928 ###### Perl_croak(aTHX_ "pack/unpack repeat count overflow"); 929 12910 len = (len * 10) + (*patptr++ - '0'); 930 } 931 162505 *lenptr = len; 932 162505 return patptr; 933 } 934 935 /* The marvellous template parsing routine: Using state stored in *symptr, 936 * locates next template code and count 937 */ 938 STATIC bool 939 S_next_symbol(pTHX_ tempsym_t* symptr ) 940 449735 { 941 449735 const char* patptr = symptr->patptr; 942 449735 const char* patend = symptr->patend; 943 944 449735 symptr->flags &= ~FLAG_SLASH; 945 946 472874 while (patptr < patend) { 947 325843 if (isSPACE(*patptr)) 948 23120 patptr++; 949 302723 else if (*patptr == '#') { 950 12 patptr++; 951 184 while (patptr < patend && *patptr != '\n') 952 172 patptr++; 953 12 if (patptr < patend) 954 12 patptr++; 955 } else { 956 /* We should have found a template code */ 957 302711 I32 code = *patptr++ & 0xFF; 958 302711 U32 inherited_modifiers = 0; 959 960 302711 if (code == ','){ /* grandfather in commas but with a warning */ 961 7 if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){ 962 4 symptr->flags |= FLAG_COMMA; 963 4 Perl_warner(aTHX_ packWARN(WARN_UNPACK), 964 "Invalid type ',' in %s", _action( symptr ) ); 965 } 966 4 continue; 967 } 968 969 /* for '(', skip to ')' */ 970 302704 if (code == '(') { 971 6749 if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' ) 972 4 Perl_croak(aTHX_ "()-group starts with a count in %s", 973 _action( symptr ) ); 974 6745 symptr->grpbeg = patptr; 975 6745 patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') ); 976 6745 if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL ) 977 1 Perl_croak(aTHX_ "Too deeply nested ()-groups in %s", 978 _action( symptr ) ); 979 } 980 981 /* look for group modifiers to inherit */ 982 302699 if (TYPE_ENDIANNESS(symptr->flags)) { 983 296 if (strchr(ENDIANNESS_ALLOWED_TYPES, TYPE_NO_MODIFIERS(code))) 984 268 inherited_modifiers |= TYPE_ENDIANNESS(symptr->flags); 985 } 986 987 /* look for modifiers */ 988 327503 while (patptr < patend) { 989 297809 const char *allowed; 990 297809 I32 modifier; 991 297809 switch (*patptr) { 992 case '!': 993 10002 modifier = TYPE_IS_SHRIEKING; 994 10002 allowed = SHRIEKING_ALLOWED_TYPES; 995 10002 break; 996 #ifdef PERL_PACK_CAN_BYTEORDER 997 case '>': 998 7458 modifier = TYPE_IS_BIG_ENDIAN; 999 7458 allowed = ENDIANNESS_ALLOWED_TYPES; 1000 7458 break; 1001 case '<': 1002 7460 modifier = TYPE_IS_LITTLE_ENDIAN; 1003 7460 allowed = ENDIANNESS_ALLOWED_TYPES; 1004 7460 break; 1005 #endif /* PERL_PACK_CAN_BYTEORDER */ 1006 default: 1007 272889 allowed = ""; 1008 272889 modifier = 0; 1009 297809 break; 1010 } 1011 1012 297809 if (modifier == 0) 1013 272889 break; 1014 1015 24920 if (!strchr(allowed, TYPE_NO_MODIFIERS(code))) 1016 94 Perl_croak(aTHX_ "'%c' allowed only after types %s in %s", *patptr, 1017 allowed, _action( symptr ) ); 1018 1019 24826 if (TYPE_ENDIANNESS(code | modifier) == TYPE_ENDIANNESS_MASK) 1020 16 Perl_croak(aTHX_ "Can't use both '<' and '>' after type '%c' in %s", 1021 (int) TYPE_NO_MODIFIERS(code), _action( symptr ) ); 1022 24810 else if (TYPE_ENDIANNESS(code | modifier | inherited_modifiers) == 1023 TYPE_ENDIANNESS_MASK) 1024 6 Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s", 1025 *patptr, _action( symptr ) ); 1026 1027 24804 if (ckWARN(WARN_UNPACK)) { 1028 24348 if (code & modifier) 1029 5 Perl_warner(aTHX_ packWARN(WARN_UNPACK), 1030 "Duplicate modifier '%c' after '%c' in %s", 1031 *patptr, (int) TYPE_NO_MODIFIERS(code), 1032 _action( symptr ) ); 1033 } 1034 1035 24804 code |= modifier; 1036 24804 patptr++; 1037 } 1038 1039 /* inherit modifiers */ 1040 302583 code |= inherited_modifiers; 1041 1042 /* look for count and/or / */ 1043 302583 if (patptr < patend) { 1044 272889 if (isDIGIT(*patptr)) { 1045 151629 patptr = get_num( patptr, &symptr->length ); 1046 151629 symptr->howlen = e_number; 1047 1048 121260 } else if (*patptr == '*') { 1049 37235 patptr++; 1050 37235 symptr->howlen = e_star; 1051 1052 84025 } else if (*patptr == '[') { 1053 15295 const char* lenptr = ++patptr; 1054 15295 symptr->howlen = e_number; 1055 15295 patptr = group_end( patptr, patend, ']' ) + 1; 1056 /* what kind of [] is it? */ 1057 15295 if (isDIGIT(*lenptr)) { 1058 10876 lenptr = get_num( lenptr, &symptr->length ); 1059 10876 if( *lenptr != ']' ) 1060 1 Perl_croak(aTHX_ "Malformed integer in [] in %s", 1061 _action( symptr ) ); 1062 } else { 1063 4419 tempsym_t savsym = *symptr; 1064 4419 symptr->patend = patptr-1; 1065 4419 symptr->patptr = lenptr; 1066 4419 savsym.length = measure_struct(symptr); 1067 4418 *symptr = savsym; 1068 } 1069 } else { 1070 68730 symptr->howlen = e_no_len; 1071 68730 symptr->length = 1; 1072 } 1073 1074 /* try to find / */ 1075 316610 while (patptr < patend) { 1076 199258 if (isSPACE(*patptr)) 1077 43709 patptr++; 1078 155549 else if (*patptr == '#') { 1079 14 patptr++; 1080 156 while (patptr < patend && *patptr != '\n') 1081 142 patptr++; 1082 14 if (patptr < patend) 1083 6 patptr++; 1084 } else { 1085 155535 if (*patptr == '/') { 1086 239 symptr->flags |= FLAG_SLASH; 1087 239 patptr++; 1088 239 if (patptr < patend && 1089 (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[')) 1090 3 Perl_croak(aTHX_ "'/' does not take a repeat count in %s", 1091 _action( symptr ) ); 1092 } 1093 29694 break; 1094 } 1095 } 1096 } else { 1097 /* at end - no count, no / */ 1098 29694 symptr->howlen = e_no_len; 1099 29694 symptr->length = 1; 1100 } 1101 1102 302578 symptr->code = code; 1103 302578 symptr->patptr = patptr; 1104 302578 return TRUE; 1105 } 1106 } 1107 147031 symptr->patptr = patptr; 1108 147031 return FALSE; 1109 } 1110 1111 /* 1112 There is no way to cleanly handle the case where we should process the 1113 string per byte in its upgraded form while it's really in downgraded form 1114 (e.g. estimates like strend-s as an upper bound for the number of 1115 characters left wouldn't work). So if we foresee the need of this 1116 (pattern starts with U or contains U0), we want to work on the encoded 1117 version of the string. Users are advised to upgrade their pack string 1118 themselves if they need to do a lot of unpacks like this on it 1119 */ 1120 /* XXX These can be const */ 1121 STATIC bool 1122 need_utf8(const char *pat, const char *patend) 1123 37501 { 1124 37501 bool first = TRUE; 1125 347625 while (pat < patend) { 1126 310365 if (pat[0] == '#') { 1127 26 pat++; 1128 26 pat = (const char *) memchr(pat, '\n', patend-pat); 1129 26 if (!pat) return FALSE; 1130 310339 } else if (pat[0] == 'U') { 1131 442 if (first || pat[1] == '0') return TRUE; 1132 309897 } else first = FALSE; 1133 310124 pat++; 1134 } 1135 37260 return FALSE; 1136 } 1137 1138 STATIC char 1139 50207 first_symbol(const char *pat, const char *patend) { 1140 50215 while (pat < patend) { 1141 50214 if (pat[0] != '#') return pat[0]; 1142 8 pat++; 1143 8 pat = (const char *) memchr(pat, '\n', patend-pat); 1144 8 if (!pat) return 0; 1145 8 pat++; 1146 } 1147 1 return 0; 1148 } 1149 1150 /* 1151 =for apidoc unpack_str 1152 1153 The engine implementing unpack() Perl function. Note: parameters strbeg, new_s 1154 and ocnt are not used. This call should not be used, use unpackstring instead. 1155 1156 =cut */ 1157 1158 I32 1159 Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, const char *strbeg, const char *strend, char **new_s, I32 ocnt, U32 flags) 1160 ###### { 1161 ###### tempsym_t sym; 1162 ###### PERL_UNUSED_ARG(strbeg); 1163 ###### PERL_UNUSED_ARG(new_s); 1164 ###### PERL_UNUSED_ARG(ocnt); 1165 1166 ###### if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; 1167 ###### else if (need_utf8(pat, patend)) { 1168 /* We probably should try to avoid this in case a scalar context call 1169 wouldn't get to the "U0" */ 1170 ###### STRLEN len = strend - s; 1171 ###### s = (char *) bytes_to_utf8((U8 *) s, &len); 1172 ###### SAVEFREEPV(s); 1173 ###### strend = s + len; 1174 ###### flags |= FLAG_DO_UTF8; 1175 } 1176 1177 ###### if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) 1178 ###### flags |= FLAG_PARSE_UTF8; 1179 1180 ###### TEMPSYM_INIT(&sym, pat, patend, flags); 1181 1182 ###### return unpack_rec(&sym, s, s, strend, NULL ); 1183 } 1184 1185 /* 1186 =for apidoc unpackstring 1187 1188 The engine implementing unpack() Perl function. C puts the 1189 extracted list items on the stack and returns the number of elements. 1190 Issue C before and C after the call to this function. 1191 1192 =cut */ 1193 1194 I32 1195 Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, const char *strend, U32 flags) 1196 50207 { 1197 50207 tempsym_t sym; 1198 1199 50207 if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; 1200 37501 else if (need_utf8(pat, patend)) { 1201 /* We probably should try to avoid this in case a scalar context call 1202 wouldn't get to the "U0" */ 1203 233 STRLEN len = strend - s; 1204 233 s = (char *) bytes_to_utf8((U8 *) s, &len); 1205 233 SAVEFREEPV(s); 1206 233 strend = s + len; 1207 233 flags |= FLAG_DO_UTF8; 1208 } 1209 1210 50207 if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) 1211 7681 flags |= FLAG_PARSE_UTF8; 1212 1213 50207 TEMPSYM_INIT(&sym, pat, patend, flags); 1214 1215 50207 return unpack_rec(&sym, s, s, strend, NULL ); 1216 } 1217 1218 STATIC 1219 I32 1220 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s ) 1221 50538 { 1222 50538 dVAR; dSP; 1223 50538 SV *sv; 1224 50538 const I32 start_sp_offset = SP - PL_stack_base; 1225 50538 howlen_t howlen; 1226 1227 50538 I32 checksum = 0; 1228 50538 UV cuv = 0; 1229 50538 NV cdouble = 0.0; 1230 50538 const int bits_in_uv = CHAR_BIT * sizeof(cuv); 1231 50538 bool beyond = FALSE; 1232 50538 bool explicit_length; 1233 50538 const bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0; 1234 50538 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; 1235 50538 symptr->strbeg = s - strbeg; 1236 1237 210450 while (next_symbol(symptr)) { 1238 159937 packprops_t props; 1239 159937 I32 len; 1240 159937 I32 datumtype = symptr->code; 1241 /* do first one only unless in list context 1242 / is implemented by unpacking the count, then popping it from the 1243 stack, so must check that we're not in the middle of a / */ 1244 159937 if ( unpack_only_one 1245 && (SP - PL_stack_base == start_sp_offset + 1) 1246 && (datumtype != '/') ) /* XXX can this be omitted */ 1247 6 break; 1248 1249 159931 switch (howlen = symptr->howlen) { 1250 case e_star: 1251 14717 len = strend - strbeg; /* long enough */ 1252 14717 break; 1253 default: 1254 /* e_no_len and e_number */ 1255 145214 len = symptr->length; 1256 159931 break; 1257 } 1258 1259 159931 explicit_length = TRUE; 1260 redo_switch: 1261 160108 beyond = s >= strend; 1262 1263 160108 props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; 1264 160108 if (props) { 1265 /* props nonzero means we can process this letter. */ 1266 71097 const long size = props & PACK_SIZE_MASK; 1267 71097 const long howmany = (strend - s) / size; 1268 71097 if (len > howmany) 1269 1067 len = howmany; 1270 1271 71097 if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) { 1272 69912 if (len && unpack_only_one) len = 1; 1273 69912 EXTEND(SP, len); 1274 69912 EXTEND_MORTAL(len); 1275 } 1276 } 1277 1278 160108 switch(TYPE_NO_ENDIANNESS(datumtype)) { 1279 default: 1280 4 Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); 1281 1282 case '%': 1283 1191 if (howlen == e_no_len) 1284 171 len = 16; /* len is not specified */ 1285 1191 checksum = len; 1286 1191 cuv = 0; 1287 1191 cdouble = 0; 1288 1191 continue; 1289 141 break; 1290 case '(': 1291 { 1292 141 tempsym_t savsym = *symptr; 1293 141 const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); 1294 141 symptr->flags |= group_modifiers; 1295 141 symptr->patend = savsym.grpend; 1296 141 symptr->previous = &savsym; 1297 141 symptr->level++; 1298 141 PUTBACK; 1299 462 while (len--) { 1300 331 symptr->patptr = savsym.grpbeg; 1301 331 if (utf8) symptr->flags |= FLAG_PARSE_UTF8; 1302 318 else symptr->flags &= ~FLAG_PARSE_UTF8; 1303 331 unpack_rec(symptr, s, strbeg, strend, &s); 1304 325 if (s == strend && savsym.howlen == e_star) 1305 135 break; /* No way to continue */ 1306 } 1307 135 SPAGAIN; 1308 135 savsym.flags = symptr->flags & ~group_modifiers; 1309 135 *symptr = savsym; 1310 135 break; 1311 } 1312 #ifdef PERL_PACK_CAN_SHRIEKSIGN 1313 case '.' | TYPE_IS_SHRIEKING: 1314 #endif 1315 case '.': { 1316 35 const char *from; 1317 35 SV *sv; 1318 #ifdef PERL_PACK_CAN_SHRIEKSIGN 1319 35 const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); 1320 #else /* PERL_PACK_CAN_SHRIEKSIGN */ 1321 const bool u8 = utf8; 1322 #endif 1323 35 if (howlen == e_star) from = strbeg; 1324 30 else if (len <= 0) from = s; 1325 else { 1326 24 tempsym_t *group = symptr; 1327 1328 34 while (--len && group) group = group->previous; 1329 24 from = group ? strbeg + group->strbeg : strbeg; 1330 } 1331 35 sv = from <= s ? 1332 newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) : 1333 newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s))); 1334 35 XPUSHs(sv_2mortal(sv)); 1335 35 break; 1336 } 1337 #ifdef PERL_PACK_CAN_SHRIEKSIGN 1338 case '@' | TYPE_IS_SHRIEKING: 1339 #endif 1340 case '@': 1341 35 s = strbeg + symptr->strbeg; 1342 #ifdef PERL_PACK_CAN_SHRIEKSIGN 1343 35 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) 1344 #else /* PERL_PACK_CAN_SHRIEKSIGN */ 1345 if (utf8) 1346 #endif 1347 { 1348 48 while (len > 0) { 1349 39 if (s >= strend) 1350 ###### Perl_croak(aTHX_ "'@' outside of string in unpack"); 1351 39 s += UTF8SKIP(s); 1352 39 len--; 1353 } 1354 9 if (s > strend) 1355 ###### Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack"); 1356 } else { 1357 26 if (strend-s < len) 1358 ###### Perl_croak(aTHX_ "'@' outside of string in unpack"); 1359 26 s += len; 1360 } 1361 26 break; 1362 case 'X' | TYPE_IS_SHRIEKING: 1363 7 if (!len) /* Avoid division by 0 */ 1364 ###### len = 1; 1365 7 if (utf8) { 1366 3 const char *hop, *last; 1367 3 I32 l = len; 1368 3 hop = last = strbeg; 1369 17 while (hop < s) { 1370 14 hop += UTF8SKIP(hop); 1371 14 if (--l == 0) { 1372 2 last = hop; 1373 2 l = len; 1374 } 1375 } 1376 3 if (last > s) 1377 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 1378 3 s = last; 1379 3 break; 1380 } 1381 4 len = (s - strbeg) % len; 1382 /* FALL THROUGH */ 1383 case 'X': 1384 24 if (utf8) { 1385 15 while (len > 0) { 1386 10 if (s <= strbeg) 1387 ###### Perl_croak(aTHX_ "'X' outside of string in unpack"); 1388 28 while (--s, UTF8_IS_CONTINUATION(*s)) { 1389 18 if (s <= strbeg) 1390 ###### Perl_croak(aTHX_ "'X' outside of string in unpack"); 1391 } 1392 10 len--; 1393 } 1394 } else { 1395 19 if (len > s - strbeg) 1396 ###### Perl_croak(aTHX_ "'X' outside of string in unpack" ); 1397 19 s -= len; 1398 } 1399 19 break; 1400 case 'x' | TYPE_IS_SHRIEKING: { 1401 12 I32 ai32; 1402 12 if (!len) /* Avoid division by 0 */ 1403 ###### len = 1; 1404 12 if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len; 1405 10 else ai32 = (s - strbeg) % len; 1406 12 if (ai32 == 0) break; 1407 6 len -= ai32; 1408 } 1409 /* FALL THROUGH */ 1410 case 'x': 1411 4544 if (utf8) { 1412 1158 while (len>0) { 1413 1082 if (s >= strend) 1414 ###### Perl_croak(aTHX_ "'x' outside of string in unpack"); 1415 1082 s += UTF8SKIP(s); 1416 1082 len--; 1417 } 1418 } else { 1419 4468 if (len > strend - s) 1420 ###### Perl_croak(aTHX_ "'x' outside of string in unpack"); 1421 4468 s += len; 1422 } 1423 4468 break; 1424 case '/': 1425 2 Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); 1426 82636 break; 1427 case 'A': 1428 case 'Z': 1429 case 'a': 1430 82636 if (checksum) { 1431 /* Preliminary length estimate is assumed done in 'W' */ 1432 ###### if (len > strend - s) len = strend - s; 1433 ###### goto W_checksum; 1434 } 1435 82636 if (utf8) { 1436 34 I32 l; 1437 34 const char *hop; 1438 102 for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) { 1439 83 if (hop >= strend) { 1440 15 if (hop > strend) 1441 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 1442 68 break; 1443 } 1444 } 1445 34 if (hop > strend) 1446 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 1447 34 len = hop - s; 1448 82602 } else if (len > strend - s) 1449 10 len = strend - s; 1450 1451 82636 if (datumtype == 'Z') { 1452 /* 'Z' strips stuff after first null */ 1453 23 const char *ptr, *end; 1454 23 end = s + len; 1455 23 for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break; 1456 23 sv = newSVpvn(s, ptr-s); 1457 23 if (howlen == e_star) /* exact for 'Z*' */ 1458 6 len = ptr-s + (ptr != strend ? 1 : 0); 1459 82613 } else if (datumtype == 'A') { 1460 /* 'A' strips both nulls and spaces */ 1461 1531 const char *ptr; 1462 1531 if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) { 1463 30 for (ptr = s+len-1; ptr >= s; ptr--) 1464 28 if (*ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) && 1465 4 !is_utf8_space((U8 *) ptr)) break; 1466 6 if (ptr >= s) ptr += UTF8SKIP(ptr); 1467 2 else ptr++; 1468 6 if (ptr > s+len) 1469 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 1470 } else { 1471 38756 for (ptr = s+len-1; ptr >= s; ptr--) 1472 38410 if (*ptr != 0 && !isSPACE(*ptr)) break; 1473 1525 ptr++; 1474 } 1475 1531 sv = newSVpvn(s, ptr-s); 1476 81082 } else sv = newSVpvn(s, len); 1477 1478 82636 if (utf8) { 1479 34 SvUTF8_on(sv); 1480 /* Undo any upgrade done due to need_utf8() */ 1481 34 if (!(symptr->flags & FLAG_WAS_UTF8)) 1482 10 sv_utf8_downgrade(sv, 0); 1483 } 1484 82636 XPUSHs(sv_2mortal(sv)); 1485 82636 s += len; 1486 82636 break; 1487 case 'B': 1488 case 'b': { 1489 91 char *str; 1490 91 if (howlen == e_star || len > (strend - s) * 8) 1491 4 len = (strend - s) * 8; 1492 91 if (checksum) { 1493 6 if (!PL_bitcount) { 1494 1 int bits; 1495 1 Newz(601, PL_bitcount, 256, char); 1496 256 for (bits = 1; bits < 256; bits++) { 1497 255 if (bits & 1) PL_bitcount[bits]++; 1498 255 if (bits & 2) PL_bitcount[bits]++; 1499 255 if (bits & 4) PL_bitcount[bits]++; 1500 255 if (bits & 8) PL_bitcount[bits]++; 1501 255 if (bits & 16) PL_bitcount[bits]++; 1502 255 if (bits & 32) PL_bitcount[bits]++; 1503 255 if (bits & 64) PL_bitcount[bits]++; 1504 255 if (bits & 128) PL_bitcount[bits]++; 1505 } 1506 } 1507 6 if (utf8) 1508 ###### while (len >= 8 && s < strend) { 1509 ###### cuv += PL_bitcount[uni_to_byte(aTHX_ &s, strend, datumtype)]; 1510 ###### len -= 8; 1511 } 1512 else 1513 8259 while (len >= 8) { 1514 8253 cuv += PL_bitcount[*(U8 *)s++]; 1515 8253 len -= 8; 1516 } 1517 6 if (len && s < strend) { 1518 3 U8 bits; 1519 3 bits = SHIFT_BYTE(utf8, s, strend, datumtype); 1520 3 if (datumtype == 'b') 1521 9 while (len-- > 0) { 1522 7 if (bits & 1) cuv++; 1523 7 bits >>= 1; 1524 } 1525 else 1526 6 while (len-- > 0) { 1527 5 if (bits & 0x80) cuv++; 1528 5 bits <<= 1; 1529 } 1530 } 1531 85 break; 1532 } 1533 1534 85 sv = sv_2mortal(NEWSV(35, len ? len : 1)); 1535 85 SvPOK_on(sv); 1536 85 str = SvPVX(sv); 1537 85 if (datumtype == 'b') { 1538 83 U8 bits = 0; 1539 83 const I32 ai32 = len; 1540 66927 for (len = 0; len < ai32; len++) { 1541 66844 if (len & 7) bits >>= 1; 1542 8358 else if (utf8) { 1543 3 if (s >= strend) break; 1544 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 1545 8355 } else bits = *(U8 *) s++; 1546 66844 *str++ = bits & 1 ? '1' : '0'; 1547 } 1548 } else { 1549 2 U8 bits = 0; 1550 2 const I32 ai32 = len; 1551 44 for (len = 0; len < ai32; len++) { 1552 42 if (len & 7) bits <<= 1; 1553 6 else if (utf8) { 1554 3 if (s >= strend) break; 1555 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 1556 3 } else bits = *(U8 *) s++; 1557 42 *str++ = bits & 0x80 ? '1' : '0'; 1558 } 1559 } 1560 85 *str = '\0'; 1561 85 SvCUR_set(sv, str - SvPVX_const(sv)); 1562 85 XPUSHs(sv); 1563 85 break; 1564 } 1565 case 'H': 1566 case 'h': { 1567 260 char *str; 1568 /* Preliminary length estimate, acceptable for utf8 too */ 1569 260 if (howlen == e_star || len > (strend - s) * 2) 1570 212 len = (strend - s) * 2; 1571 260 sv = sv_2mortal(NEWSV(35, len ? len : 1)); 1572 260 SvPOK_on(sv); 1573 260 str = SvPVX(sv); 1574 260 if (datumtype == 'h') { 1575 46 U8 bits = 0; 1576 46 I32 ai32 = len; 1577 232 for (len = 0; len < ai32; len++) { 1578 186 if (len & 1) bits >>= 4; 1579 94 else if (utf8) { 1580 3 if (s >= strend) break; 1581 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 1582 91 } else bits = * (U8 *) s++; 1583 186 *str++ = PL_hexdigit[bits & 15]; 1584 } 1585 } else { 1586 214 U8 bits = 0; 1587 214 const I32 ai32 = len; 1588 1712 for (len = 0; len < ai32; len++) { 1589 1498 if (len & 1) bits <<= 4; 1590 750 else if (utf8) { 1591 3 if (s >= strend) break; 1592 3 bits = uni_to_byte(aTHX_ &s, strend, datumtype); 1593 747 } else bits = *(U8 *) s++; 1594 1498 *str++ = PL_hexdigit[(bits >> 4) & 15]; 1595 } 1596 } 1597 260 *str = '\0'; 1598 260 SvCUR_set(sv, str - SvPVX_const(sv)); 1599 260 XPUSHs(sv); 1600 260 break; 1601 } 1602 case 'c': 1603 388 while (len-- > 0) { 1604 236 int aint = SHIFT_BYTE(utf8, s, strend, datumtype); 1605 236 if (aint >= 128) /* fake up signed chars */ 1606 43 aint -= 256; 1607 236 if (!checksum) 1608 143 PUSHs(sv_2mortal(newSViv((IV)aint))); 1609 93 else if (checksum > bits_in_uv) 1610 30 cdouble += (NV)aint; 1611 else 1612 63 cuv += aint; 1613 } 1614 50197 break; 1615 case 'C': 1616 case 'W': 1617 W_checksum: 1618 50197 if (len == 0) { 1619 260 if (explicit_length && datumtype == 'C') 1620 /* Switch to "character" mode */ 1621 258 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; 1622 258 break; 1623 } 1624 49937 if (datumtype == 'C' ? 1625 (symptr->flags & FLAG_DO_UTF8) && 1626 !(symptr->flags & FLAG_WAS_UTF8) : utf8) { 1627 266 while (len-- > 0 && s < strend) { 1628 193 STRLEN retlen; 1629 193 const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, 1630 193 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 1631 193 if (retlen == (STRLEN) -1 || retlen == 0) 1632 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 1633 193 s += retlen; 1634 193 if (!checksum) 1635 58 PUSHs(sv_2mortal(newSVuv((UV) val))); 1636 135 else if (checksum > bits_in_uv) 1637 54 cdouble += (NV) val; 1638 else 1639 81 cuv += val; 1640 } 1641 49864 } else if (!checksum) 1642 1296687 while (len-- > 0) { 1643 1246968 const U8 ch = *(U8 *) s++; 1644 1246968 PUSHs(sv_2mortal(newSVuv((UV) ch))); 1645 } 1646 145 else if (checksum > bits_in_uv) 1647 36 while (len-- > 0) cdouble += (NV) *(U8 *) s++; 1648 else 1649 66036 while (len-- > 0) cuv += *(U8 *) s++; 1650 5568 break; 1651 case 'U': 1652 5568 if (len == 0) { 1653 480 if (explicit_length) { 1654 /* Switch to "bytes in UTF-8" mode */ 1655 478 if (symptr->flags & FLAG_DO_UTF8) utf8 = 0; 1656 else 1657 /* Should be impossible due to the need_utf8() test */ 1658 ###### Perl_croak(aTHX_ "U0 mode on a byte string"); 1659 } 1660 5088 break; 1661 } 1662 5088 if (len > strend - s) len = strend - s; 1663 5088 if (!checksum) { 1664 5080 if (len && unpack_only_one) len = 1; 1665 5080 EXTEND(SP, len); 1666 5080 EXTEND_MORTAL(len); 1667 } 1668 14230 while (len-- > 0 && s < strend) { 1669 9142 STRLEN retlen; 1670 9142 UV auv; 1671 9142 if (utf8) { 1672 19 U8 result[UTF8_MAXLEN]; 1673 19 const char *ptr = s; 1674 19 STRLEN len; 1675 /* Bug: warns about bad utf8 even if we are short on bytes 1676 and will break out of the loop */ 1677 19 if (!uni_to_bytes(aTHX_ &ptr, strend, (char *) result, 1, 1678 'U')) 1679 ###### break; 1680 19 len = UTF8SKIP(result); 1681 19 if (!uni_to_bytes(aTHX_ &ptr, strend, 1682 ###### (char *) &result[1], len-1, 'U')) break; 1683 19 auv = utf8n_to_uvuni(result, len, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV); 1684 19 s = ptr; 1685 } else { 1686 9123 auv = utf8n_to_uvuni((U8*)s, strend - s, &retlen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV); 1687 9123 if (retlen == (STRLEN) -1 || retlen == 0) 1688 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); 1689 9123 s += retlen; 1690 } 1691 9142 if (!checksum) 1692 9122 PUSHs(sv_2mortal(newSVuv((UV) auv))); 1693 20 else if (checksum > bits_in_uv) 1694 2 cdouble += (NV) auv; 1695 else 1696 18 cuv += auv; 1697 } 1698 202 break; 1699 case 's' | TYPE_IS_SHRIEKING: 1700 #if SHORTSIZE != SIZE16 1701 while (len-- > 0) { 1702 short ashort; 1703 SHIFT_VAR(utf8, s, strend, ashort, datumtype); 1704 DO_BO_UNPACK(ashort, s); 1705 if (!checksum) 1706 PUSHs(sv_2mortal(newSViv((IV)ashort))); 1707 else if (checksum > bits_in_uv) 1708 cdouble += (NV)ashort; 1709 else 1710 cuv += ashort; 1711 } 1712 break; 1713 #else 1714 /* Fallthrough! */ 1715 #endif 1716 case 's': 1717 821 while (len-- > 0) { 1718 619 I16 ai16; 1719 1720 #if U16SIZE > SIZE16 1721 ai16 = 0; 1722 #endif 1723 619 SHIFT16(utf8, s, strend, &ai16, datumtype); 1724 619 DO_BO_UNPACK(ai16, 16); 1725 #if U16SIZE > SIZE16 1726 if (ai16 > 32767) 1727 ai16 -= 65536; 1728 #endif 1729 619 if (!checksum) 1730 151 PUSHs(sv_2mortal(newSViv((IV)ai16))); 1731 468 else if (checksum > bits_in_uv) 1732 180 cdouble += (NV)ai16; 1733 else 1734 288 cuv += ai16; 1735 } 1736 8758 break; 1737 case 'S' | TYPE_IS_SHRIEKING: 1738 #if SHORTSIZE != SIZE16 1739 while (len-- > 0) { 1740 unsigned short aushort; 1741 SHIFT_VAR(utf8, s, strend, aushort, datumtype); 1742 DO_BO_UNPACK(aushort, s); 1743 if (!checksum) 1744 PUSHs(sv_2mortal(newSVuv((UV) aushort))); 1745 else if (checksum > bits_in_uv) 1746 cdouble += (NV)aushort; 1747 else 1748 cuv += aushort; 1749 } 1750 break; 1751 #else 1752 /* Fallhrough! */ 1753 #endif 1754 case 'v': 1755 case 'n': 1756 case 'S': 1757 371860 while (len-- > 0) { 1758 363102 U16 au16; 1759 #if U16SIZE > SIZE16 1760 au16 = 0; 1761 #endif 1762 363102 SHIFT16(utf8, s, strend, &au16, datumtype); 1763 363102 DO_BO_UNPACK(au16, 16); 1764 #ifdef HAS_NTOHS 1765 363102 if (datumtype == 'n') 1766 361777 au16 = PerlSock_ntohs(au16); 1767 #endif 1768 #ifdef HAS_VTOHS 1769 if (datumtype == 'v') 1770 au16 = vtohs(au16); 1771 #endif 1772 363102 if (!checksum) 1773 34768 PUSHs(sv_2mortal(newSVuv((UV)au16))); 1774 328334 else if (checksum > bits_in_uv) 1775 327920 cdouble += (NV) au16; 1776 else 1777 414 cuv += au16; 1778 } 1779 44 break; 1780 #ifdef PERL_PACK_CAN_SHRIEKSIGN 1781 case 'v' | TYPE_IS_SHRIEKING: 1782 case 'n' | TYPE_IS_SHRIEKING: 1783 208 while (len-- > 0) { 1784 164 I16 ai16; 1785 # if U16SIZE > SIZE16 1786 ai16 = 0; 1787 # endif 1788 164 SHIFT16(utf8, s, strend, &ai16, datumtype); 1789 # ifdef HAS_NTOHS 1790 164 if (datumtype == ('n' | TYPE_IS_SHRIEKING)) 1791 82 ai16 = (I16) PerlSock_ntohs((U16) ai16); 1792 # endif /* HAS_NTOHS */ 1793 # ifdef HAS_VTOHS 1794 if (datumtype == ('v' | TYPE_IS_SHRIEKING)) 1795 ai16 = (I16) vtohs((U16) ai16); 1796 # endif /* HAS_VTOHS */ 1797 164 if (!checksum) 1798 14 PUSHs(sv_2mortal(newSViv((IV)ai16))); 1799 150 else if (checksum > bits_in_uv) 1800 60 cdouble += (NV) ai16; 1801 else 1802 90 cuv += ai16; 1803 } 1804 200 break; 1805 #endif /* PERL_PACK_CAN_SHRIEKSIGN */ 1806 case 'i': 1807 case 'i' | TYPE_IS_SHRIEKING: 1808 847 while (len-- > 0) { 1809 647 int aint; 1810 647 SHIFT_VAR(utf8, s, strend, aint, datumtype); 1811 647 DO_BO_UNPACK(aint, i); 1812 647 if (!checksum) 1813 99 PUSHs(sv_2mortal(newSViv((IV)aint))); 1814 548 else if (checksum > bits_in_uv) 1815 180 cdouble += (NV)aint; 1816 else 1817 368 cuv += aint; 1818 } 1819 205 break; 1820 case 'I': 1821 case 'I' | TYPE_IS_SHRIEKING: 1822 851 while (len-- > 0) { 1823 646 unsigned int auint; 1824 646 SHIFT_VAR(utf8, s, strend, auint, datumtype); 1825 646 DO_BO_UNPACK(auint, i); 1826 646 if (!checksum) 1827 178 PUSHs(sv_2mortal(newSVuv((UV)auint))); 1828 468 else if (checksum > bits_in_uv) 1829 180 cdouble += (NV)auint; 1830 else 1831 288 cuv += auint; 1832 } 1833 101 break; 1834 case 'j': 1835 412 while (len-- > 0) { 1836 311 IV aiv; 1837 311 SHIFT_VAR(utf8, s, strend, aiv, datumtype); 1838 #if IVSIZE == INTSIZE 1839 311 DO_BO_UNPACK(aiv, i); 1840 #elif IVSIZE == LONGSIZE 1841 DO_BO_UNPACK(aiv, l); 1842 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE 1843 DO_BO_UNPACK(aiv, 64); 1844 #else 1845 Perl_croak(aTHX_ "'j' not supported on this platform"); 1846 #endif 1847 311 if (!checksum) 1848 68 PUSHs(sv_2mortal(newSViv(aiv))); 1849 243 else if (checksum > bits_in_uv) 1850 90 cdouble += (NV)aiv; 1851 else 1852 153 cuv += aiv; 1853 } 1854 149 break; 1855 case 'J': 1856 556 while (len-- > 0) { 1857 407 UV auv; 1858 407 SHIFT_VAR(utf8, s, strend, auv, datumtype); 1859 #if IVSIZE == INTSIZE 1860 407 DO_BO_UNPACK(auv, i); 1861 #elif IVSIZE == LONGSIZE 1862 DO_BO_UNPACK(auv, l); 1863 #elif defined(HAS_QUAD) && IVSIZE == U64SIZE 1864 DO_BO_UNPACK(auv, 64); 1865 #else 1866 Perl_croak(aTHX_ "'J' not supported on this platform"); 1867 #endif 1868 407 if (!checksum) 1869 164 PUSHs(sv_2mortal(newSVuv(auv))); 1870 243 else if (checksum > bits_in_uv) 1871 90 cdouble += (NV)auv; 1872 else 1873 153 cuv += auv; 1874 } 1875 209 break; 1876 case 'l' | TYPE_IS_SHRIEKING: 1877 #if LONGSIZE != SIZE32 1878 while (len-- > 0) { 1879 long along; 1880 SHIFT_VAR(utf8, s, strend, along, datumtype); 1881 DO_BO_UNPACK(along, l); 1882 if (!checksum) 1883 PUSHs(sv_2mortal(newSViv((IV)along))); 1884 else if (checksum > bits_in_uv) 1885 cdouble += (NV)along; 1886 else 1887 cuv += along; 1888 } 1889 break; 1890 #else 1891 /* Fallthrough! */ 1892 #endif 1893 case 'l': 1894 799 while (len-- > 0) { 1895 590 I32 ai32; 1896 #if U32SIZE > SIZE32 1897 ai32 = 0; 1898 #endif 1899 590 SHIFT32(utf8, s, strend, &ai32, datumtype); 1900 590 DO_BO_UNPACK(ai32, 32); 1901 #if U32SIZE > SIZE32 1902 if (ai32 > 2147483647) ai32 -= 4294967296; 1903 #endif 1904 590 if (!checksum) 1905 122 PUSHs(sv_2mortal(newSViv((IV)ai32))); 1906 468 else if (checksum > bits_in_uv) 1907 180 cdouble += (NV)ai32; 1908 else 1909 288 cuv += ai32; 1910 } 1911 4947 break; 1912 case 'L' | TYPE_IS_SHRIEKING: 1913 #if LONGSIZE != SIZE32 1914 while (len-- > 0) { 1915 unsigned long aulong; 1916 SHIFT_VAR(utf8, s, strend, aulong, datumtype); 1917 DO_BO_UNPACK(aulong, l); 1918 if (!checksum) 1919 PUSHs(sv_2mortal(newSVuv((UV)aulong))); 1920 else if (checksum > bits_in_uv) 1921 cdouble += (NV)aulong; 1922 else 1923 cuv += aulong; 1924 } 1925 break; 1926 #else 1927 /* Fall through! */ 1928 #endif 1929 case 'V': 1930 case 'N': 1931 case 'L': 1932 23652 while (len-- > 0) { 1933 18705 U32 au32; 1934 #if U32SIZE > SIZE32 1935 au32 = 0; 1936 #endif 1937 18705 SHIFT32(utf8, s, strend, &au32, datumtype); 1938 18705 DO_BO_UNPACK(au32, 32); 1939 #ifdef HAS_NTOHL 1940 18705 if (datumtype == 'N') 1941 17814 au32 = PerlSock_ntohl(au32); 1942 #endif 1943 #ifdef HAS_VTOHL 1944 if (datumtype == 'V') 1945 au32 = vtohl(au32); 1946 #endif 1947 18705 if (!checksum) 1948 18051 PUSHs(sv_2mortal(newSVuv((UV)au32))); 1949 654 else if (checksum > bits_in_uv) 1950 240 cdouble += (NV)au32; 1951 else 1952 414 cuv += au32; 1953 } 1954 44 break; 1955 #ifdef PERL_PACK_CAN_SHRIEKSIGN 1956 case 'V' | TYPE_IS_SHRIEKING: 1957 case 'N' | TYPE_IS_SHRIEKING: 1958 208 while (len-- > 0) { 1959 164 I32 ai32; 1960 # if U32SIZE > SIZE32 1961 ai32 = 0; 1962 # endif 1963 164 SHIFT32(utf8, s, strend, &ai32, datumtype); 1964 # ifdef HAS_NTOHL 1965 164 if (datumtype == ('N' | TYPE_IS_SHRIEKING)) 1966 82 ai32 = (I32)PerlSock_ntohl((U32)ai32); 1967 # endif 1968 # ifdef HAS_VTOHL 1969 if (datumtype == ('V' | TYPE_IS_SHRIEKING)) 1970 ai32 = (I32)vtohl((U32)ai32); 1971 # endif 1972 164 if (!checksum) 1973 14 PUSHs(sv_2mortal(newSViv((IV)ai32))); 1974 150 else if (checksum > bits_in_uv) 1975 60 cdouble += (NV)ai32; 1976 else 1977 90 cuv += ai32; 1978 } 1979 8 break; 1980 #endif /* PERL_PACK_CAN_SHRIEKSIGN */ 1981 case 'p': 1982 16 while (len-- > 0) { 1983 8 const char *aptr; 1984 8 SHIFT_VAR(utf8, s, strend, aptr, datumtype); 1985 8 DO_BO_UNPACK_PC(aptr); 1986 /* newSVpv generates undef if aptr is NULL */ 1987 8 PUSHs(sv_2mortal(newSVpv(aptr, 0))); 1988 } 1989 24 break; 1990 case 'w': 1991 { 1992 24 UV auv = 0; 1993 24 U32 bytes = 0; 1994 1995 123 while (len > 0 && s < strend) { 1996 99 U8 ch; 1997 99 ch = SHIFT_BYTE(utf8, s, strend, datumtype); 1998 99 auv = (auv << 7) | (ch & 0x7f); 1999 /* UTF8_IS_XXXXX not right here - using constant 0x80 */ 2000 99 if (ch < 0x80) { 2001 25 bytes = 0; 2002 25 PUSHs(sv_2mortal(newSVuv(auv))); 2003 25 len--; 2004 25 auv = 0; 2005 25 continue; 2006 } 2007 74 if (++bytes >= sizeof(UV)) { /* promote to string */ 2008 15 const char *t; 2009 2010 15 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); 2011 187 while (s < strend) { 2012 185 ch = SHIFT_BYTE(utf8, s, strend, datumtype); 2013 185 sv = mul128(sv, (U8)(ch & 0x7f)); 2014 185 if (!(ch & 0x80)) { 2015 13 bytes = 0; 2016 break; 2017 } 2018 } 2019 15 t = SvPV_nolen_const(sv); 2020 123 while (*t == '0') 2021 108 t++; 2022 15 sv_chop(sv, t); 2023 15 PUSHs(sv_2mortal(sv)); 2024 15 len--; 2025 15 auv = 0; 2026 } 2027 } 2028 24 if ((s >= strend) && bytes) 2029 3 Perl_croak(aTHX_ "Unterminated compressed integer in unpack"); 2030 } 2031 3 break; 2032 case 'P': 2033 3 if (symptr->howlen == e_star) 2034 1 Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); 2035 2 EXTEND(SP, 1); 2036 2 if (sizeof(char*) <= strend - s) { 2037 2 char *aptr; 2038 2 SHIFT_VAR(utf8, s, strend, aptr, datumtype); 2039 2 DO_BO_UNPACK_PC(aptr); 2040 /* newSVpvn generates undef if aptr is NULL */ 2041 2 PUSHs(sv_2mortal(newSVpvn(aptr, len))); 2042 } 2043 2 break; 2044 #ifdef HAS_QUAD 2045 case 'q': 2046 while (len-- > 0) { 2047 Quad_t aquad; 2048 SHIFT_VAR(utf8, s, strend, aquad, datumtype); 2049 DO_BO_UNPACK(aquad, 64); 2050 if (!checksum) 2051 PUSHs(sv_2mortal(aquad >= IV_MIN && aquad <= IV_MAX ? 2052 newSViv((IV)aquad) : newSVnv((NV)aquad))); 2053 else if (checksum > bits_in_uv) 2054 cdouble += (NV)aquad; 2055 else 2056 cuv += aquad; 2057 } 2058 break; 2059 case 'Q': 2060 while (len-- > 0) { 2061 Uquad_t auquad; 2062 SHIFT_VAR(utf8, s, strend, auquad, datumtype); 2063 DO_BO_UNPACK(auquad, 64); 2064 if (!checksum) 2065 PUSHs(sv_2mortal(auquad <= UV_MAX ? 2066 newSVuv((UV)auquad):newSVnv((NV)auquad))); 2067 else if (checksum > bits_in_uv) 2068 cdouble += (NV)auquad; 2069 else 2070 cuv += auquad; 2071 } 2072 break; 2073 #endif /* HAS_QUAD */ 2074 /* float and double added gnb@melba.bby.oz.au 22/11/89 */ 2075 case 'f': 2076 393 while (len-- > 0) { 2077 297 float afloat; 2078 297 SHIFT_VAR(utf8, s, strend, afloat, datumtype); 2079 297 DO_BO_UNPACK_N(afloat, float); 2080 297 if (!checksum) 2081 54 PUSHs(sv_2mortal(newSVnv((NV)afloat))); 2082 else 2083 243 cdouble += afloat; 2084 } 2085 100 break; 2086 case 'd': 2087 401 while (len-- > 0) { 2088 301 double adouble; 2089 301 SHIFT_VAR(utf8, s, strend, adouble, datumtype); 2090 301 DO_BO_UNPACK_N(adouble, double); 2091 301 if (!checksum) 2092 58 PUSHs(sv_2mortal(newSVnv((NV)adouble))); 2093 else 2094 243 cdouble += adouble; 2095 } 2096 93 break; 2097 case 'F': 2098 384 while (len-- > 0) { 2099 291 NV anv; 2100 291 SHIFT_VAR(utf8, s, strend, anv, datumtype); 2101 291 DO_BO_UNPACK_N(anv, NV); 2102 291 if (!checksum) 2103 48 PUSHs(sv_2mortal(newSVnv(anv))); 2104 else 2105 243 cdouble += anv; 2106 } 2107 36 break; 2108 #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 2109 case 'D': 2110 while (len-- > 0) { 2111 long double aldouble; 2112 SHIFT_VAR(utf8, s, strend, aldouble, datumtype); 2113 DO_BO_UNPACK_N(aldouble, long double); 2114 if (!checksum) 2115 PUSHs(sv_2mortal(newSVnv((NV)aldouble))); 2116 else 2117 cdouble += aldouble; 2118 } 2119 break; 2120 #endif 2121 case 'u': 2122 /* MKS: 2123 * Initialise the decode mapping. By using a table driven 2124 * algorithm, the code will be character-set independent 2125 * (and just as fast as doing character arithmetic) 2126 */ 2127 36 if (PL_uudmap['M'] == 0) { 2128 5 int i; 2129 2130 330 for (i = 0; i < sizeof(PL_uuemap); i += 1) 2131 325 PL_uudmap[(U8)PL_uuemap[i]] = i; 2132 /* 2133 * Because ' ' and '`' map to the same value, 2134 * we need to decode them both the same. 2135 */ 2136 5 PL_uudmap[' '] = 0; 2137 } 2138 { 2139 36 const STRLEN l = (STRLEN) (strend - s) * 3 / 4; 2140 36 sv = sv_2mortal(NEWSV(42, l)); 2141 36 if (l) SvPOK_on(sv); 2142 } 2143 36 if (utf8) { 2144 2 while (next_uni_uu(aTHX_ &s, strend, &len)) { 2145 1 I32 a, b, c, d; 2146 1 char hunk[4]; 2147 2148 1 hunk[3] = '\0'; 2149 5 while (len > 0) { 2150 4 next_uni_uu(aTHX_ &s, strend, &a); 2151 4 next_uni_uu(aTHX_ &s, strend, &b); 2152 4 next_uni_uu(aTHX_ &s, strend, &c); 2153 4 next_uni_uu(aTHX_ &s, strend, &d); 2154 4 hunk[0] = (char)((a << 2) | (b >> 4)); 2155 4 hunk[1] = (char)((b << 4) | (c >> 2)); 2156 4 hunk[2] = (char)((c << 6) | d); 2157 4 sv_catpvn(sv, hunk, (len > 3) ? 3 : len); 2158 4 len -= 3; 2159 } 2160 1 if (s < strend) { 2161 1 if (*s == '\n') { 2162 1 s++; 2163 } 2164 else { 2165 /* possible checksum byte */ 2166 ###### const char *skip = s+UTF8SKIP(s); 2167 ###### if (skip < strend && *skip == '\n') 2168 ###### s = skip+1; 2169 } 2170 } 2171 } 2172 } else { 2173 122 while (s < strend && *s > ' ' && ISUUCHAR(*s)) { 2174 87 I32 a, b, c, d; 2175 87 char hunk[4]; 2176 2177 87 hunk[3] = '\0'; 2178 87 len = PL_uudmap[*(U8*)s++] & 077; 2179 1136 while (len > 0) { 2180 1049 if (s < strend && ISUUCHAR(*s)) 2181 1048 a = PL_uudmap[*(U8*)s++] & 077; 2182 else 2183 1 a = 0; 2184 1049 if (s < strend && ISUUCHAR(*s)) 2185 1048 b = PL_uudmap[*(U8*)s++] & 077; 2186 else 2187 1 b = 0; 2188 1049 if (s < strend && ISUUCHAR(*s)) 2189 1048 c = PL_uudmap[*(U8*)s++] & 077; 2190 else 2191 1 c = 0; 2192 1049 if (s < strend && ISUUCHAR(*s)) 2193 1048 d = PL_uudmap[*(U8*)s++] & 077; 2194 else 2195 1 d = 0; 2196 1049 hunk[0] = (char)((a << 2) | (b >> 4)); 2197 1049 hunk[1] = (char)((b << 4) | (c >> 2)); 2198 1049 hunk[2] = (char)((c << 6) | d); 2199 1049 sv_catpvn(sv, hunk, (len > 3) ? 3 : len); 2200 1049 len -= 3; 2201 } 2202 87 if (*s == '\n') 2203 86 s++; 2204 else /* possible checksum byte */ 2205 1 if (s + 1 < strend && s[1] == '\n') 2206 ###### s += 2; 2207 } 2208 } 2209 36 XPUSHs(sv); 2210 158901 break; 2211 } 2212 2213 158901 if (checksum) { 2214 1191 if (strchr("fFdD", TYPE_NO_MODIFIERS(datumtype)) || 2215 (checksum > bits_in_uv && 2216 strchr("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { 2217 478 NV trouble, anv; 2218 2219 478 anv = (NV) (1 << (checksum & 15)); 2220 1754 while (checksum >= 16) { 2221 1276 checksum -= 16; 2222 1276 anv *= 65536.0; 2223 } 2224 634 while (cdouble < 0.0) 2225 156 cdouble += anv; 2226 478 cdouble = Perl_modf(cdouble / anv, &trouble) * anv; 2227 478 sv = newSVnv(cdouble); 2228 } 2229 else { 2230 713 if (checksum < bits_in_uv) { 2231 636 UV mask = ((UV)1 << checksum) - 1; 2232 636 cuv &= mask; 2233 } 2234 713 sv = newSVuv(cuv); 2235 } 2236 1191 XPUSHs(sv_2mortal(sv)); 2237 1191 checksum = 0; 2238 } 2239 2240 158901 if (symptr->flags & FLAG_SLASH){ 2241 180 if (SP - PL_stack_base - start_sp_offset <= 0) 2242 ###### Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); 2243 180 if( next_symbol(symptr) ){ 2244 179 if( symptr->howlen == e_number ) 2245 ###### Perl_croak(aTHX_ "Count after length/code in unpack" ); 2246 179 if( beyond ){ 2247 /* ...end of char buffer then no decent length available */ 2248 2 Perl_croak(aTHX_ "length/code after end of string in unpack" ); 2249 } else { 2250 /* take top of stack (hope it's numeric) */ 2251 177 len = POPi; 2252 177 if( len < 0 ) 2253 ###### Perl_croak(aTHX_ "Negative '/' count in unpack" ); 2254 } 2255 } else { 2256 1 Perl_croak(aTHX_ "Code missing after '/' in unpack" ); 2257 } 2258 177 datumtype = symptr->code; 2259 177 explicit_length = FALSE; 2260 177 goto redo_switch; 2261 } 2262 } 2263 2264 50500 if (new_s) 2265 325 *new_s = s; 2266 50500 PUTBACK; 2267 50500 return SP - PL_stack_base - start_sp_offset; 2268 } 2269 2270 PP(pp_unpack) 2271 50207 { 2272 50207 dSP; 2273 50207 dPOPPOPssrl; 2274 50207 I32 gimme = GIMME_V; 2275 50207 STRLEN llen; 2276 50207 STRLEN rlen; 2277 50207 const char *pat = SvPV_const(left, llen); 2278 50207 const char *s = SvPV_const(right, rlen); 2279 50207 const char *strend = s + rlen; 2280 50207 const char *patend = pat + llen; 2281 50207 I32 cnt; 2282 2283 50207 PUTBACK; 2284 50207 cnt = unpackstring(pat, patend, s, strend, 2285 ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0) 2286 | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0)); 2287 2288 50175 SPAGAIN; 2289 50175 if ( !cnt && gimme == G_SCALAR ) 2290 3 PUSHs(&PL_sv_undef); 2291 50175 RETURN; 2292 } 2293 2294 STATIC U8 * 2295 doencodes(U8 *h, const char *s, I32 len) 2296 101 { 2297 101 *h++ = PL_uuemap[len]; 2298 486 while (len > 2) { 2299 385 *h++ = PL_uuemap[(077 & (s[0] >> 2))]; 2300 385 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))]; 2301 385 *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; 2302 385 *h++ = PL_uuemap[(077 & (s[2] & 077))]; 2303 385 s += 3; 2304 385 len -= 3; 2305 } 2306 101 if (len > 0) { 2307 57 const char r = (len > 1 ? s[1] : '\0'); 2308 57 *h++ = PL_uuemap[(077 & (s[0] >> 2))]; 2309 57 *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))]; 2310 57 *h++ = PL_uuemap[(077 & ((r << 2) & 074))]; 2311 57 *h++ = PL_uuemap[0]; 2312 } 2313 101 *h++ = '\n'; 2314 101 return h; 2315 } 2316 2317 STATIC SV * 2318 S_is_an_int(pTHX_ const char *s, STRLEN l) 2319 8 { 2320 8 SV *result = newSVpvn(s, l); 2321 8 char *const result_c = SvPV_nolen(result); /* convenience */ 2322 8 char *out = result_c; 2323 8 bool skip = 1; 2324 8 bool ignore = 0; 2325 2326 153 while (*s) { 2327 146 switch (*s) { 2328 case ' ': 2329 ###### break; 2330 case '+': 2331 ###### if (!skip) { 2332 ###### SvREFCNT_dec(result); 2333 ###### return (NULL); 2334 } 2335 145 break; 2336 case '0': 2337 case '1': 2338 case '2': 2339 case '3': 2340 case '4': 2341 case '5': 2342 case '6': 2343 case '7': 2344 case '8': 2345 case '9': 2346 145 skip = 0; 2347 145 if (!ignore) { 2348 145 *(out++) = *s; 2349 } 2350 145 break; 2351 case '.': 2352 ###### ignore = 1; 2353 ###### break; 2354 default: 2355 1 SvREFCNT_dec(result); 2356 1 return (NULL); 2357 } 2358 145 s++; 2359 } 2360 7 *(out++) = '\0'; 2361 7 SvCUR_set(result, out - result_c); 2362 7 return (result); 2363 } 2364 2365 /* pnum must be '\0' terminated */ 2366 STATIC int 2367 S_div128(pTHX_ SV *pnum, bool *done) 2368 64 { 2369 64 STRLEN len; 2370 64 char * const s = SvPV(pnum, len); 2371 64 char *t = s; 2372 64 int m = 0; 2373 2374 64 *done = 1; 2375 1406 while (*t) { 2376 1342 const int i = m * 10 + (*t - '0'); 2377 1342 const int r = (i >> 7); /* r < 10 */ 2378 1342 m = i & 0x7F; 2379 1342 if (r) { 2380 551 *done = 0; 2381 } 2382 1342 *(t++) = '0' + r; 2383 } 2384 64 *(t++) = '\0'; 2385 64 SvCUR_set(pnum, (STRLEN) (t - s)); 2386 64 return (m); 2387 } 2388 2389 /* 2390 =for apidoc pack_cat 2391 2392 The engine implementing pack() Perl function. Note: parameters next_in_list and 2393 flags are not used. This call should not be used; use packlist instead. 2394 2395 =cut */ 2396 2397 2398 void 2399 Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) 2400 ###### { 2401 ###### tempsym_t sym; 2402 ###### PERL_UNUSED_ARG(next_in_list); 2403 ###### PERL_UNUSED_ARG(flags); 2404 2405 ###### TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); 2406 2407 ###### (void)pack_rec( cat, &sym, beglist, endlist ); 2408 } 2409 2410 2411 /* 2412 =for apidoc packlist 2413 2414 The engine implementing pack() Perl function. 2415 2416 =cut */ 2417 2418 2419 void 2420 Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, register SV **beglist, SV **endlist ) 2421 71852 { 2422 71852 STRLEN no_len; 2423 71852 tempsym_t sym; 2424 2425 71852 TEMPSYM_INIT(&sym, pat, patend, FLAG_PACK); 2426 2427 /* We're going to do changes through SvPVX(cat). Make sure it's valid. 2428 Also make sure any UTF8 flag is loaded */ 2429 71852 SvPV_force(cat, no_len); 2430 71852 if (DO_UTF8(cat)) sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; 2431 2432 71852 (void)pack_rec( cat, &sym, beglist, endlist ); 2433 } 2434 2435 /* like sv_utf8_upgrade, but also repoint the group start markers */ 2436 STATIC void 2437 20565 marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { 2438 20565 STRLEN len; 2439 20565 tempsym_t *group; 2440 20565 const char *from_ptr, *from_start, *from_end, **marks, **m; 2441 20565 char *to_start, *to_ptr; 2442 2443 20565 if (SvUTF8(sv)) return; 2444 2445 20565 from_start = SvPVX_const(sv); 2446 20565 from_end = from_start + SvCUR(sv); 2447 20641 for (from_ptr = from_start; from_ptr < from_end; from_ptr++) 2448 94 if (!NATIVE_IS_INVARIANT(*from_ptr)) break; 2449 20565 if (from_ptr == from_end) { 2450 /* Simple case: no character needs to be changed */ 2451 20547 SvUTF8_on(sv); 2452 20547 return; 2453 } 2454 2455 18 len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1; 2456 18 New('U', to_start, len, char); 2457 18 Copy(from_start, to_start, from_ptr-from_start, char); 2458 18 to_ptr = to_start + (from_ptr-from_start); 2459 2460 18 New('U', marks, sym_ptr->level+2, const char *); 2461 42 for (group=sym_ptr; group; group = group->previous) 2462 24 marks[group->level] = from_start + group->strbeg; 2463 18 marks[sym_ptr->level+1] = from_end+1; 2464 33 for (m = marks; *m < from_ptr; m++) 2465 15 *m = to_start + (*m-from_start); 2466 2467 96 for (;from_ptr < from_end; from_ptr++) { 2468 48 while (*m == from_ptr) *m++ = to_ptr; 2469 39 to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr); 2470 } 2471 18 *to_ptr = 0; 2472 2473 18 while (*m == from_ptr) *m++ = to_ptr; 2474 18 if (m != marks + sym_ptr->level+1) { 2475 ###### Safefree(marks); 2476 ###### Safefree(to_start); 2477 ###### Perl_croak(aTHX_ "Assertion: marks beyond string end"); 2478 } 2479 42 for (group=sym_ptr; group; group = group->previous) 2480 24 group->strbeg = marks[group->level] - to_start; 2481 18 Safefree(marks); 2482 2483 18 if (SvOOK(sv)) { 2484 ###### if (SvIVX(sv)) { 2485 ###### SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); 2486 ###### from_start -= SvIVX(sv); 2487 ###### SvIV_set(sv, 0); 2488 } 2489 ###### SvFLAGS(sv) &= ~SVf_OOK; 2490 } 2491 18 if (SvLEN(sv) != 0) 2492 18 Safefree(from_start); 2493 18 SvPV_set(sv, to_start); 2494 18 SvCUR_set(sv, to_ptr - to_start); 2495 18 SvLEN_set(sv, len); 2496 18 SvUTF8_on(sv); 2497 } 2498 2499 /* Exponential string grower. Makes string extension effectively O(n) 2500 needed says how many extra bytes we need (not counting the final '\0') 2501 Only grows the string if there is an actual lack of space 2502 */ 2503 STATIC char * 2504 1261 sv_exp_grow(pTHX_ SV *sv, STRLEN needed) { 2505 1261 const STRLEN cur = SvCUR(sv); 2506 1261 const STRLEN len = SvLEN(sv); 2507 1261 STRLEN extend; 2508 1261 if (len - cur > needed) return SvPVX(sv); 2509 1261 extend = needed > len ? needed : len; 2510 1261 return SvGROW(sv, len+extend+1); 2511 } 2512 2513 STATIC 2514 SV ** 2515 S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) 2516 89317 { 2517 89317 tempsym_t lookahead; 2518 89317 I32 items = endlist - beglist; 2519 89317 bool found = next_symbol(symptr); 2520 89221 bool utf8 = (symptr->flags & FLAG_PARSE_UTF8) ? 1 : 0; 2521 2522 89221 if (symptr->level == 0 && found && symptr->code == 'U') { 2523 18871 marked_upgrade(aTHX_ cat, symptr); 2524 18871 symptr->flags |= FLAG_DO_UTF8; 2525 18871 utf8 = 0; 2526 } 2527 89221 symptr->strbeg = SvCUR(cat); 2528 2529 220475 while (found) { 2530 131465 SV *fromstr; 2531 131465 STRLEN fromlen; 2532 131465 I32 len; 2533 131465 SV *lengthcode = Nullsv; 2534 131465 I32 datumtype = symptr->code; 2535 131465 howlen_t howlen = symptr->howlen; 2536 131465 char *start = SvPVX(cat); 2537 131465 char *cur = start + SvCUR(cat); 2538 2539 #define NEXTFROM (lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no) 2540 2541 131465 switch (howlen) { 2542 case e_star: 2543 22438 len = strchr("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? 2544 0 : items; 2545 22438 break; 2546 default: 2547 /* e_no_len and e_number */ 2548 109027 len = symptr->length; 2549 131465 break; 2550 } 2551 2552 131465 if (len) { 2553 119926 packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; 2554 2555 119926 if (props && !(props & PACK_SIZE_UNPREDICTABLE)) { 2556 /* We can process this letter. */ 2557 62429 STRLEN size = props & PACK_SIZE_MASK; 2558 62429 GROWING(utf8, cat, start, cur, (STRLEN) len * size); 2559 } 2560 } 2561 2562 /* Look ahead for next symbol. Do we have code/code? */ 2563 131465 lookahead = *symptr; 2564 131465 found = next_symbol(&lookahead); 2565 131454 if (symptr->flags & FLAG_SLASH) { 2566 54 IV count; 2567 54 if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack"); 2568 54 if (strchr("aAZ", lookahead.code)) { 2569 48 if (lookahead.howlen == e_number) count = lookahead.length; 2570 else { 2571 42 if (items > 0) 2572 41 count = DO_UTF8(*beglist) ? 2573 sv_len_utf8(*beglist) : sv_len(*beglist); 2574 1 else count = 0; 2575 42 if (lookahead.code == 'Z') count++; 2576 } 2577 } else { 2578 6 if (lookahead.howlen == e_number && lookahead.length < items) 2579 2 count = lookahead.length; 2580 4 else count = items; 2581 } 2582 54 lookahead.howlen = e_number; 2583 54 lookahead.length = count; 2584 54 lengthcode = sv_2mortal(newSViv(count)); 2585 } 2586 2587 /* Code inside the switch must take care to properly update 2588 cat (CUR length and '\0' termination) if it updated *cur and 2589 doesn't simply leave using break */ 2590 131454 switch(TYPE_NO_ENDIANNESS(datumtype)) { 2591 default: 2592 91 Perl_croak(aTHX_ "Invalid type '%c' in pack", 2593 (int) TYPE_NO_MODIFIERS(datumtype)); 2594 case '%': 2595 ###### Perl_croak(aTHX_ "'%%' may not be used in pack"); 2596 { 2597 27 char *from; 2598 #ifdef PERL_PACK_CAN_SHRIEKSIGN 2599 case '.' | TYPE_IS_SHRIEKING: 2600 #endif 2601 case '.': 2602 27 if (howlen == e_star) from = start; 2603 24 else if (len == 0) from = cur; 2604 else { 2605 21 tempsym_t *group = symptr; 2606 2607 24 while (--len && group) group = group->previous; 2608 21 from = group ? start + group->strbeg : start; 2609 } 2610 27 fromstr = NEXTFROM; 2611 27 len = SvIV(fromstr); 2612 27 goto resize; 2613 #ifdef PERL_PACK_CAN_SHRIEKSIGN 2614 case '@' | TYPE_IS_SHRIEKING: 2615 #endif 2616 case '@': 2617 25 from = start + symptr->strbeg; 2618 resize: 2619 #ifdef PERL_PACK_CAN_SHRIEKSIGN 2620 52 if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) 2621 #else /* PERL_PACK_CAN_SHRIEKSIGN */ 2622 if (utf8) 2623 #endif 2624 15 if (len >= 0) { 2625 64 while (len && from < cur) { 2626 51 from += UTF8SKIP(from); 2627 51 len--; 2628 } 2629 13 if (from > cur) 2630 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); 2631 13 if (len) { 2632 /* Here we know from == cur */ 2633 grow: 2634 2086 GROWING(0, cat, start, cur, len); 2635 2086 Zero(cur, len, char); 2636 2086 cur += len; 2637 2 } else if (from < cur) { 2638 1 len = cur - from; 2639 1 goto shrink; 2640 2 } else goto no_change; 2641 } else { 2642 2 cur = from; 2643 2 len = -len; 2644 2 goto utf8_shrink; 2645 } 2646 else { 2647 37 len -= cur - from; 2648 37 if (len > 0) goto grow; 2649 22 if (len == 0) goto no_change; 2650 14 len = -len; 2651 14 goto shrink; 2652 } 2653 3685 break; 2654 } 2655 case '(': { 2656 3685 tempsym_t savsym = *symptr; 2657 3685 U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); 2658 3685 symptr->flags |= group_modifiers; 2659 3685 symptr->patend = savsym.grpend; 2660 3685 symptr->level++; 2661 3685 symptr->previous = &lookahead; 2662 21041 while (len--) { 2663 17465 U32 was_utf8; 2664 17465 if (utf8) symptr->flags |= FLAG_PARSE_UTF8; 2665 17261 else symptr->flags &= ~FLAG_PARSE_UTF8; 2666 17465 was_utf8 = SvUTF8(cat); 2667 17465 symptr->patptr = savsym.grpbeg; 2668 17465 beglist = pack_rec(cat, symptr, beglist, endlist); 2669 17360 if (SvUTF8(cat) != was_utf8) 2670 /* This had better be an upgrade while in utf8==0 mode */ 2671 59 utf8 = 1; 2672 2673 17360 if (savsym.howlen == e_star && beglist == endlist) 2674 3580 break; /* No way to continue */ 2675 } 2676 3580 lookahead.flags = symptr->flags & ~group_modifiers; 2677 3580 goto no_change; 2678 } 2679 case 'X' | TYPE_IS_SHRIEKING: 2680 734 if (!len) /* Avoid division by 0 */ 2681 13 len = 1; 2682 734 if (utf8) { 2683 11 char *hop, *last; 2684 11 I32 l = len; 2685 11 hop = last = start; 2686 181 while (hop < cur) { 2687 170 hop += UTF8SKIP(hop); 2688 170 if (--l == 0) { 2689 20 last = hop; 2690 20 l = len; 2691 } 2692 } 2693 11 if (last > cur) 2694 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); 2695 11 cur = last; 2696 11 break; 2697 } 2698 723 len = (cur-start) % len; 2699 /* FALL THROUGH */ 2700 case 'X': 2701 1459 if (utf8) { 2702 11 if (len < 1) goto no_change; 2703 utf8_shrink: 2704 100 while (len > 0) { 2705 88 if (cur <= start) 2706 ###### Perl_croak(aTHX_ "'%c' outside of string in pack", 2707 (int) TYPE_NO_MODIFIERS(datumtype)); 2708 257 while (--cur, UTF8_IS_CONTINUATION(*cur)) { 2709 169 if (cur <= start) 2710 ###### Perl_croak(aTHX_ "'%c' outside of string in pack", 2711 (int) TYPE_NO_MODIFIERS(datumtype)); 2712 } 2713 88 len--; 2714 } 2715 } else { 2716 shrink: 2717 1463 if (cur - start < len) 2718 1 Perl_croak(aTHX_ "'%c' outside of string in pack", 2719 (int) TYPE_NO_MODIFIERS(datumtype)); 2720 1462 cur -= len; 2721 } 2722 1474 if (cur < start+symptr->strbeg) { 2723 /* Make sure group starts don't point into the void */ 2724 10 tempsym_t *group; 2725 10 const STRLEN length = cur-start; 2726 20 for (group = symptr; 2727 group && length < group->strbeg; 2728 10 group = group->previous) group->strbeg = length; 2729 10 lookahead.strbeg = length; 2730 } 2731 10 break; 2732 case 'x' | TYPE_IS_SHRIEKING: { 2733 739 I32 ai32; 2734 739 if (!len) /* Avoid division by 0 */ 2735 ###### len = 1; 2736 739 if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len; 2737 728 else ai32 = (cur - start) % len; 2738 739 if (ai32 == 0) goto no_change; 2739 313 len -= ai32; 2740 } 2741 /* FALL THROUGH */ 2742 case 'x': 2743 313 goto grow; 2744 case 'A': 2745 case 'Z': 2746 case 'a': { 2747 3387 const char *aptr; 2748 2749 3387 fromstr = NEXTFROM; 2750 3387 aptr = SvPV_const(fromstr, fromlen); 2751 3387 if (DO_UTF8(fromstr)) { 2752 1617 const char *end, *s; 2753 2754 1617 if (!utf8 && !SvUTF8(cat)) { 2755 1593 marked_upgrade(aTHX_ cat, symptr); 2756 1593 lookahead.flags |= FLAG_DO_UTF8; 2757 1593 lookahead.strbeg = symptr->strbeg; 2758 1593 utf8 = 1; 2759 1593 start = SvPVX(cat); 2760 1593 cur = start + SvCUR(cat); 2761 } 2762 1617 if (howlen == e_star) { 2763 1515 if (utf8) goto string_copy; 2764 3 len = fromlen+1; 2765 } 2766 105 s = aptr; 2767 105 end = aptr + fromlen; 2768 105 fromlen = datumtype == 'Z' ? len-1 : len; 2769 177 while ((I32) fromlen > 0 && s < end) { 2770 72 s += UTF8SKIP(s); 2771 72 fromlen--; 2772 } 2773 105 if (s > end) 2774 ###### Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); 2775 105 if (utf8) { 2776 87 len = fromlen; 2777 87 if (datumtype == 'Z') len++; 2778 87 fromlen = s-aptr; 2779 87 len += fromlen; 2780 2781 87 goto string_copy; 2782 } 2783 18 fromlen = len - fromlen; 2784 18 if (datumtype == 'Z') fromlen--; 2785 18 if (howlen == e_star) { 2786 3 len = fromlen; 2787 3 if (datumtype == 'Z') len++; 2788 } 2789 18 GROWING(0, cat, start, cur, len); 2790 18 if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen, 2791 datumtype | TYPE_IS_PACK)) 2792 ###### Perl_croak(aTHX_ "Perl bug: predicted utf8 length not available"); 2793 18 cur += fromlen; 2794 18 len -= fromlen; 2795 1770 } else if (utf8) { 2796 32 if (howlen == e_star) { 2797 24 len = fromlen; 2798 24 if (datumtype == 'Z') len++; 2799 } 2800 32 if (len <= (I32) fromlen) { 2801 32 fromlen = len; 2802 32 if (datumtype == 'Z' && fromlen > 0) fromlen--; 2803 } 2804 /* assumes a byte expands to at most UTF8_EXPAND bytes on 2805 upgrade, so: 2806 expected_length <= from_len*UTF8_EXPAND + (len-from_len) */ 2807 32 GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len); 2808 32 len -= fromlen; 2809 97 while (fromlen > 0) { 2810 65 cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr); 2811 65 aptr++; 2812 65 fromlen--; 2813 } 2814 } else { 2815 string_copy: 2816 3337 if (howlen == e_star) { 2817 1577 len = fromlen; 2818 1577 if (datumtype == 'Z') len++; 2819 } 2820 3337 if (len <= (I32) fromlen) { 2821 2390 fromlen = len; 2822 2390 if (datumtype == 'Z' && fromlen > 0) fromlen--; 2823 } 2824 3337 GROWING(0, cat, start, cur, len); 2825 3337 Copy(aptr, cur, fromlen, char); 2826 3337 cur += fromlen; 2827 3337 len -= fromlen; 2828 } 2829 3387 memset(cur, datumtype == 'A' ? ' ' : '\0', len); 2830 3387 cur += len; 2831 3387 break; 2832 } 2833 case 'B': 2834 case 'b': { 2835 653 const char *str, *end; 2836 653 I32 l, field_len; 2837 653 U8 bits; 2838 653 bool utf8_source; 2839 653 U32 utf8_flags; 2840 2841 653 fromstr = NEXTFROM; 2842 653 str = SvPV_const(fromstr, fromlen); 2843 653 end = str + fromlen; 2844 653 if (DO_UTF8(fromstr)) { 2845 ###### utf8_source = TRUE; 2846 ###### utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; 2847 } else { 2848 653 utf8_source = FALSE; 2849 653 utf8_flags = 0; /* Unused, but keep compilers happy */ 2850 } 2851 653 if (howlen == e_star) len = fromlen; 2852 653 field_len = (len+7)/8; 2853 653 GROWING(utf8, cat, start, cur, field_len); 2854 653 if (len > (I32)fromlen) len = fromlen; 2855 653 bits = 0; 2856 653 l = 0; 2857 653 if (datumtype == 'B') 2858 4713 while (l++ < len) { 2859 4295 if (utf8_source) { 2860 ###### UV val; 2861 ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); 2862 ###### bits |= val & 1; 2863 4295 } else bits |= *str++ & 1; 2864 4295 if (l & 7) bits <<= 1; 2865 else { 2866 466 PUSH_BYTE(utf8, cur, bits); 2867 466 bits = 0; 2868 } 2869 } 2870 else 2871 /* datumtype == 'b' */ 2872 858 while (l++ < len) { 2873 623 if (utf8_source) { 2874 ###### UV val; 2875 ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); 2876 ###### if (val & 1) bits |= 0x80; 2877 623 } else if (*str++ & 1) 2878 441 bits |= 0x80; 2879 623 if (l & 7) bits >>= 1; 2880 else { 2881 8 PUSH_BYTE(utf8, cur, bits); 2882 8 bits = 0; 2883 } 2884 } 2885 653 l--; 2886 653 if (l & 7) { 2887 472 if (datumtype == 'B') 2888 237 bits <<= 7 - (l & 7); 2889 else 2890 235 bits >>= 7 - (l & 7); 2891 472 PUSH_BYTE(utf8, cur, bits); 2892 472 l += 7; 2893 } 2894 /* Determine how many chars are left in the requested field */ 2895 653 l /= 8; 2896 653 if (howlen == e_star) field_len = 0; 2897 470 else field_len -= l; 2898 653 Zero(cur, field_len, char); 2899 653 cur += field_len; 2900 653 break; 2901 } 2902 case 'H': 2903 case 'h': { 2904 1389 const char *str, *end; 2905 1389 I32 l, field_len; 2906 1389 U8 bits; 2907 1389 bool utf8_source; 2908 1389 U32 utf8_flags; 2909 2910 1389 fromstr = NEXTFROM; 2911 1389 str = SvPV_const(fromstr, fromlen); 2912 1389 end = str + fromlen; 2913 1389 if (DO_UTF8(fromstr)) { 2914 ###### utf8_source = TRUE; 2915 ###### utf8_flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; 2916 } else { 2917 1389 utf8_source = FALSE; 2918 1389 utf8_flags = 0; /* Unused, but keep compilers happy */ 2919 } 2920 1389 if (howlen == e_star) len = fromlen; 2921 1389 field_len = (len+1)/2; 2922 1389 GROWING(utf8, cat, start, cur, field_len); 2923 1389 if (!utf8 && len > (I32)fromlen) len = fromlen; 2924 1389 bits = 0; 2925 1389 l = 0; 2926 1389 if (datumtype == 'H') 2927 51892 while (l++ < len) { 2928 50739 if (utf8_source) { 2929 ###### UV val; 2930 ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); 2931 ###### if (val < 256 && isALPHA(val)) 2932 ###### bits |= (val + 9) & 0xf; 2933 else 2934 ###### bits |= val & 0xf; 2935 50739 } else if (isALPHA(*str)) 2936 4112 bits |= (*str++ + 9) & 0xf; 2937 else 2938 46627 bits |= *str++ & 0xf; 2939 50739 if (l & 1) bits <<= 4; 2940 else { 2941 25329 PUSH_BYTE(utf8, cur, bits); 2942 25329 bits = 0; 2943 } 2944 } 2945 else 2946 641 while (l++ < len) { 2947 405 if (utf8_source) { 2948 ###### UV val; 2949 ###### NEXT_UNI_VAL(val, cur, str, end, utf8_flags); 2950 ###### if (val < 256 && isALPHA(val)) 2951 ###### bits |= ((val + 9) & 0xf) << 4; 2952 else 2953 ###### bits |= (val & 0xf) << 4; 2954 405 } else if (isALPHA(*str)) 2955 243 bits |= ((*str++ + 9) & 0xf) << 4; 2956 else 2957 162 bits |= (*str++ & 0xf) << 4; 2958 405 if (l & 1) bits >>= 4; 2959 else { 2960 162 PUSH_BYTE(utf8, cur, bits); 2961 162 bits = 0; 2962 } 2963 } 2964 1389 l--; 2965 1389 if (l & 1) { 2966 162 PUSH_BYTE(utf8, cur, bits); 2967 162 l++; 2968 } 2969 /* Determine how many chars are left in the requested field */ 2970 1389 l /= 2; 2971 1389 if (howlen == e_star) field_len = 0; 2972 472 else field_len -= l; 2973 1389 Zero(cur, field_len, char); 2974 1389 cur += field_len; 2975 1389 break; 2976 } 2977 case 'c': 2978 1547 while (len-- > 0) { 2979 1270 IV aiv; 2980 1270 fromstr = NEXTFROM; 2981 1270 aiv = SvIV(fromstr); 2982 1270 if ((-128 > aiv || aiv > 127) && 2983 ckWARN(WARN_PACK)) 2984 2 Perl_warner(aTHX_ packWARN(WARN_PACK), 2985 "Character in 'c' format wrapped in pack"); 2986 1270 PUSH_BYTE(utf8, cur, aiv & 0xff); 2987 } 2988 26030 break; 2989 case 'C': 2990 26030 if (len == 0) { 2991 112 utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; 2992 112 break; 2993 } 2994 25918 GROWING(0, cat, start, cur, len); 2995 54724 while (len-- > 0) { 2996 28806 IV aiv; 2997 28806 fromstr = NEXTFROM; 2998 28806 aiv = SvIV(fromstr); 2999 28806 if ((0 > aiv || aiv > 0xff) && 3000 ckWARN(WARN_PACK)) 3001 2 Perl_warner(aTHX_ packWARN(WARN_PACK), 3002 "Character in 'C' format wrapped in pack"); 3003 28806 *cur++ = aiv & 0xff; 3004 } 3005 416 break; 3006 case 'W': { 3007 416 char *end; 3008 416 U8 in_bytes = IN_BYTES; 3009 3010 416 end = start+SvLEN(cat)-1; 3011 416 if (utf8) end -= UTF8_MAXLEN-1; 3012 1891 while (len-- > 0) { 3013 1475 UV auv; 3014 1475 fromstr = NEXTFROM; 3015 1475 auv = SvUV(fromstr); 3016 1475 if (in_bytes) auv = auv % 0x100; 3017 1475 if (utf8) { 3018 W_utf8: 3019 1326