1 /* sv.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 * "I wonder what the Entish is for 'yes' and 'no'," he thought. 10 * 11 * 12 * This file contains the code that creates, manipulates and destroys 13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the 14 * structure of an SV, so their creation and destruction is handled 15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode 16 * level functions (eg. substr, split, join) for each of the types are 17 * in the pp*.c files. 18 */ 19 20 #include "EXTERN.h" 21 #define PERL_IN_SV_C 22 #include "perl.h" 23 #include "regcomp.h" 24 25 #define FCALL *f 26 27 #ifdef __Lynx__ 28 /* Missing proto on LynxOS */ 29 char *gconvert(double, int, int, char *); 30 #endif 31 32 #ifdef PERL_UTF8_CACHE_ASSERT 33 /* if adding more checks watch out for the following tests: 34 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t 35 * lib/utf8.t lib/Unicode/Collate/t/index.t 36 * --jhi 37 */ 38 # define ASSERT_UTF8_CACHE(cache) \ 39 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ 40 assert((cache)[2] <= (cache)[3]); \ 41 assert((cache)[3] <= (cache)[1]);} \ 42 } STMT_END 43 #else 44 # define ASSERT_UTF8_CACHE(cache) NOOP 45 #endif 46 47 #ifdef PERL_OLD_COPY_ON_WRITE 48 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) 49 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) 50 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- 51 on-write. */ 52 #endif 53 54 /* ============================================================================ 55 56 =head1 Allocation and deallocation of SVs. 57 58 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct 59 sv, av, hv...) contains type and reference count information, and for 60 many types, a pointer to the body (struct xrv, xpv, xpviv...), which 61 contains fields specific to each type. Some types store all they need 62 in the head, so don't have a body. 63 64 In all but the most memory-paranoid configuations (ex: PURIFY), heads 65 and bodies are allocated out of arenas, which by default are 66 approximately 4K chunks of memory parcelled up into N heads or bodies. 67 Sv-bodies are allocated by their sv-type, guaranteeing size 68 consistency needed to allocate safely from arrays. 69 70 For SV-heads, the first slot in each arena is reserved, and holds a 71 link to the next arena, some flags, and a note of the number of slots. 72 Snaked through each arena chain is a linked list of free items; when 73 this becomes empty, an extra arena is allocated and divided up into N 74 items which are threaded into the free list. 75 76 SV-bodies are similar, but they use arena-sets by default, which 77 separate the link and info from the arena itself, and reclaim the 1st 78 slot in the arena. SV-bodies are further described later. 79 80 The following global variables are associated with arenas: 81 82 PL_sv_arenaroot pointer to list of SV arenas 83 PL_sv_root pointer to list of free SV structures 84 85 PL_body_arenas head of linked-list of body arenas 86 PL_body_roots[] array of pointers to list of free bodies of svtype 87 arrays are indexed by the svtype needed 88 89 A few special SV heads are not allocated from an arena, but are 90 instead directly created in the interpreter structure, eg PL_sv_undef. 91 The size of arenas can be changed from the default by setting 92 PERL_ARENA_SIZE appropriately at compile time. 93 94 The SV arena serves the secondary purpose of allowing still-live SVs 95 to be located and destroyed during final cleanup. 96 97 At the lowest level, the macros new_SV() and del_SV() grab and free 98 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() 99 to return the SV to the free list with error checking.) new_SV() calls 100 more_sv() / sv_add_arena() to add an extra arena if the free list is empty. 101 SVs in the free list have their SvTYPE field set to all ones. 102 103 At the time of very final cleanup, sv_free_arenas() is called from 104 perl_destruct() to physically free all the arenas allocated since the 105 start of the interpreter. 106 107 The function visit() scans the SV arenas list, and calls a specified 108 function for each SV it finds which is still live - ie which has an SvTYPE 109 other than all 1's, and a non-zero SvREFCNT. visit() is used by the 110 following functions (specified as [function that calls visit()] / [function 111 called by visit() for each SV]): 112 113 sv_report_used() / do_report_used() 114 dump all remaining SVs (debugging aid) 115 116 sv_clean_objs() / do_clean_objs(),do_clean_named_objs() 117 Attempt to free all objects pointed to by RVs, 118 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined, 119 try to do the same for all objects indirectly 120 referenced by typeglobs too. Called once from 121 perl_destruct(), prior to calling sv_clean_all() 122 below. 123 124 sv_clean_all() / do_clean_all() 125 SvREFCNT_dec(sv) each remaining SV, possibly 126 triggering an sv_free(). It also sets the 127 SVf_BREAK flag on the SV to indicate that the 128 refcnt has been artificially lowered, and thus 129 stopping sv_free() from giving spurious warnings 130 about SVs which unexpectedly have a refcnt 131 of zero. called repeatedly from perl_destruct() 132 until there are no SVs left. 133 134 =head2 Arena allocator API Summary 135 136 Private API to rest of sv.c 137 138 new_SV(), del_SV(), 139 140 new_XIV(), del_XIV(), 141 new_XNV(), del_XNV(), 142 etc 143 144 Public API: 145 146 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() 147 148 =cut 149 150 ============================================================================ */ 151 152 /* 153 * "A time to plant, and a time to uproot what was planted..." 154 */ 155 156 void 157 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) 158 { 159 dVAR; 160 void *new_chunk; 161 U32 new_chunk_size; 162 new_chunk = (void *)(chunk); 163 new_chunk_size = (chunk_size); 164 if (new_chunk_size > PL_nice_chunk_size) { 165 Safefree(PL_nice_chunk); 166 PL_nice_chunk = (char *) new_chunk; 167 PL_nice_chunk_size = new_chunk_size; 168 } else { 169 Safefree(chunk); 170 } 171 } 172 173 #ifdef DEBUG_LEAKING_SCALARS 174 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) 175 #else 176 # define FREE_SV_DEBUG_FILE(sv) 177 #endif 178 179 #ifdef PERL_POISON 180 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) 181 /* Whilst I'd love to do this, it seems that things like to check on 182 unreferenced scalars 183 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) 184 */ 185 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ 186 PoisonNew(&SvREFCNT(sv), 1, U32) 187 #else 188 # define SvARENA_CHAIN(sv) SvANY(sv) 189 # define POSION_SV_HEAD(sv) 190 #endif 191 192 #define plant_SV(p) \ 193 STMT_START { \ 194 FREE_SV_DEBUG_FILE(p); \ 195 POSION_SV_HEAD(p); \ 196 SvARENA_CHAIN(p) = (void *)PL_sv_root; \ 197 SvFLAGS(p) = SVTYPEMASK; \ 198 PL_sv_root = (p); \ 199 --PL_sv_count; \ 200 } STMT_END 201 202 #define uproot_SV(p) \ 203 STMT_START { \ 204 (p) = PL_sv_root; \ 205 PL_sv_root = (SV*)SvARENA_CHAIN(p); \ 206 ++PL_sv_count; \ 207 } STMT_END 208 209 210 /* make some more SVs by adding another arena */ 211 212 STATIC SV* 213 S_more_sv(pTHX) 214 { 215 dVAR; 216 SV* sv; 217 218 if (PL_nice_chunk) { 219 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); 220 PL_nice_chunk = NULL; 221 PL_nice_chunk_size = 0; 222 } 223 else { 224 char *chunk; /* must use New here to match call to */ 225 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ 226 sv_add_arena(chunk, PERL_ARENA_SIZE, 0); 227 } 228 uproot_SV(sv); 229 return sv; 230 } 231 232 /* new_SV(): return a new, empty SV head */ 233 234 #ifdef DEBUG_LEAKING_SCALARS 235 /* provide a real function for a debugger to play with */ 236 STATIC SV* 237 S_new_SV(pTHX) 238 { 239 SV* sv; 240 241 if (PL_sv_root) 242 uproot_SV(sv); 243 else 244 sv = S_more_sv(aTHX); 245 SvANY(sv) = 0; 246 SvREFCNT(sv) = 1; 247 SvFLAGS(sv) = 0; 248 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; 249 sv->sv_debug_line = (U16) (PL_parser 250 ? PL_parser->copline == NOLINE 251 ? PL_curcop 252 ? CopLINE(PL_curcop) 253 : 0 254 : PL_parser->copline 255 : 0); 256 sv->sv_debug_inpad = 0; 257 sv->sv_debug_cloned = 0; 258 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; 259 260 return sv; 261 } 262 # define new_SV(p) (p)=S_new_SV(aTHX) 263 264 #else 265 # define new_SV(p) \ 266 STMT_START { \ 267 if (PL_sv_root) \ 268 uproot_SV(p); \ 269 else \ 270 (p) = S_more_sv(aTHX); \ 271 SvANY(p) = 0; \ 272 SvREFCNT(p) = 1; \ 273 SvFLAGS(p) = 0; \ 274 } STMT_END 275 #endif 276 277 278 /* del_SV(): return an empty SV head to the free list */ 279 280 #ifdef DEBUGGING 281 282 #define del_SV(p) \ 283 STMT_START { \ 284 if (DEBUG_D_TEST) \ 285 del_sv(p); \ 286 else \ 287 plant_SV(p); \ 288 } STMT_END 289 290 STATIC void 291 S_del_sv(pTHX_ SV *p) 292 { 293 dVAR; 294 if (DEBUG_D_TEST) { 295 SV* sva; 296 bool ok = 0; 297 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { 298 const SV * const sv = sva + 1; 299 const SV * const svend = &sva[SvREFCNT(sva)]; 300 if (p >= sv && p < svend) { 301 ok = 1; 302 break; 303 } 304 } 305 if (!ok) { 306 if (ckWARN_d(WARN_INTERNAL)) 307 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 308 "Attempt to free non-arena SV: 0x%"UVxf 309 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); 310 return; 311 } 312 } 313 plant_SV(p); 314 } 315 316 #else /* ! DEBUGGING */ 317 318 #define del_SV(p) plant_SV(p) 319 320 #endif /* DEBUGGING */ 321 322 323 /* 324 =head1 SV Manipulation Functions 325 326 =for apidoc sv_add_arena 327 328 Given a chunk of memory, link it to the head of the list of arenas, 329 and split it into a list of free SVs. 330 331 =cut 332 */ 333 334 void 335 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) 336 { 337 dVAR; 338 SV* const sva = (SV*)ptr; 339 register SV* sv; 340 register SV* svend; 341 342 /* The first SV in an arena isn't an SV. */ 343 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ 344 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ 345 SvFLAGS(sva) = flags; /* FAKE if not to be freed */ 346 347 PL_sv_arenaroot = sva; 348 PL_sv_root = sva + 1; 349 350 svend = &sva[SvREFCNT(sva) - 1]; 351 sv = sva + 1; 352 while (sv < svend) { 353 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1); 354 #ifdef DEBUGGING 355 SvREFCNT(sv) = 0; 356 #endif 357 /* Must always set typemask because it's always checked in on cleanup 358 when the arenas are walked looking for objects. */ 359 SvFLAGS(sv) = SVTYPEMASK; 360 sv++; 361 } 362 SvARENA_CHAIN(sv) = 0; 363 #ifdef DEBUGGING 364 SvREFCNT(sv) = 0; 365 #endif 366 SvFLAGS(sv) = SVTYPEMASK; 367 } 368 369 /* visit(): call the named function for each non-free SV in the arenas 370 * whose flags field matches the flags/mask args. */ 371 372 STATIC I32 373 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask) 374 { 375 dVAR; 376 SV* sva; 377 I32 visited = 0; 378 379 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { 380 register const SV * const svend = &sva[SvREFCNT(sva)]; 381 register SV* sv; 382 for (sv = sva + 1; sv < svend; ++sv) { 383 if (SvTYPE(sv) != SVTYPEMASK 384 && (sv->sv_flags & mask) == flags 385 && SvREFCNT(sv)) 386 { 387 (FCALL)(aTHX_ sv); 388 ++visited; 389 } 390 } 391 } 392 return visited; 393 } 394 395 #ifdef DEBUGGING 396 397 /* called by sv_report_used() for each live SV */ 398 399 static void 400 do_report_used(pTHX_ SV *sv) 401 { 402 if (SvTYPE(sv) != SVTYPEMASK) { 403 PerlIO_printf(Perl_debug_log, "****\n"); 404 sv_dump(sv); 405 } 406 } 407 #endif 408 409 /* 410 =for apidoc sv_report_used 411 412 Dump the contents of all SVs not yet freed. (Debugging aid). 413 414 =cut 415 */ 416 417 void 418 Perl_sv_report_used(pTHX) 419 { 420 #ifdef DEBUGGING 421 visit(do_report_used, 0, 0); 422 #else 423 PERL_UNUSED_CONTEXT; 424 #endif 425 } 426 427 /* called by sv_clean_objs() for each live SV */ 428 429 static void 430 do_clean_objs(pTHX_ SV *ref) 431 { 432 dVAR; 433 assert (SvROK(ref)); 434 { 435 SV * const target = SvRV(ref); 436 if (SvOBJECT(target)) { 437 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); 438 if (SvWEAKREF(ref)) { 439 sv_del_backref(target, ref); 440 SvWEAKREF_off(ref); 441 SvRV_set(ref, NULL); 442 } else { 443 SvROK_off(ref); 444 SvRV_set(ref, NULL); 445 SvREFCNT_dec(target); 446 } 447 } 448 } 449 450 /* XXX Might want to check arrays, etc. */ 451 } 452 453 /* called by sv_clean_objs() for each live SV */ 454 455 #ifndef DISABLE_DESTRUCTOR_KLUDGE 456 static void 457 do_clean_named_objs(pTHX_ SV *sv) 458 { 459 dVAR; 460 assert(SvTYPE(sv) == SVt_PVGV); 461 assert(isGV_with_GP(sv)); 462 if (GvGP(sv)) { 463 if (( 464 #ifdef PERL_DONT_CREATE_GVSV 465 GvSV(sv) && 466 #endif 467 SvOBJECT(GvSV(sv))) || 468 (GvAV(sv) && SvOBJECT(GvAV(sv))) || 469 (GvHV(sv) && SvOBJECT(GvHV(sv))) || 470 /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */ 471 (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) || 472 (GvCV(sv) && SvOBJECT(GvCV(sv))) ) 473 { 474 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); 475 SvFLAGS(sv) |= SVf_BREAK; 476 SvREFCNT_dec(sv); 477 } 478 } 479 } 480 #endif 481 482 /* 483 =for apidoc sv_clean_objs 484 485 Attempt to destroy all objects not yet freed 486 487 =cut 488 */ 489 490 void 491 Perl_sv_clean_objs(pTHX) 492 { 493 dVAR; 494 PL_in_clean_objs = TRUE; 495 visit(do_clean_objs, SVf_ROK, SVf_ROK); 496 #ifndef DISABLE_DESTRUCTOR_KLUDGE 497 /* some barnacles may yet remain, clinging to typeglobs */ 498 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); 499 #endif 500 PL_in_clean_objs = FALSE; 501 } 502 503 /* called by sv_clean_all() for each live SV */ 504 505 static void 506 do_clean_all(pTHX_ SV *sv) 507 { 508 dVAR; 509 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); 510 SvFLAGS(sv) |= SVf_BREAK; 511 SvREFCNT_dec(sv); 512 } 513 514 /* 515 =for apidoc sv_clean_all 516 517 Decrement the refcnt of each remaining SV, possibly triggering a 518 cleanup. This function may have to be called multiple times to free 519 SVs which are in complex self-referential hierarchies. 520 521 =cut 522 */ 523 524 I32 525 Perl_sv_clean_all(pTHX) 526 { 527 dVAR; 528 I32 cleaned; 529 PL_in_clean_all = TRUE; 530 cleaned = visit(do_clean_all, 0,0); 531 PL_in_clean_all = FALSE; 532 return cleaned; 533 } 534 535 /* 536 ARENASETS: a meta-arena implementation which separates arena-info 537 into struct arena_set, which contains an array of struct 538 arena_descs, each holding info for a single arena. By separating 539 the meta-info from the arena, we recover the 1st slot, formerly 540 borrowed for list management. The arena_set is about the size of an 541 arena, avoiding the needless malloc overhead of a naive linked-list. 542 543 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused 544 memory in the last arena-set (1/2 on average). In trade, we get 545 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for 546 smaller types). The recovery of the wasted space allows use of 547 small arenas for large, rare body types, by changing array* fields 548 in body_details_by_type[] below. 549 */ 550 struct arena_desc { 551 char *arena; /* the raw storage, allocated aligned */ 552 size_t size; /* its size ~4k typ */ 553 U32 misc; /* type, and in future other things. */ 554 }; 555 556 struct arena_set; 557 558 /* Get the maximum number of elements in set[] such that struct arena_set 559 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and 560 therefore likely to be 1 aligned memory page. */ 561 562 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ 563 - 2 * sizeof(int)) / sizeof (struct arena_desc)) 564 565 struct arena_set { 566 struct arena_set* next; 567 unsigned int set_size; /* ie ARENAS_PER_SET */ 568 unsigned int curr; /* index of next available arena-desc */ 569 struct arena_desc set[ARENAS_PER_SET]; 570 }; 571 572 /* 573 =for apidoc sv_free_arenas 574 575 Deallocate the memory used by all arenas. Note that all the individual SV 576 heads and bodies within the arenas must already have been freed. 577 578 =cut 579 */ 580 void 581 Perl_sv_free_arenas(pTHX) 582 { 583 dVAR; 584 SV* sva; 585 SV* svanext; 586 unsigned int i; 587 588 /* Free arenas here, but be careful about fake ones. (We assume 589 contiguity of the fake ones with the corresponding real ones.) */ 590 591 for (sva = PL_sv_arenaroot; sva; sva = svanext) { 592 svanext = (SV*) SvANY(sva); 593 while (svanext && SvFAKE(svanext)) 594 svanext = (SV*) SvANY(svanext); 595 596 if (!SvFAKE(sva)) 597 Safefree(sva); 598 } 599 600 { 601 struct arena_set *aroot = (struct arena_set*) PL_body_arenas; 602 603 while (aroot) { 604 struct arena_set *current = aroot; 605 i = aroot->curr; 606 while (i--) { 607 assert(aroot->set[i].arena); 608 Safefree(aroot->set[i].arena); 609 } 610 aroot = aroot->next; 611 Safefree(current); 612 } 613 } 614 PL_body_arenas = 0; 615 616 i = PERL_ARENA_ROOTS_SIZE; 617 while (i--) 618 PL_body_roots[i] = 0; 619 620 Safefree(PL_nice_chunk); 621 PL_nice_chunk = NULL; 622 PL_nice_chunk_size = 0; 623 PL_sv_arenaroot = 0; 624 PL_sv_root = 0; 625 } 626 627 /* 628 Here are mid-level routines that manage the allocation of bodies out 629 of the various arenas. There are 5 kinds of arenas: 630 631 1. SV-head arenas, which are discussed and handled above 632 2. regular body arenas 633 3. arenas for reduced-size bodies 634 4. Hash-Entry arenas 635 5. pte arenas (thread related) 636 637 Arena types 2 & 3 are chained by body-type off an array of 638 arena-root pointers, which is indexed by svtype. Some of the 639 larger/less used body types are malloced singly, since a large 640 unused block of them is wasteful. Also, several svtypes dont have 641 bodies; the data fits into the sv-head itself. The arena-root 642 pointer thus has a few unused root-pointers (which may be hijacked 643 later for arena types 4,5) 644 645 3 differs from 2 as an optimization; some body types have several 646 unused fields in the front of the structure (which are kept in-place 647 for consistency). These bodies can be allocated in smaller chunks, 648 because the leading fields arent accessed. Pointers to such bodies 649 are decremented to point at the unused 'ghost' memory, knowing that 650 the pointers are used with offsets to the real memory. 651 652 HE, HEK arenas are managed separately, with separate code, but may 653 be merge-able later.. 654 655 PTE arenas are not sv-bodies, but they share these mid-level 656 mechanics, so are considered here. The new mid-level mechanics rely 657 on the sv_type of the body being allocated, so we just reserve one 658 of the unused body-slots for PTEs, then use it in those (2) PTE 659 contexts below (line ~10k) 660 */ 661 662 /* get_arena(size): this creates custom-sized arenas 663 TBD: export properly for hv.c: S_more_he(). 664 */ 665 void* 666 Perl_get_arena(pTHX_ size_t arena_size, U32 misc) 667 { 668 dVAR; 669 struct arena_desc* adesc; 670 struct arena_set *aroot = (struct arena_set*) PL_body_arenas; 671 unsigned int curr; 672 673 /* shouldnt need this 674 if (!arena_size) arena_size = PERL_ARENA_SIZE; 675 */ 676 677 /* may need new arena-set to hold new arena */ 678 if (!aroot || aroot->curr >= aroot->set_size) { 679 struct arena_set *newroot; 680 Newxz(newroot, 1, struct arena_set); 681 newroot->set_size = ARENAS_PER_SET; 682 newroot->next = aroot; 683 aroot = newroot; 684 PL_body_arenas = (void *) newroot; 685 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); 686 } 687 688 /* ok, now have arena-set with at least 1 empty/available arena-desc */ 689 curr = aroot->curr++; 690 adesc = &(aroot->set[curr]); 691 assert(!adesc->arena); 692 693 Newx(adesc->arena, arena_size, char); 694 adesc->size = arena_size; 695 adesc->misc = misc; 696 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 697 curr, (void*)adesc->arena, (UV)arena_size)); 698 699 return adesc->arena; 700 } 701 702 703 /* return a thing to the free list */ 704 705 #define del_body(thing, root) \ 706 STMT_START { \ 707 void ** const thing_copy = (void **)thing;\ 708 *thing_copy = *root; \ 709 *root = (void*)thing_copy; \ 710 } STMT_END 711 712 /* 713 714 =head1 SV-Body Allocation 715 716 Allocation of SV-bodies is similar to SV-heads, differing as follows; 717 the allocation mechanism is used for many body types, so is somewhat 718 more complicated, it uses arena-sets, and has no need for still-live 719 SV detection. 720 721 At the outermost level, (new|del)_X*V macros return bodies of the 722 appropriate type. These macros call either (new|del)_body_type or 723 (new|del)_body_allocated macro pairs, depending on specifics of the 724 type. Most body types use the former pair, the latter pair is used to 725 allocate body types with "ghost fields". 726 727 "ghost fields" are fields that are unused in certain types, and 728 consequently dont need to actually exist. They are declared because 729 they're part of a "base type", which allows use of functions as 730 methods. The simplest examples are AVs and HVs, 2 aggregate types 731 which don't use the fields which support SCALAR semantics. 732 733 For these types, the arenas are carved up into *_allocated size 734 chunks, we thus avoid wasted memory for those unaccessed members. 735 When bodies are allocated, we adjust the pointer back in memory by the 736 size of the bit not allocated, so it's as if we allocated the full 737 structure. (But things will all go boom if you write to the part that 738 is "not there", because you'll be overwriting the last members of the 739 preceding structure in memory.) 740 741 We calculate the correction using the STRUCT_OFFSET macro. For 742 example, if xpv_allocated is the same structure as XPV then the two 743 OFFSETs sum to zero, and the pointer is unchanged. If the allocated 744 structure is smaller (no initial NV actually allocated) then the net 745 effect is to subtract the size of the NV from the pointer, to return a 746 new pointer as if an initial NV were actually allocated. 747 748 This is the same trick as was used for NV and IV bodies. Ironically it 749 doesn't need to be used for NV bodies any more, because NV is now at 750 the start of the structure. IV bodies don't need it either, because 751 they are no longer allocated. 752 753 In turn, the new_body_* allocators call S_new_body(), which invokes 754 new_body_inline macro, which takes a lock, and takes a body off the 755 linked list at PL_body_roots[sv_type], calling S_more_bodies() if 756 necessary to refresh an empty list. Then the lock is released, and 757 the body is returned. 758 759 S_more_bodies calls get_arena(), and carves it up into an array of N 760 bodies, which it strings into a linked list. It looks up arena-size 761 and body-size from the body_details table described below, thus 762 supporting the multiple body-types. 763 764 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and 765 the (new|del)_X*V macros are mapped directly to malloc/free. 766 767 */ 768 769 /* 770 771 For each sv-type, struct body_details bodies_by_type[] carries 772 parameters which control these aspects of SV handling: 773 774 Arena_size determines whether arenas are used for this body type, and if 775 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to 776 zero, forcing individual mallocs and frees. 777 778 Body_size determines how big a body is, and therefore how many fit into 779 each arena. Offset carries the body-pointer adjustment needed for 780 *_allocated body types, and is used in *_allocated macros. 781 782 But its main purpose is to parameterize info needed in 783 Perl_sv_upgrade(). The info here dramatically simplifies the function 784 vs the implementation in 5.8.7, making it table-driven. All fields 785 are used for this, except for arena_size. 786 787 For the sv-types that have no bodies, arenas are not used, so those 788 PL_body_roots[sv_type] are unused, and can be overloaded. In 789 something of a special case, SVt_NULL is borrowed for HE arenas; 790 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the 791 bodies_by_type[SVt_NULL] slot is not used, as the table is not 792 available in hv.c. 793 794 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless, 795 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can 796 just use the same allocation semantics. At first, PTEs were also 797 overloaded to a non-body sv-type, but this yielded hard-to-find malloc 798 bugs, so was simplified by claiming a new slot. This choice has no 799 consequence at this time. 800 801 */ 802 803 struct body_details { 804 U8 body_size; /* Size to allocate */ 805 U8 copy; /* Size of structure to copy (may be shorter) */ 806 U8 offset; 807 unsigned int type : 4; /* We have space for a sanity check. */ 808 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */ 809 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */ 810 unsigned int arena : 1; /* Allocated from an arena */ 811 size_t arena_size; /* Size of arena to allocate */ 812 }; 813 814 #define HADNV FALSE 815 #define NONV TRUE 816 817 818 #ifdef PURIFY 819 /* With -DPURFIY we allocate everything directly, and don't use arenas. 820 This seems a rather elegant way to simplify some of the code below. */ 821 #define HASARENA FALSE 822 #else 823 #define HASARENA TRUE 824 #endif 825 #define NOARENA FALSE 826 827 /* Size the arenas to exactly fit a given number of bodies. A count 828 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, 829 simplifying the default. If count > 0, the arena is sized to fit 830 only that many bodies, allowing arenas to be used for large, rare 831 bodies (XPVFM, XPVIO) without undue waste. The arena size is 832 limited by PERL_ARENA_SIZE, so we can safely oversize the 833 declarations. 834 */ 835 #define FIT_ARENA0(body_size) \ 836 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) 837 #define FIT_ARENAn(count,body_size) \ 838 ( count * body_size <= PERL_ARENA_SIZE) \ 839 ? count * body_size \ 840 : FIT_ARENA0 (body_size) 841 #define FIT_ARENA(count,body_size) \ 842 count \ 843 ? FIT_ARENAn (count, body_size) \ 844 : FIT_ARENA0 (body_size) 845 846 /* A macro to work out the offset needed to subtract from a pointer to (say) 847 848 typedef struct { 849 STRLEN xpv_cur; 850 STRLEN xpv_len; 851 } xpv_allocated; 852 853 to make its members accessible via a pointer to (say) 854 855 struct xpv { 856 NV xnv_nv; 857 STRLEN xpv_cur; 858 STRLEN xpv_len; 859 }; 860 861 */ 862 863 #define relative_STRUCT_OFFSET(longer, shorter, member) \ 864 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member)) 865 866 /* Calculate the length to copy. Specifically work out the length less any 867 final padding the compiler needed to add. See the comment in sv_upgrade 868 for why copying the padding proved to be a bug. */ 869 870 #define copy_length(type, last_member) \ 871 STRUCT_OFFSET(type, last_member) \ 872 + sizeof (((type*)SvANY((SV*)0))->last_member) 873 874 static const struct body_details bodies_by_type[] = { 875 { sizeof(HE), 0, 0, SVt_NULL, 876 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) }, 877 878 /* The bind placeholder pretends to be an RV for now. 879 Also it's marked as "can't upgrade" to stop anyone using it before it's 880 implemented. */ 881 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, 882 883 /* IVs are in the head, so the allocation size is 0. 884 However, the slot is overloaded for PTEs. */ 885 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */ 886 sizeof(IV), /* This is used to copy out the IV body. */ 887 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, 888 NOARENA /* IVS don't need an arena */, 889 /* But PTEs need to know the size of their arena */ 890 FIT_ARENA(0, sizeof(struct ptr_tbl_ent)) 891 }, 892 893 /* 8 bytes on most ILP32 with IEEE doubles */ 894 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA, 895 FIT_ARENA(0, sizeof(NV)) }, 896 897 /* RVs are in the head now. */ 898 { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 }, 899 900 /* 8 bytes on most ILP32 with IEEE doubles */ 901 { sizeof(xpv_allocated), 902 copy_length(XPV, xpv_len) 903 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur), 904 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur), 905 SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) }, 906 907 /* 12 */ 908 { sizeof(xpviv_allocated), 909 copy_length(XPVIV, xiv_u) 910 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur), 911 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur), 912 SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) }, 913 914 /* 20 */ 915 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV, 916 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) }, 917 918 /* 28 */ 919 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, 920 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, 921 922 /* 48 */ 923 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, 924 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, 925 926 /* 64 */ 927 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, 928 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, 929 930 { sizeof(xpvav_allocated), 931 copy_length(XPVAV, xmg_stash) 932 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill), 933 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill), 934 SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) }, 935 936 { sizeof(xpvhv_allocated), 937 copy_length(XPVHV, xmg_stash) 938 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill), 939 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill), 940 SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) }, 941 942 /* 56 */ 943 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated), 944 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur), 945 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) }, 946 947 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated), 948 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur), 949 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) }, 950 951 /* XPVIO is 84 bytes, fits 48x */ 952 { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV, 953 HASARENA, FIT_ARENA(24, sizeof(XPVIO)) }, 954 }; 955 956 #define new_body_type(sv_type) \ 957 (void *)((char *)S_new_body(aTHX_ sv_type)) 958 959 #define del_body_type(p, sv_type) \ 960 del_body(p, &PL_body_roots[sv_type]) 961 962 963 #define new_body_allocated(sv_type) \ 964 (void *)((char *)S_new_body(aTHX_ sv_type) \ 965 - bodies_by_type[sv_type].offset) 966 967 #define del_body_allocated(p, sv_type) \ 968 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) 969 970 971 #define my_safemalloc(s) (void*)safemalloc(s) 972 #define my_safecalloc(s) (void*)safecalloc(s, 1) 973 #define my_safefree(p) safefree((char*)p) 974 975 #ifdef PURIFY 976 977 #define new_XNV() my_safemalloc(sizeof(XPVNV)) 978 #define del_XNV(p) my_safefree(p) 979 980 #define new_XPVNV() my_safemalloc(sizeof(XPVNV)) 981 #define del_XPVNV(p) my_safefree(p) 982 983 #define new_XPVAV() my_safemalloc(sizeof(XPVAV)) 984 #define del_XPVAV(p) my_safefree(p) 985 986 #define new_XPVHV() my_safemalloc(sizeof(XPVHV)) 987 #define del_XPVHV(p) my_safefree(p) 988 989 #define new_XPVMG() my_safemalloc(sizeof(XPVMG)) 990 #define del_XPVMG(p) my_safefree(p) 991 992 #define new_XPVGV() my_safemalloc(sizeof(XPVGV)) 993 #define del_XPVGV(p) my_safefree(p) 994 995 #else /* !PURIFY */ 996 997 #define new_XNV() new_body_type(SVt_NV) 998 #define del_XNV(p) del_body_type(p, SVt_NV) 999 1000 #define new_XPVNV() new_body_type(SVt_PVNV) 1001 #define del_XPVNV(p) del_body_type(p, SVt_PVNV) 1002 1003 #define new_XPVAV() new_body_allocated(SVt_PVAV) 1004 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) 1005 1006 #define new_XPVHV() new_body_allocated(SVt_PVHV) 1007 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) 1008 1009 #define new_XPVMG() new_body_type(SVt_PVMG) 1010 #define del_XPVMG(p) del_body_type(p, SVt_PVMG) 1011 1012 #define new_XPVGV() new_body_type(SVt_PVGV) 1013 #define del_XPVGV(p) del_body_type(p, SVt_PVGV) 1014 1015 #endif /* PURIFY */ 1016 1017 /* no arena for you! */ 1018 1019 #define new_NOARENA(details) \ 1020 my_safemalloc((details)->body_size + (details)->offset) 1021 #define new_NOARENAZ(details) \ 1022 my_safecalloc((details)->body_size + (details)->offset) 1023 1024 STATIC void * 1025 S_more_bodies (pTHX_ svtype sv_type) 1026 { 1027 dVAR; 1028 void ** const root = &PL_body_roots[sv_type]; 1029 const struct body_details * const bdp = &bodies_by_type[sv_type]; 1030 const size_t body_size = bdp->body_size; 1031 char *start; 1032 const char *end; 1033 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 1034 static bool done_sanity_check; 1035 1036 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global 1037 * variables like done_sanity_check. */ 1038 if (!done_sanity_check) { 1039 unsigned int i = SVt_LAST; 1040 1041 done_sanity_check = TRUE; 1042 1043 while (i--) 1044 assert (bodies_by_type[i].type == i); 1045 } 1046 #endif 1047 1048 assert(bdp->arena_size); 1049 1050 start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type); 1051 1052 end = start + bdp->arena_size - body_size; 1053 1054 /* computed count doesnt reflect the 1st slot reservation */ 1055 DEBUG_m(PerlIO_printf(Perl_debug_log, 1056 "arena %p end %p arena-size %d type %d size %d ct %d\n", 1057 (void*)start, (void*)end, 1058 (int)bdp->arena_size, sv_type, (int)body_size, 1059 (int)bdp->arena_size / (int)body_size)); 1060 1061 *root = (void *)start; 1062 1063 while (start < end) { 1064 char * const next = start + body_size; 1065 *(void**) start = (void *)next; 1066 start = next; 1067 } 1068 *(void **)start = 0; 1069 1070 return *root; 1071 } 1072 1073 /* grab a new thing from the free list, allocating more if necessary. 1074 The inline version is used for speed in hot routines, and the 1075 function using it serves the rest (unless PURIFY). 1076 */ 1077 #define new_body_inline(xpv, sv_type) \ 1078 STMT_START { \ 1079 void ** const r3wt = &PL_body_roots[sv_type]; \ 1080 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ 1081 ? *((void **)(r3wt)) : more_bodies(sv_type)); \ 1082 *(r3wt) = *(void**)(xpv); \ 1083 } STMT_END 1084 1085 #ifndef PURIFY 1086 1087 STATIC void * 1088 S_new_body(pTHX_ svtype sv_type) 1089 { 1090 dVAR; 1091 void *xpv; 1092 new_body_inline(xpv, sv_type); 1093 return xpv; 1094 } 1095 1096 #endif 1097 1098 /* 1099 =for apidoc sv_upgrade 1100 1101 Upgrade an SV to a more complex form. Generally adds a new body type to the 1102 SV, then copies across as much information as possible from the old body. 1103 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>. 1104 1105 =cut 1106 */ 1107 1108 void 1109 Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) 1110 { 1111 dVAR; 1112 void* old_body; 1113 void* new_body; 1114 const svtype old_type = SvTYPE(sv); 1115 const struct body_details *new_type_details; 1116 const struct body_details *const old_type_details 1117 = bodies_by_type + old_type; 1118 1119 if (new_type != SVt_PV && SvIsCOW(sv)) { 1120 sv_force_normal_flags(sv, 0); 1121 } 1122 1123 if (old_type == new_type) 1124 return; 1125 1126 if (old_type > new_type) 1127 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", 1128 (int)old_type, (int)new_type); 1129 1130 1131 old_body = SvANY(sv); 1132 1133 /* Copying structures onto other structures that have been neatly zeroed 1134 has a subtle gotcha. Consider XPVMG 1135 1136 +------+------+------+------+------+-------+-------+ 1137 | NV | CUR | LEN | IV | MAGIC | STASH | 1138 +------+------+------+------+------+-------+-------+ 1139 0 4 8 12 16 20 24 28 1140 1141 where NVs are aligned to 8 bytes, so that sizeof that structure is 1142 actually 32 bytes long, with 4 bytes of padding at the end: 1143 1144 +------+------+------+------+------+-------+-------+------+ 1145 | NV | CUR | LEN | IV | MAGIC | STASH | ??? | 1146 +------+------+------+------+------+-------+-------+------+ 1147 0 4 8 12 16 20 24 28 32 1148 1149 so what happens if you allocate memory for this structure: 1150 1151 +------+------+------+------+------+-------+-------+------+------+... 1152 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | 1153 +------+------+------+------+------+-------+-------+------+------+... 1154 0 4 8 12 16 20 24 28 32 36 1155 1156 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you 1157 expect, because you copy the area marked ??? onto GP. Now, ??? may have 1158 started out as zero once, but it's quite possible that it isn't. So now, 1159 rather than a nicely zeroed GP, you have it pointing somewhere random. 1160 Bugs ensue. 1161 1162 (In fact, GP ends up pointing at a previous GP structure, because the 1163 principle cause of the padding in XPVMG getting garbage is a copy of 1164 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now 1165 this happens to be moot because XPVGV has been re-ordered, with GP 1166 no longer after STASH) 1167 1168 So we are careful and work out the size of used parts of all the 1169 structures. */ 1170 1171 switch (old_type) { 1172 case SVt_NULL: 1173 break; 1174 case SVt_IV: 1175 if (new_type < SVt_PVIV) { 1176 new_type = (new_type == SVt_NV) 1177 ? SVt_PVNV : SVt_PVIV; 1178 } 1179 break; 1180 case SVt_NV: 1181 if (new_type < SVt_PVNV) { 1182 new_type = SVt_PVNV; 1183 } 1184 break; 1185 case SVt_RV: 1186 break; 1187 case SVt_PV: 1188 assert(new_type > SVt_PV); 1189 assert(SVt_IV < SVt_PV); 1190 assert(SVt_NV < SVt_PV); 1191 break; 1192 case SVt_PVIV: 1193 break; 1194 case SVt_PVNV: 1195 break; 1196 case SVt_PVMG: 1197 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, 1198 there's no way that it can be safely upgraded, because perl.c 1199 expects to Safefree(SvANY(PL_mess_sv)) */ 1200 assert(sv != PL_mess_sv); 1201 /* This flag bit is used to mean other things in other scalar types. 1202 Given that it only has meaning inside the pad, it shouldn't be set 1203 on anything that can get upgraded. */ 1204 assert(!SvPAD_TYPED(sv)); 1205 break; 1206 default: 1207 if (old_type_details->cant_upgrade) 1208 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, 1209 sv_reftype(sv, 0), (UV) old_type, (UV) new_type); 1210 } 1211 new_type_details = bodies_by_type + new_type; 1212 1213 SvFLAGS(sv) &= ~SVTYPEMASK; 1214 SvFLAGS(sv) |= new_type; 1215 1216 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of 1217 the return statements above will have triggered. */ 1218 assert (new_type != SVt_NULL); 1219 switch (new_type) { 1220 case SVt_IV: 1221 assert(old_type == SVt_NULL); 1222 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 1223 SvIV_set(sv, 0); 1224 return; 1225 case SVt_NV: 1226 assert(old_type == SVt_NULL); 1227 SvANY(sv) = new_XNV(); 1228 SvNV_set(sv, 0); 1229 return; 1230 case SVt_RV: 1231 assert(old_type == SVt_NULL); 1232 SvANY(sv) = &sv->sv_u.svu_rv; 1233 SvRV_set(sv, 0); 1234 return; 1235 case SVt_PVHV: 1236 case SVt_PVAV: 1237 assert(new_type_details->body_size); 1238 1239 #ifndef PURIFY 1240 assert(new_type_details->arena); 1241 assert(new_type_details->arena_size); 1242 /* This points to the start of the allocated area. */ 1243 new_body_inline(new_body, new_type); 1244 Zero(new_body, new_type_details->body_size, char); 1245 new_body = ((char *)new_body) - new_type_details->offset; 1246 #else 1247 /* We always allocated the full length item with PURIFY. To do this 1248 we fake things so that arena is false for all 16 types.. */ 1249 new_body = new_NOARENAZ(new_type_details); 1250 #endif 1251 SvANY(sv) = new_body; 1252 if (new_type == SVt_PVAV) { 1253 AvMAX(sv) = -1; 1254 AvFILLp(sv) = -1; 1255 AvREAL_only(sv); 1256 } 1257 1258 /* SVt_NULL isn't the only thing upgraded to AV or HV. 1259 The target created by newSVrv also is, and it can have magic. 1260 However, it never has SvPVX set. 1261 */ 1262 if (old_type >= SVt_RV) { 1263 assert(SvPVX_const(sv) == 0); 1264 } 1265 1266 if (old_type >= SVt_PVMG) { 1267 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); 1268 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); 1269 } else { 1270 sv->sv_u.svu_array = NULL; /* or svu_hash */ 1271 } 1272 break; 1273 1274 1275 case SVt_PVIV: 1276 /* XXX Is this still needed? Was it ever needed? Surely as there is 1277 no route from NV to PVIV, NOK can never be true */ 1278 assert(!SvNOKp(sv)); 1279 assert(!SvNOK(sv)); 1280 case SVt_PVIO: 1281 case SVt_PVFM: 1282 case SVt_PVGV: 1283 case SVt_PVCV: 1284 case SVt_PVLV: 1285 case SVt_PVMG: 1286 case SVt_PVNV: 1287 case SVt_PV: 1288 1289 assert(new_type_details->body_size); 1290 /* We always allocated the full length item with PURIFY. To do this 1291 we fake things so that arena is false for all 16 types.. */ 1292 if(new_type_details->arena) { 1293 /* This points to the start of the allocated area. */ 1294 new_body_inline(new_body, new_type); 1295 Zero(new_body, new_type_details->body_size, char); 1296 new_body = ((char *)new_body) - new_type_details->offset; 1297 } else { 1298 new_body = new_NOARENAZ(new_type_details); 1299 } 1300 SvANY(sv) = new_body; 1301 1302 if (old_type_details->copy) { 1303 /* There is now the potential for an upgrade from something without 1304 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ 1305 int offset = old_type_details->offset; 1306 int length = old_type_details->copy; 1307 1308 if (new_type_details->offset > old_type_details->offset) { 1309 const int difference 1310 = new_type_details->offset - old_type_details->offset; 1311 offset += difference; 1312 length -= difference; 1313 } 1314 assert (length >= 0); 1315 1316 Copy((char *)old_body + offset, (char *)new_body + offset, length, 1317 char); 1318 } 1319 1320 #ifndef NV_ZERO_IS_ALLBITS_ZERO 1321 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a 1322 * correct 0.0 for us. Otherwise, if the old body didn't have an 1323 * NV slot, but the new one does, then we need to initialise the 1324 * freshly created NV slot with whatever the correct bit pattern is 1325 * for 0.0 */ 1326 if (old_type_details->zero_nv && !new_type_details->zero_nv 1327 && !isGV_with_GP(sv)) 1328 SvNV_set(sv, 0); 1329 #endif 1330 1331 if (new_type == SVt_PVIO) 1332 IoPAGE_LEN(sv) = 60; 1333 if (old_type < SVt_RV) 1334 SvPV_set(sv, NULL); 1335 break; 1336 default: 1337 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", 1338 (unsigned long)new_type); 1339 } 1340 1341 if (old_type_details->arena) { 1342 /* If there was an old body, then we need to free it. 1343 Note that there is an assumption that all bodies of types that 1344 can be upgraded came from arenas. Only the more complex non- 1345 upgradable types are allowed to be directly malloc()ed. */ 1346 #ifdef PURIFY 1347 my_safefree(old_body); 1348 #else 1349 del_body((void*)((char*)old_body + old_type_details->offset), 1350 &PL_body_roots[old_type]); 1351 #endif 1352 } 1353 } 1354 1355 /* 1356 =for apidoc sv_backoff 1357 1358 Remove any string offset. You should normally use the C<SvOOK_off> macro 1359 wrapper instead. 1360 1361 =cut 1362 */ 1363 1364 int 1365 Perl_sv_backoff(pTHX_ register SV *sv) 1366 { 1367 PERL_UNUSED_CONTEXT; 1368 assert(SvOOK(sv)); 1369 assert(SvTYPE(sv) != SVt_PVHV); 1370 assert(SvTYPE(sv) != SVt_PVAV); 1371 if (SvIVX(sv)) { 1372 const char * const s = SvPVX_const(sv); 1373 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); 1374 SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); 1375 SvIV_set(sv, 0); 1376 Move(s, SvPVX(sv), SvCUR(sv)+1, char); 1377 } 1378 SvFLAGS(sv) &= ~SVf_OOK; 1379 return 0; 1380 } 1381 1382 /* 1383 =for apidoc sv_grow 1384 1385 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and 1386 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. 1387 Use the C<SvGROW> wrapper instead. 1388 1389 =cut 1390 */ 1391 1392 char * 1393 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) 1394 { 1395 register char *s; 1396 1397 if (PL_madskills && newlen >= 0x100000) { 1398 PerlIO_printf(Perl_debug_log, 1399 "Allocation too large: %"UVxf"\n", (UV)newlen); 1400 } 1401 #ifdef HAS_64K_LIMIT 1402 if (newlen >= 0x10000) { 1403 PerlIO_printf(Perl_debug_log, 1404 "Allocation too large: %"UVxf"\n", (UV)newlen); 1405 my_exit(1); 1406 } 1407 #endif /* HAS_64K_LIMIT */ 1408 if (SvROK(sv)) 1409 sv_unref(sv); 1410 if (SvTYPE(sv) < SVt_PV) { 1411 sv_upgrade(sv, SVt_PV); 1412 s = SvPVX_mutable(sv); 1413 } 1414 else if (SvOOK(sv)) { /* pv is offset? */ 1415 sv_backoff(sv); 1416 s = SvPVX_mutable(sv); 1417 if (newlen > SvLEN(sv)) 1418 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ 1419 #ifdef HAS_64K_LIMIT 1420 if (newlen >= 0x10000) 1421 newlen = 0xFFFF; 1422 #endif 1423 } 1424 else 1425 s = SvPVX_mutable(sv); 1426 1427 if (newlen > SvLEN(sv)) { /* need more room? */ 1428 newlen = PERL_STRLEN_ROUNDUP(newlen); 1429 if (SvLEN(sv) && s) { 1430 #ifdef MYMALLOC 1431 const STRLEN l = malloced_size((void*)SvPVX_const(sv)); 1432 if (newlen <= l) { 1433 SvLEN_set(sv, l); 1434 return s; 1435 } else 1436 #endif 1437 s = (char*)saferealloc(s, newlen); 1438 } 1439 else { 1440 s = (char*)safemalloc(newlen); 1441 if (SvPVX_const(sv) && SvCUR(sv)) { 1442 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); 1443 } 1444 } 1445 SvPV_set(sv, s); 1446 SvLEN_set(sv, newlen); 1447 } 1448 return s; 1449 } 1450 1451 /* 1452 =for apidoc sv_setiv 1453 1454 Copies an integer into the given SV, upgrading first if necessary. 1455 Does not handle 'set' magic. See also C<sv_setiv_mg>. 1456 1457 =cut 1458 */ 1459 1460 void 1461 Perl_sv_setiv(pTHX_ register SV *sv, IV i) 1462 { 1463 dVAR; 1464 SV_CHECK_THINKFIRST_COW_DROP(sv); 1465 switch (SvTYPE(sv)) { 1466 case SVt_NULL: 1467 sv_upgrade(sv, SVt_IV); 1468 break; 1469 case SVt_NV: 1470 sv_upgrade(sv, SVt_PVNV); 1471 break; 1472 case SVt_RV: 1473 case SVt_PV: 1474 sv_upgrade(sv, SVt_PVIV); 1475 break; 1476 1477 case SVt_PVGV: 1478 case SVt_PVAV: 1479 case SVt_PVHV: 1480 case SVt_PVCV: 1481 case SVt_PVFM: 1482 case SVt_PVIO: 1483 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), 1484 OP_DESC(PL_op)); 1485 default: NOOP; 1486 } 1487 (void)SvIOK_only(sv); /* validate number */ 1488 SvIV_set(sv, i); 1489 SvTAINT(sv); 1490 } 1491 1492 /* 1493 =for apidoc sv_setiv_mg 1494 1495 Like C<sv_setiv>, but also handles 'set' magic. 1496 1497 =cut 1498 */ 1499 1500 void 1501 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) 1502 { 1503 sv_setiv(sv,i); 1504 SvSETMAGIC(sv); 1505 } 1506 1507 /* 1508 =for apidoc sv_setuv 1509 1510 Copies an unsigned integer into the given SV, upgrading first if necessary. 1511 Does not handle 'set' magic. See also C<sv_setuv_mg>. 1512 1513 =cut 1514 */ 1515 1516 void 1517 Perl_sv_setuv(pTHX_ register SV *sv, UV u) 1518 { 1519 /* With these two if statements: 1520 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 1521 1522 without 1523 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 1524 1525 If you wish to remove them, please benchmark to see what the effect is 1526 */ 1527 if (u <= (UV)IV_MAX) { 1528 sv_setiv(sv, (IV)u); 1529 return; 1530 } 1531 sv_setiv(sv, 0); 1532 SvIsUV_on(sv); 1533 SvUV_set(sv, u); 1534 } 1535 1536 /* 1537 =for apidoc sv_setuv_mg 1538 1539 Like C<sv_setuv>, but also handles 'set' magic. 1540 1541 =cut 1542 */ 1543 1544 void 1545 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) 1546 { 1547 sv_setuv(sv,u); 1548 SvSETMAGIC(sv); 1549 } 1550 1551 /* 1552 =for apidoc sv_setnv 1553 1554 Copies a double into the given SV, upgrading first if necessary. 1555 Does not handle 'set' magic. See also C<sv_setnv_mg>. 1556 1557 =cut 1558 */ 1559 1560 void 1561 Perl_sv_setnv(pTHX_ register SV *sv, NV num) 1562 { 1563 dVAR; 1564 SV_CHECK_THINKFIRST_COW_DROP(sv); 1565 switch (SvTYPE(sv)) { 1566 case SVt_NULL: 1567 case SVt_IV: 1568 sv_upgrade(sv, SVt_NV); 1569 break; 1570 case SVt_RV: 1571 case SVt_PV: 1572 case SVt_PVIV: 1573 sv_upgrade(sv, SVt_PVNV); 1574 break; 1575 1576 case SVt_PVGV: 1577 case SVt_PVAV: 1578 case SVt_PVHV: 1579 case SVt_PVCV: 1580 case SVt_PVFM: 1581 case SVt_PVIO: 1582 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), 1583 OP_NAME(PL_op)); 1584 default: NOOP; 1585 } 1586 SvNV_set(sv, num); 1587 (void)SvNOK_only(sv); /* validate number */ 1588 SvTAINT(sv); 1589 } 1590 1591 /* 1592 =for apidoc sv_setnv_mg 1593 1594 Like C<sv_setnv>, but also handles 'set' magic. 1595 1596 =cut 1597 */ 1598 1599 void 1600 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) 1601 { 1602 sv_setnv(sv,num); 1603 SvSETMAGIC(sv); 1604 } 1605 1606 /* Print an "isn't numeric" warning, using a cleaned-up, 1607 * printable version of the offending string 1608 */ 1609 1610 STATIC void 1611 S_not_a_number(pTHX_ SV *sv) 1612 { 1613 dVAR; 1614 SV *dsv; 1615 char tmpbuf[64]; 1616 const char *pv; 1617 1618 if (DO_UTF8(sv)) { 1619 dsv = sv_2mortal(newSVpvs("")); 1620 pv = sv_uni_display(dsv, sv, 10, 0); 1621 } else { 1622 char *d = tmpbuf; 1623 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; 1624 /* each *s can expand to 4 chars + "...\0", 1625 i.e. need room for 8 chars */ 1626 1627 const char *s = SvPVX_const(sv); 1628 const char * const end = s + SvCUR(sv); 1629 for ( ; s < end && d < limit; s++ ) { 1630 int ch = *s & 0xFF; 1631 if (ch & 128 && !isPRINT_LC(ch)) { 1632 *d++ = 'M'; 1633 *d++ = '-'; 1634 ch &= 127; 1635 } 1636 if (ch == '\n') { 1637 *d++ = '\\'; 1638 *d++ = 'n'; 1639 } 1640 else if (ch == '\r') { 1641 *d++ = '\\'; 1642 *d++ = 'r'; 1643 } 1644 else if (ch == '\f') { 1645 *d++ = '\\'; 1646 *d++ = 'f'; 1647 } 1648 else if (ch == '\\') { 1649 *d++ = '\\'; 1650 *d++ = '\\'; 1651 } 1652 else if (ch == '\0') { 1653 *d++ = '\\'; 1654 *d++ = '0'; 1655 } 1656 else if (isPRINT_LC(ch)) 1657 *d++ = ch; 1658 else { 1659 *d++ = '^'; 1660 *d++ = toCTRL(ch); 1661 } 1662 } 1663 if (s < end) { 1664 *d++ = '.'; 1665 *d++ = '.'; 1666 *d++ = '.'; 1667 } 1668 *d = '\0'; 1669 pv = tmpbuf; 1670 } 1671 1672 if (PL_op) 1673 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), 1674 "Argument \"%s\" isn't numeric in %s", pv, 1675 OP_DESC(PL_op)); 1676 else 1677 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), 1678 "Argument \"%s\" isn't numeric", pv); 1679 } 1680 1681 /* 1682 =for apidoc looks_like_number 1683 1684 Test if the content of an SV looks like a number (or is a number). 1685 C<Inf> and C<Infinity> are treated as numbers (so will not issue a 1686 non-numeric warning), even if your atof() doesn't grok them. 1687 1688 =cut 1689 */ 1690 1691 I32 1692 Perl_looks_like_number(pTHX_ SV *sv) 1693 { 1694 register const char *sbegin; 1695 STRLEN len; 1696 1697 if (SvPOK(sv)) { 1698 sbegin = SvPVX_const(sv); 1699 len = SvCUR(sv); 1700 } 1701 else if (SvPOKp(sv)) 1702 sbegin = SvPV_const(sv, len); 1703 else 1704 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); 1705 return grok_number(sbegin, len, NULL); 1706 } 1707 1708 STATIC bool 1709 S_glob_2number(pTHX_ GV * const gv) 1710 { 1711 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; 1712 SV *const buffer = sv_newmortal(); 1713 1714 /* FAKE globs can get coerced, so need to turn this off temporarily if it 1715 is on. */ 1716 SvFAKE_off(gv); 1717 gv_efullname3(buffer, gv, "*"); 1718 SvFLAGS(gv) |= wasfake; 1719 1720 /* We know that all GVs stringify to something that is not-a-number, 1721 so no need to test that. */ 1722 if (ckWARN(WARN_NUMERIC)) 1723 not_a_number(buffer); 1724 /* We just want something true to return, so that S_sv_2iuv_common 1725 can tail call us and return true. */ 1726 return TRUE; 1727 } 1728 1729 STATIC char * 1730 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) 1731 { 1732 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; 1733 SV *const buffer = sv_newmortal(); 1734 1735 /* FAKE globs can get coerced, so need to turn this off temporarily if it 1736 is on. */ 1737 SvFAKE_off(gv); 1738 gv_efullname3(buffer, gv, "*"); 1739 SvFLAGS(gv) |= wasfake; 1740 1741 assert(SvPOK(buffer)); 1742 if (len) { 1743 *len = SvCUR(buffer); 1744 } 1745 return SvPVX(buffer); 1746 } 1747 1748 /* Actually, ISO C leaves conversion of UV to IV undefined, but 1749 until proven guilty, assume that things are not that bad... */ 1750 1751 /* 1752 NV_PRESERVES_UV: 1753 1754 As 64 bit platforms often have an NV that doesn't preserve all bits of 1755 an IV (an assumption perl has been based on to date) it becomes necessary 1756 to remove the assumption that the NV always carries enough precision to 1757 recreate the IV whenever needed, and that the NV is the canonical form. 1758 Instead, IV/UV and NV need to be given equal rights. So as to not lose 1759 precision as a side effect of conversion (which would lead to insanity 1760 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is 1761 1) to distinguish between IV/UV/NV slots that have cached a valid 1762 conversion where precision was lost and IV/UV/NV slots that have a 1763 valid conversion which has lost no precision 1764 2) to ensure that if a numeric conversion to one form is requested that 1765 would lose precision, the precise conversion (or differently 1766 imprecise conversion) is also performed and cached, to prevent 1767 requests for different numeric formats on the same SV causing 1768 lossy conversion chains. (lossless conversion chains are perfectly 1769 acceptable (still)) 1770 1771 1772 flags are used: 1773 SvIOKp is true if the IV slot contains a valid value 1774 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) 1775 SvNOKp is true if the NV slot contains a valid value 1776 SvNOK is true only if the NV value is accurate 1777 1778 so 1779 while converting from PV to NV, check to see if converting that NV to an 1780 IV(or UV) would lose accuracy over a direct conversion from PV to 1781 IV(or UV). If it would, cache both conversions, return NV, but mark 1782 SV as IOK NOKp (ie not NOK). 1783 1784 While converting from PV to IV, check to see if converting that IV to an 1785 NV would lose accuracy over a direct conversion from PV to NV. If it 1786 would, cache both conversions, flag similarly. 1787 1788 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite 1789 correctly because if IV & NV were set NV *always* overruled. 1790 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning 1791 changes - now IV and NV together means that the two are interchangeable: 1792 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; 1793 1794 The benefit of this is that operations such as pp_add know that if 1795 SvIOK is true for both left and right operands, then integer addition 1796 can be used instead of floating point (for cases where the result won't 1797 overflow). Before, floating point was always used, which could lead to 1798 loss of precision compared with integer addition. 1799 1800 * making IV and NV equal status should make maths accurate on 64 bit 1801 platforms 1802 * may speed up maths somewhat if pp_add and friends start to use 1803 integers when possible instead of fp. (Hopefully the overhead in 1804 looking for SvIOK and checking for overflow will not outweigh the 1805 fp to integer speedup) 1806 * will slow down integer operations (callers of SvIV) on "inaccurate" 1807 values, as the change from SvIOK to SvIOKp will cause a call into 1808 sv_2iv each time rather than a macro access direct to the IV slot 1809 * should speed up number->string conversion on integers as IV is 1810 favoured when IV and NV are equally accurate 1811 1812 #################################################################### 1813 You had better be using SvIOK_notUV if you want an IV for arithmetic: 1814 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. 1815 On the other hand, SvUOK is true iff UV. 1816 #################################################################### 1817 1818 Your mileage will vary depending your CPU's relative fp to integer 1819 performance ratio. 1820 */ 1821 1822 #ifndef NV_PRESERVES_UV 1823 # define IS_NUMBER_UNDERFLOW_IV 1 1824 # define IS_NUMBER_UNDERFLOW_UV 2 1825 # define IS_NUMBER_IV_AND_UV 2 1826 # define IS_NUMBER_OVERFLOW_IV 4 1827 # define IS_NUMBER_OVERFLOW_UV 5 1828 1829 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ 1830 1831 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ 1832 STATIC int 1833 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) 1834 { 1835 dVAR; 1836 PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */ 1837 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); 1838 if (SvNVX(sv) < (NV)IV_MIN) { 1839 (void)SvIOKp_on(sv); 1840 (void)SvNOK_on(sv); 1841 SvIV_set(sv, IV_MIN); 1842 return IS_NUMBER_UNDERFLOW_IV; 1843 } 1844 if (SvNVX(sv) > (NV)UV_MAX) { 1845 (void)SvIOKp_on(sv); 1846 (void)SvNOK_on(sv); 1847 SvIsUV_on(sv); 1848 SvUV_set(sv, UV_MAX); 1849 return IS_NUMBER_OVERFLOW_UV; 1850 } 1851 (void)SvIOKp_on(sv); 1852 (void)SvNOK_on(sv); 1853 /* Can't use strtol etc to convert this string. (See truth table in 1854 sv_2iv */ 1855 if (SvNVX(sv) <= (UV)IV_MAX) { 1856 SvIV_set(sv, I_V(SvNVX(sv))); 1857 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 1858 SvIOK_on(sv); /* Integer is precise. NOK, IOK */ 1859 } else { 1860 /* Integer is imprecise. NOK, IOKp */ 1861 } 1862 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; 1863 } 1864 SvIsUV_on(sv); 1865 SvUV_set(sv, U_V(SvNVX(sv))); 1866 if ((NV)(SvUVX(sv)) == SvNVX(sv)) { 1867 if (SvUVX(sv) == UV_MAX) { 1868 /* As we know that NVs don't preserve UVs, UV_MAX cannot 1869 possibly be preserved by NV. Hence, it must be overflow. 1870 NOK, IOKp */ 1871 return IS_NUMBER_OVERFLOW_UV; 1872 } 1873 SvIOK_on(sv); /* Integer is precise. NOK, UOK */ 1874 } else { 1875 /* Integer is imprecise. NOK, IOKp */ 1876 } 1877 return IS_NUMBER_OVERFLOW_IV; 1878 } 1879 #endif /* !NV_PRESERVES_UV*/ 1880 1881 STATIC bool 1882 S_sv_2iuv_common(pTHX_ SV *sv) { 1883 dVAR; 1884 if (SvNOKp(sv)) { 1885 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv 1886 * without also getting a cached IV/UV from it at the same time 1887 * (ie PV->NV conversion should detect loss of accuracy and cache 1888 * IV or UV at same time to avoid this. */ 1889 /* IV-over-UV optimisation - choose to cache IV if possible */ 1890 1891 if (SvTYPE(sv) == SVt_NV) 1892 sv_upgrade(sv, SVt_PVNV); 1893 1894 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ 1895 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost 1896 certainly cast into the IV range at IV_MAX, whereas the correct 1897 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary 1898 cases go to UV */ 1899 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 1900 if (Perl_isnan(SvNVX(sv))) { 1901 SvUV_set(sv, 0); 1902 SvIsUV_on(sv); 1903 return FALSE; 1904 } 1905 #endif 1906 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 1907 SvIV_set(sv, I_V(SvNVX(sv))); 1908 if (SvNVX(sv) == (NV) SvIVX(sv) 1909 #ifndef NV_PRESERVES_UV 1910 && (((UV)1 << NV_PRESERVES_UV_BITS) > 1911 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) 1912 /* Don't flag it as "accurately an integer" if the number 1913 came from a (by definition imprecise) NV operation, and 1914 we're outside the range of NV integer precision */ 1915 #endif 1916 ) { 1917 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ 1918 DEBUG_c(PerlIO_printf(Perl_debug_log, 1919 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", 1920 PTR2UV(sv), 1921 SvNVX(sv), 1922 SvIVX(sv))); 1923 1924 } else { 1925 /* IV not precise. No need to convert from PV, as NV 1926 conversion would already have cached IV if it detected 1927 that PV->IV would be better than PV->NV->IV 1928 flags already correct - don't set public IOK. */ 1929 DEBUG_c(PerlIO_printf(Perl_debug_log, 1930 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", 1931 PTR2UV(sv), 1932 SvNVX(sv), 1933 SvIVX(sv))); 1934 } 1935 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, 1936 but the cast (NV)IV_MIN rounds to a the value less (more 1937 negative) than IV_MIN which happens to be equal to SvNVX ?? 1938 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and 1939 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and 1940 (NV)UVX == NVX are both true, but the values differ. :-( 1941 Hopefully for 2s complement IV_MIN is something like 1942 0x8000000000000000 which will be exact. NWC */ 1943 } 1944 else { 1945 SvUV_set(sv, U_V(SvNVX(sv))); 1946 if ( 1947 (SvNVX(sv) == (NV) SvUVX(sv)) 1948 #ifndef NV_PRESERVES_UV 1949 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ 1950 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ 1951 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) 1952 /* Don't flag it as "accurately an integer" if the number 1953 came from a (by definition imprecise) NV operation, and 1954 we're outside the range of NV integer precision */ 1955 #endif 1956 ) 1957 SvIOK_on(sv); 1958 SvIsUV_on(sv); 1959 DEBUG_c(PerlIO_printf(Perl_debug_log, 1960 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", 1961 PTR2UV(sv), 1962 SvUVX(sv), 1963 SvUVX(sv))); 1964 } 1965 } 1966 else if (SvPOKp(sv) && SvLEN(sv)) { 1967 UV value; 1968 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 1969 /* We want to avoid a possible problem when we cache an IV/ a UV which 1970 may be later translated to an NV, and the resulting NV is not 1971 the same as the direct translation of the initial string 1972 (eg 123.456 can shortcut to the IV 123 with atol(), but we must 1973 be careful to ensure that the value with the .456 is around if the 1974 NV value is requested in the future). 1975 1976 This means that if we cache such an IV/a UV, we need to cache the 1977 NV as well. Moreover, we trade speed for space, and do not 1978 cache the NV if we are sure it's not needed. 1979 */ 1980 1981 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ 1982 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 1983 == IS_NUMBER_IN_UV) { 1984 /* It's definitely an integer, only upgrade to PVIV */ 1985 if (SvTYPE(sv) < SVt_PVIV) 1986 sv_upgrade(sv, SVt_PVIV); 1987 (void)SvIOK_on(sv); 1988 } else if (SvTYPE(sv) < SVt_PVNV) 1989 sv_upgrade(sv, SVt_PVNV); 1990 1991 /* If NVs preserve UVs then we only use the UV value if we know that 1992 we aren't going to call atof() below. If NVs don't preserve UVs 1993 then the value returned may have more precision than atof() will 1994 return, even though value isn't perfectly accurate. */ 1995 if ((numtype & (IS_NUMBER_IN_UV 1996 #ifdef NV_PRESERVES_UV 1997 | IS_NUMBER_NOT_INT 1998 #endif 1999 )) == IS_NUMBER_IN_UV) { 2000 /* This won't turn off the public IOK flag if it was set above */ 2001 (void)SvIOKp_on(sv); 2002 2003 if (!(numtype & IS_NUMBER_NEG)) { 2004 /* positive */; 2005 if (value <= (UV)IV_MAX) { 2006 SvIV_set(sv, (IV)value); 2007 } else { 2008 /* it didn't overflow, and it was positive. */ 2009 SvUV_set(sv, value); 2010 SvIsUV_on(sv); 2011 } 2012 } else { 2013 /* 2s complement assumption */ 2014 if (value <= (UV)IV_MIN) { 2015 SvIV_set(sv, -(IV)value); 2016 } else { 2017 /* Too negative for an IV. This is a double upgrade, but 2018 I'm assuming it will be rare. */ 2019 if (SvTYPE(sv) < SVt_PVNV) 2020 sv_upgrade(sv, SVt_PVNV); 2021 SvNOK_on(sv); 2022 SvIOK_off(sv); 2023 SvIOKp_on(sv); 2024 SvNV_set(sv, -(NV)value); 2025 SvIV_set(sv, IV_MIN); 2026 } 2027 } 2028 } 2029 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we 2030 will be in the previous block to set the IV slot, and the next 2031 block to set the NV slot. So no else here. */ 2032 2033 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2034 != IS_NUMBER_IN_UV) { 2035 /* It wasn't an (integer that doesn't overflow the UV). */ 2036 SvNV_set(sv, Atof(SvPVX_const(sv))); 2037 2038 if (! numtype && ckWARN(WARN_NUMERIC)) 2039 not_a_number(sv); 2040 2041 #if defined(USE_LONG_DOUBLE) 2042 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", 2043 PTR2UV(sv), SvNVX(sv))); 2044 #else 2045 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", 2046 PTR2UV(sv), SvNVX(sv))); 2047 #endif 2048 2049 #ifdef NV_PRESERVES_UV 2050 (void)SvIOKp_on(sv); 2051 (void)SvNOK_on(sv); 2052 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2053 SvIV_set(sv, I_V(SvNVX(sv))); 2054 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 2055 SvIOK_on(sv); 2056 } else { 2057 NOOP; /* Integer is imprecise. NOK, IOKp */ 2058 } 2059 /* UV will not work better than IV */ 2060 } else { 2061 if (SvNVX(sv) > (NV)UV_MAX) { 2062 SvIsUV_on(sv); 2063 /* Integer is inaccurate. NOK, IOKp, is UV */ 2064 SvUV_set(sv, UV_MAX); 2065 } else { 2066 SvUV_set(sv, U_V(SvNVX(sv))); 2067 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs 2068 NV preservse UV so can do correct comparison. */ 2069 if ((NV)(SvUVX(sv)) == SvNVX(sv)) { 2070 SvIOK_on(sv); 2071 } else { 2072 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ 2073 } 2074 } 2075 SvIsUV_on(sv); 2076 } 2077 #else /* NV_PRESERVES_UV */ 2078 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2079 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { 2080 /* The IV/UV slot will have been set from value returned by 2081 grok_number above. The NV slot has just been set using 2082 Atof. */ 2083 SvNOK_on(sv); 2084 assert (SvIOKp(sv)); 2085 } else { 2086 if (((UV)1 << NV_PRESERVES_UV_BITS) > 2087 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { 2088 /* Small enough to preserve all bits. */ 2089 (void)SvIOKp_on(sv); 2090 SvNOK_on(sv); 2091 SvIV_set(sv, I_V(SvNVX(sv))); 2092 if ((NV)(SvIVX(sv)) == SvNVX(sv)) 2093 SvIOK_on(sv); 2094 /* Assumption: first non-preserved integer is < IV_MAX, 2095 this NV is in the preserved range, therefore: */ 2096 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) 2097 < (UV)IV_MAX)) { 2098 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); 2099 } 2100 } else { 2101 /* IN_UV NOT_INT 2102 0 0 already failed to read UV. 2103 0 1 already failed to read UV. 2104 1 0 you won't get here in this case. IV/UV 2105 slot set, public IOK, Atof() unneeded. 2106 1 1 already read UV. 2107 so there's no point in sv_2iuv_non_preserve() attempting 2108 to use atol, strtol, strtoul etc. */ 2109 sv_2iuv_non_preserve (sv, numtype); 2110 } 2111 } 2112 #endif /* NV_PRESERVES_UV */ 2113 } 2114 } 2115 else { 2116 if (isGV_with_GP(sv)) 2117 return glob_2number((GV *)sv); 2118 2119 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 2120 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) 2121 report_uninit(sv); 2122 } 2123 if (SvTYPE(sv) < SVt_IV) 2124 /* Typically the caller expects that sv_any is not NULL now. */ 2125 sv_upgrade(sv, SVt_IV); 2126 /* Return 0 from the caller. */ 2127 return TRUE; 2128 } 2129 return FALSE; 2130 } 2131 2132 /* 2133 =for apidoc sv_2iv_flags 2134 2135 Return the integer value of an SV, doing any necessary string 2136 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2137 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. 2138 2139 =cut 2140 */ 2141 2142 IV 2143 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) 2144 { 2145 dVAR; 2146 if (!sv) 2147 return 0; 2148 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { 2149 /* FBMs use the same flag bit as SVf_IVisUV, so must let them 2150 cache IVs just in case. In practice it seems that they never 2151 actually anywhere accessible by user Perl code, let alone get used 2152 in anything other than a string context. */ 2153 if (flags & SV_GMAGIC) 2154 mg_get(sv); 2155 if (SvIOKp(sv)) 2156 return SvIVX(sv); 2157 if (SvNOKp(sv)) { 2158 return I_V(SvNVX(sv)); 2159 } 2160 if (SvPOKp(sv) && SvLEN(sv)) { 2161 UV value; 2162 const int numtype 2163 = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2164 2165 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2166 == IS_NUMBER_IN_UV) { 2167 /* It's definitely an integer */ 2168 if (numtype & IS_NUMBER_NEG) { 2169 if (value < (UV)IV_MIN) 2170 return -(IV)value; 2171 } else { 2172 if (value < (UV)IV_MAX) 2173 return (IV)value; 2174 } 2175 } 2176 if (!numtype) { 2177 if (ckWARN(WARN_NUMERIC)) 2178 not_a_number(sv); 2179 } 2180 return I_V(Atof(SvPVX_const(sv))); 2181 } 2182 if (SvROK(sv)) { 2183 goto return_rok; 2184 } 2185 assert(SvTYPE(sv) >= SVt_PVMG); 2186 /* This falls through to the report_uninit inside S_sv_2iuv_common. */ 2187 } else if (SvTHINKFIRST(sv)) { 2188 if (SvROK(sv)) { 2189 return_rok: 2190 if (SvAMAGIC(sv)) { 2191 SV * const tmpstr=AMG_CALLun(sv,numer); 2192 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2193 return SvIV(tmpstr); 2194 } 2195 } 2196 return PTR2IV(SvRV(sv)); 2197 } 2198 if (SvIsCOW(sv)) { 2199 sv_force_normal_flags(sv, 0); 2200 } 2201 if (SvREADONLY(sv) && !SvOK(sv)) { 2202 if (ckWARN(WARN_UNINITIALIZED)) 2203 report_uninit(sv); 2204 return 0; 2205 } 2206 } 2207 if (!SvIOKp(sv)) { 2208 if (S_sv_2iuv_common(aTHX_ sv)) 2209 return 0; 2210 } 2211 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", 2212 PTR2UV(sv),SvIVX(sv))); 2213 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); 2214 } 2215 2216 /* 2217 =for apidoc sv_2uv_flags 2218 2219 Return the unsigned integer value of an SV, doing any necessary string 2220 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2221 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros. 2222 2223 =cut 2224 */ 2225 2226 UV 2227 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) 2228 { 2229 dVAR; 2230 if (!sv) 2231 return 0; 2232 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { 2233 /* FBMs use the same flag bit as SVf_IVisUV, so must let them 2234 cache IVs just in case. */ 2235 if (flags & SV_GMAGIC) 2236 mg_get(sv); 2237 if (SvIOKp(sv)) 2238 return SvUVX(sv); 2239 if (SvNOKp(sv)) 2240 return U_V(SvNVX(sv)); 2241 if (SvPOKp(sv) && SvLEN(sv)) { 2242 UV value; 2243 const int numtype 2244 = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2245 2246 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2247 == IS_NUMBER_IN_UV) { 2248 /* It's definitely an integer */ 2249 if (!(numtype & IS_NUMBER_NEG)) 2250 return value; 2251 } 2252 if (!numtype) { 2253 if (ckWARN(WARN_NUMERIC)) 2254 not_a_number(sv); 2255 } 2256 return U_V(Atof(SvPVX_const(sv))); 2257 } 2258 if (SvROK(sv)) { 2259 goto return_rok; 2260 } 2261 assert(SvTYPE(sv) >= SVt_PVMG); 2262 /* This falls through to the report_uninit inside S_sv_2iuv_common. */ 2263 } else if (SvTHINKFIRST(sv)) { 2264 if (SvROK(sv)) { 2265 return_rok: 2266 if (SvAMAGIC(sv)) { 2267 SV *const tmpstr = AMG_CALLun(sv,numer); 2268 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2269 return SvUV(tmpstr); 2270 } 2271 } 2272 return PTR2UV(SvRV(sv)); 2273 } 2274 if (SvIsCOW(sv)) { 2275 sv_force_normal_flags(sv, 0); 2276 } 2277 if (SvREADONLY(sv) && !SvOK(sv)) { 2278 if (ckWARN(WARN_UNINITIALIZED)) 2279 report_uninit(sv); 2280 return 0; 2281 } 2282 } 2283 if (!SvIOKp(sv)) { 2284 if (S_sv_2iuv_common(aTHX_ sv)) 2285 return 0; 2286 } 2287 2288 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", 2289 PTR2UV(sv),SvUVX(sv))); 2290 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); 2291 } 2292 2293 /* 2294 =for apidoc sv_2nv 2295 2296 Return the num value of an SV, doing any necessary string or integer 2297 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> 2298 macros. 2299 2300 =cut 2301 */ 2302 2303 NV 2304 Perl_sv_2nv(pTHX_ register SV *sv) 2305 { 2306 dVAR; 2307 if (!sv) 2308 return 0.0; 2309 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { 2310 /* FBMs use the same flag bit as SVf_IVisUV, so must let them 2311 cache IVs just in case. */ 2312 mg_get(sv); 2313 if (SvNOKp(sv)) 2314 return SvNVX(sv); 2315 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) { 2316 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && 2317 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) 2318 not_a_number(sv); 2319 return Atof(SvPVX_const(sv)); 2320 } 2321 if (SvIOKp(sv)) { 2322 if (SvIsUV(sv)) 2323 return (NV)SvUVX(sv); 2324 else 2325 return (NV)SvIVX(sv); 2326 } 2327 if (SvROK(sv)) { 2328 goto return_rok; 2329 } 2330 assert(SvTYPE(sv) >= SVt_PVMG); 2331 /* This falls through to the report_uninit near the end of the 2332 function. */ 2333 } else if (SvTHINKFIRST(sv)) { 2334 if (SvROK(sv)) { 2335 return_rok: 2336 if (SvAMAGIC(sv)) { 2337 SV *const tmpstr = AMG_CALLun(sv,numer); 2338 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2339 return SvNV(tmpstr); 2340 } 2341 } 2342 return PTR2NV(SvRV(sv)); 2343 } 2344 if (SvIsCOW(sv)) { 2345 sv_force_normal_flags(sv, 0); 2346 } 2347 if (SvREADONLY(sv) && !SvOK(sv)) { 2348 if (ckWARN(WARN_UNINITIALIZED)) 2349 report_uninit(sv); 2350 return 0.0; 2351 } 2352 } 2353 if (SvTYPE(sv) < SVt_NV) { 2354 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ 2355 sv_upgrade(sv, SVt_NV); 2356 #ifdef USE_LONG_DOUBLE 2357 DEBUG_c({ 2358 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2359 PerlIO_printf(Perl_debug_log, 2360 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", 2361 PTR2UV(sv), SvNVX(sv)); 2362 RESTORE_NUMERIC_LOCAL(); 2363 }); 2364 #else 2365 DEBUG_c({ 2366 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2367 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", 2368 PTR2UV(sv), SvNVX(sv)); 2369 RESTORE_NUMERIC_LOCAL(); 2370 }); 2371 #endif 2372 } 2373 else if (SvTYPE(sv) < SVt_PVNV) 2374 sv_upgrade(sv, SVt_PVNV); 2375 if (SvNOKp(sv)) { 2376 return SvNVX(sv); 2377 } 2378 if (SvIOKp(sv)) { 2379 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); 2380 #ifdef NV_PRESERVES_UV 2381 SvNOK_on(sv); 2382 #else 2383 /* Only set the public NV OK flag if this NV preserves the IV */ 2384 /* Check it's not 0xFFFFFFFFFFFFFFFF */ 2385 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) 2386 : (SvIVX(sv) == I_V(SvNVX(sv)))) 2387 SvNOK_on(sv); 2388 else 2389 SvNOKp_on(sv); 2390 #endif 2391 } 2392 else if (SvPOKp(sv) && SvLEN(sv)) { 2393 UV value; 2394 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2395 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) 2396 not_a_number(sv); 2397 #ifdef NV_PRESERVES_UV 2398 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2399 == IS_NUMBER_IN_UV) { 2400 /* It's definitely an integer */ 2401 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); 2402 } else 2403 SvNV_set(sv, Atof(SvPVX_const(sv))); 2404 SvNOK_on(sv); 2405 #else 2406 SvNV_set(sv, Atof(SvPVX_const(sv))); 2407 /* Only set the public NV OK flag if this NV preserves the value in 2408 the PV at least as well as an IV/UV would. 2409 Not sure how to do this 100% reliably. */ 2410 /* if that shift count is out of range then Configure's test is 2411 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == 2412 UV_BITS */ 2413 if (((UV)1 << NV_PRESERVES_UV_BITS) > 2414 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { 2415 SvNOK_on(sv); /* Definitely small enough to preserve all bits */ 2416 } else if (!(numtype & IS_NUMBER_IN_UV)) { 2417 /* Can't use strtol etc to convert this string, so don't try. 2418 sv_2iv and sv_2uv will use the NV to convert, not the PV. */ 2419 SvNOK_on(sv); 2420 } else { 2421 /* value has been set. It may not be precise. */ 2422 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { 2423 /* 2s complement assumption for (UV)IV_MIN */ 2424 SvNOK_on(sv); /* Integer is too negative. */ 2425 } else { 2426 SvNOKp_on(sv); 2427 SvIOKp_on(sv); 2428 2429 if (numtype & IS_NUMBER_NEG) { 2430 SvIV_set(sv, -(IV)value); 2431 } else if (value <= (UV)IV_MAX) { 2432 SvIV_set(sv, (IV)value); 2433 } else { 2434 SvUV_set(sv, value); 2435 SvIsUV_on(sv); 2436 } 2437 2438 if (numtype & IS_NUMBER_NOT_INT) { 2439 /* I believe that even if the original PV had decimals, 2440 they are lost beyond the limit of the FP precision. 2441 However, neither is canonical, so both only get p 2442 flags. NWC, 2000/11/25 */ 2443 /* Both already have p flags, so do nothing */ 2444 } else { 2445 const NV nv = SvNVX(sv); 2446 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2447 if (SvIVX(sv) == I_V(nv)) { 2448 SvNOK_on(sv); 2449 } else { 2450 /* It had no "." so it must be integer. */ 2451 } 2452 SvIOK_on(sv); 2453 } else { 2454 /* between IV_MAX and NV(UV_MAX). 2455 Could be slightly > UV_MAX */ 2456 2457 if (numtype & IS_NUMBER_NOT_INT) { 2458 /* UV and NV both imprecise. */ 2459 } else { 2460 const UV nv_as_uv = U_V(nv); 2461 2462 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { 2463 SvNOK_on(sv); 2464 } 2465 SvIOK_on(sv); 2466 } 2467 } 2468 } 2469 } 2470 } 2471 #endif /* NV_PRESERVES_UV */ 2472 } 2473 else { 2474 if (isGV_with_GP(sv)) { 2475 glob_2number((GV *)sv); 2476 return 0.0; 2477 } 2478 2479 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) 2480 report_uninit(sv); 2481 assert (SvTYPE(sv) >= SVt_NV); 2482 /* Typically the caller expects that sv_any is not NULL now. */ 2483 /* XXX Ilya implies that this is a bug in callers that assume this 2484 and ideally should be fixed. */ 2485 return 0.0; 2486 } 2487 #if defined(USE_LONG_DOUBLE) 2488 DEBUG_c({ 2489 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2490 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", 2491 PTR2UV(sv), SvNVX(sv)); 2492 RESTORE_NUMERIC_LOCAL(); 2493 }); 2494 #else 2495 DEBUG_c({ 2496 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2497 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", 2498 PTR2UV(sv), SvNVX(sv)); 2499 RESTORE_NUMERIC_LOCAL(); 2500 }); 2501 #endif 2502 return SvNVX(sv); 2503 } 2504 2505 /* 2506 =for apidoc sv_2num 2507 2508 Return an SV with the numeric value of the source SV, doing any necessary 2509 reference or overload conversion. You must use the C<SvNUM(sv)> macro to 2510 access this function. 2511 2512 =cut 2513 */ 2514 2515 SV * 2516 Perl_sv_2num(pTHX_ register SV *sv) 2517 { 2518 if (!SvROK(sv)) 2519 return sv; 2520 if (SvAMAGIC(sv)) { 2521 SV * const tmpsv = AMG_CALLun(sv,numer); 2522 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) 2523 return sv_2num(tmpsv); 2524 } 2525 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); 2526 } 2527 2528 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or 2529 * UV as a string towards the end of buf, and return pointers to start and 2530 * end of it. 2531 * 2532 * We assume that buf is at least TYPE_CHARS(UV) long. 2533 */ 2534 2535 static char * 2536 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) 2537 { 2538 char *ptr = buf + TYPE_CHARS(UV); 2539 char * const ebuf = ptr; 2540 int sign; 2541 2542 if (is_uv) 2543 sign = 0; 2544 else if (iv >= 0) { 2545 uv = iv; 2546 sign = 0; 2547 } else { 2548 uv = -iv; 2549 sign = 1; 2550 } 2551 do { 2552 *--ptr = '0' + (char)(uv % 10); 2553 } while (uv /= 10); 2554 if (sign) 2555 *--ptr = '-'; 2556 *peob = ebuf; 2557 return ptr; 2558 } 2559 2560 /* 2561 =for apidoc sv_2pv_flags 2562 2563 Returns a pointer to the string value of an SV, and sets *lp to its length. 2564 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string 2565 if necessary. 2566 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg> 2567 usually end up here too. 2568 2569 =cut 2570 */ 2571 2572 char * 2573 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) 2574 { 2575 dVAR; 2576 register char *s; 2577 2578 if (!sv) { 2579 if (lp) 2580 *lp = 0; 2581 return (char *)""; 2582 } 2583 if (SvGMAGICAL(sv)) { 2584 if (flags & SV_GMAGIC) 2585 mg_get(sv); 2586 if (SvPOKp(sv)) { 2587 if (lp) 2588 *lp = SvCUR(sv); 2589 if (flags & SV_MUTABLE_RETURN) 2590 return SvPVX_mutable(sv); 2591 if (flags & SV_CONST_RETURN) 2592 return (char *)SvPVX_const(sv); 2593 return SvPVX(sv); 2594 } 2595 if (SvIOKp(sv) || SvNOKp(sv)) { 2596 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ 2597 STRLEN len; 2598 2599 if (SvIOKp(sv)) { 2600 len = SvIsUV(sv) 2601 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv)) 2602 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv)); 2603 } else { 2604 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf); 2605 len = strlen(tbuf); 2606 } 2607 assert(!SvROK(sv)); 2608 { 2609 dVAR; 2610 2611 #ifdef FIXNEGATIVEZERO 2612 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') { 2613 tbuf[0] = '0'; 2614 tbuf[1] = 0; 2615 len = 1; 2616 } 2617 #endif 2618 SvUPGRADE(sv, SVt_PV); 2619 if (lp) 2620 *lp = len; 2621 s = SvGROW_mutable(sv, len + 1); 2622 SvCUR_set(sv, len); 2623 SvPOKp_on(sv); 2624 return (char*)memcpy(s, tbuf, len + 1); 2625 } 2626 } 2627 if (SvROK(sv)) { 2628 goto return_rok; 2629 } 2630 assert(SvTYPE(sv) >= SVt_PVMG); 2631 /* This falls through to the report_uninit near the end of the 2632 function. */ 2633 } else if (SvTHINKFIRST(sv)) { 2634 if (SvROK(sv)) { 2635 return_rok: 2636 if (SvAMAGIC(sv)) { 2637 SV *const tmpstr = AMG_CALLun(sv,string); 2638 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2639 /* Unwrap this: */ 2640 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); 2641 */ 2642 2643 char *pv; 2644 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { 2645 if (flags & SV_CONST_RETURN) { 2646 pv = (char *) SvPVX_const(tmpstr); 2647 } else { 2648 pv = (flags & SV_MUTABLE_RETURN) 2649 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); 2650 } 2651 if (lp) 2652 *lp = SvCUR(tmpstr); 2653 } else { 2654 pv = sv_2pv_flags(tmpstr, lp, flags); 2655 } 2656 if (SvUTF8(tmpstr)) 2657 SvUTF8_on(sv); 2658 else 2659 SvUTF8_off(sv); 2660 return pv; 2661 } 2662 } 2663 { 2664 STRLEN len; 2665 char *retval; 2666 char *buffer; 2667 MAGIC *mg; 2668 const SV *const referent = (SV*)SvRV(sv); 2669 2670 if (!referent) { 2671 len = 7; 2672 retval = buffer = savepvn("NULLREF", len); 2673 } else if (SvTYPE(referent) == SVt_PVMG 2674 && ((SvFLAGS(referent) & 2675 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) 2676 == (SVs_OBJECT|SVs_SMG)) 2677 && (mg = mg_find(referent, PERL_MAGIC_qr))) 2678 { 2679 char *str = NULL; 2680 I32 haseval = 0; 2681 U32 flags = 0; 2682 (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); 2683 if (flags & 1) 2684 SvUTF8_on(sv); 2685 else 2686 SvUTF8_off(sv); 2687 PL_reginterp_cnt += haseval; 2688 return str; 2689 } else { 2690 const char *const typestr = sv_reftype(referent, 0); 2691 const STRLEN typelen = strlen(typestr); 2692 UV addr = PTR2UV(referent); 2693 const char *stashname = NULL; 2694 STRLEN stashnamelen = 0; /* hush, gcc */ 2695 const char *buffer_end; 2696 2697 if (SvOBJECT(referent)) { 2698 const HEK *const name = HvNAME_HEK(SvSTASH(referent)); 2699 2700 if (name) { 2701 stashname = HEK_KEY(name); 2702 stashnamelen = HEK_LEN(name); 2703 2704 if (HEK_UTF8(name)) { 2705 SvUTF8_on(sv); 2706 } else { 2707 SvUTF8_off(sv); 2708 } 2709 } else { 2710 stashname = "__ANON__"; 2711 stashnamelen = 8; 2712 } 2713 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ 2714 + 2 * sizeof(UV) + 2 /* )\0 */; 2715 } else { 2716 len = typelen + 3 /* (0x */ 2717 + 2 * sizeof(UV) + 2 /* )\0 */; 2718 } 2719 2720 Newx(buffer, len, char); 2721 buffer_end = retval = buffer + len; 2722 2723 /* Working backwards */ 2724 *--retval = '\0'; 2725 *--retval = ')'; 2726 do { 2727 *--retval = PL_hexdigit[addr & 15]; 2728 } while (addr >>= 4); 2729 *--retval = 'x'; 2730 *--retval = '0'; 2731 *--retval = '('; 2732 2733 retval -= typelen; 2734 memcpy(retval, typestr, typelen); 2735 2736 if (stashname) { 2737 *--retval = '='; 2738 retval -= stashnamelen; 2739 memcpy(retval, stashname, stashnamelen); 2740 } 2741 /* retval may not neccesarily have reached the start of the 2742 buffer here. */ 2743 assert (retval >= buffer); 2744 2745 len = buffer_end - retval - 1; /* -1 for that \0 */ 2746 } 2747 if (lp) 2748 *lp = len; 2749 SAVEFREEPV(buffer); 2750 return retval; 2751 } 2752 } 2753 if (SvREADONLY(sv) && !SvOK(sv)) { 2754 if (ckWARN(WARN_UNINITIALIZED)) 2755 report_uninit(sv); 2756 if (lp) 2757 *lp = 0; 2758 return (char *)""; 2759 } 2760 } 2761 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { 2762 /* I'm assuming that if both IV and NV are equally valid then 2763 converting the IV is going to be more efficient */ 2764 const U32 isUIOK = SvIsUV(sv); 2765 char buf[TYPE_CHARS(UV)]; 2766 char *ebuf, *ptr; 2767 STRLEN len; 2768 2769 if (SvTYPE(sv) < SVt_PVIV) 2770 sv_upgrade(sv, SVt_PVIV); 2771 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); 2772 len = ebuf - ptr; 2773 /* inlined from sv_setpvn */ 2774 s = SvGROW_mutable(sv, len + 1); 2775 Move(ptr, s, len, char); 2776 s += len; 2777 *s = '\0'; 2778 } 2779 else if (SvNOKp(sv)) { 2780 const int olderrno = errno; 2781 if (SvTYPE(sv) < SVt_PVNV) 2782 sv_upgrade(sv, SVt_PVNV); 2783 /* The +20 is pure guesswork. Configure test needed. --jhi */ 2784 s = SvGROW_mutable(sv, NV_DIG + 20); 2785 /* some Xenix systems wipe out errno here */ 2786 #ifdef apollo 2787 if (SvNVX(sv) == 0.0) 2788 my_strlcpy(s, "0", SvLEN(sv)); 2789 else 2790 #endif /*apollo*/ 2791 { 2792 Gconvert(SvNVX(sv), NV_DIG, 0, s); 2793 } 2794 errno = olderrno; 2795 #ifdef FIXNEGATIVEZERO 2796 if (*s == '-' && s[1] == '0' && !s[2]) { 2797 s[0] = '0'; 2798 s[1] = 0; 2799 } 2800 #endif 2801 while (*s) s++; 2802 #ifdef hcx 2803 if (s[-1] == '.') 2804 *--s = '\0'; 2805 #endif 2806 } 2807 else { 2808 if (isGV_with_GP(sv)) 2809 return glob_2pv((GV *)sv, lp); 2810 2811 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) 2812 report_uninit(sv); 2813 if (lp) 2814 *lp = 0; 2815 if (SvTYPE(sv) < SVt_PV) 2816 /* Typically the caller expects that sv_any is not NULL now. */ 2817 sv_upgrade(sv, SVt_PV); 2818 return (char *)""; 2819 } 2820 { 2821 const STRLEN len = s - SvPVX_const(sv); 2822 if (lp) 2823 *lp = len; 2824 SvCUR_set(sv, len); 2825 } 2826 SvPOK_on(sv); 2827 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 2828 PTR2UV(sv),SvPVX_const(sv))); 2829 if (flags & SV_CONST_RETURN) 2830 return (char *)SvPVX_const(sv); 2831 if (flags & SV_MUTABLE_RETURN) 2832 return SvPVX_mutable(sv); 2833 return SvPVX(sv); 2834 } 2835 2836 /* 2837 =for apidoc sv_copypv 2838 2839 Copies a stringified representation of the source SV into the 2840 destination SV. Automatically performs any necessary mg_get and 2841 coercion of numeric values into strings. Guaranteed to preserve 2842 UTF8 flag even from overloaded objects. Similar in nature to 2843 sv_2pv[_flags] but operates directly on an SV instead of just the 2844 string. Mostly uses sv_2pv_flags to do its work, except when that 2845 would lose the UTF-8'ness of the PV. 2846 2847 =cut 2848 */ 2849 2850 void 2851 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) 2852 { 2853 STRLEN len; 2854 const char * const s = SvPV_const(ssv,len); 2855 sv_setpvn(dsv,s,len); 2856 if (SvUTF8(ssv)) 2857 SvUTF8_on(dsv); 2858 else 2859 SvUTF8_off(dsv); 2860 } 2861 2862 /* 2863 =for apidoc sv_2pvbyte 2864 2865 Return a pointer to the byte-encoded representation of the SV, and set *lp 2866 to its length. May cause the SV to be downgraded from UTF-8 as a 2867 side-effect. 2868 2869 Usually accessed via the C<SvPVbyte> macro. 2870 2871 =cut 2872 */ 2873 2874 char * 2875 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) 2876 { 2877 sv_utf8_downgrade(sv,0); 2878 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); 2879 } 2880 2881 /* 2882 =for apidoc sv_2pvutf8 2883 2884 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp 2885 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. 2886 2887 Usually accessed via the C<SvPVutf8> macro. 2888 2889 =cut 2890 */ 2891 2892 char * 2893 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) 2894 { 2895 sv_utf8_upgrade(sv); 2896 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); 2897 } 2898 2899 2900 /* 2901 =for apidoc sv_2bool 2902 2903 This function is only called on magical items, and is only used by 2904 sv_true() or its macro equivalent. 2905 2906 =cut 2907 */ 2908 2909 bool 2910 Perl_sv_2bool(pTHX_ register SV *sv) 2911 { 2912 dVAR; 2913 SvGETMAGIC(sv); 2914 2915 if (!SvOK(sv)) 2916 return 0; 2917 if (SvROK(sv)) { 2918 if (SvAMAGIC(sv)) { 2919 SV * const tmpsv = AMG_CALLun(sv,bool_); 2920 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) 2921 return (bool)SvTRUE(tmpsv); 2922 } 2923 return SvRV(sv) != 0; 2924 } 2925 if (SvPOKp(sv)) { 2926 register XPV* const Xpvtmp = (XPV*)SvANY(sv); 2927 if (Xpvtmp && 2928 (*sv->sv_u.svu_pv > '0' || 2929 Xpvtmp->xpv_cur > 1 || 2930 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) 2931 return 1; 2932 else 2933 return 0; 2934 } 2935 else { 2936 if (SvIOKp(sv)) 2937 return SvIVX(sv) != 0; 2938 else { 2939 if (SvNOKp(sv)) 2940 return SvNVX(sv) != 0.0; 2941 else { 2942 if (isGV_with_GP(sv)) 2943 return TRUE; 2944 else 2945 return FALSE; 2946 } 2947 } 2948 } 2949 } 2950 2951 /* 2952 =for apidoc sv_utf8_upgrade 2953 2954 Converts the PV of an SV to its UTF-8-encoded form. 2955 Forces the SV to string form if it is not already. 2956 Always sets the SvUTF8 flag to avoid future validity checks even 2957 if all the bytes have hibit clear. 2958 2959 This is not as a general purpose byte encoding to Unicode interface: 2960 use the Encode extension for that. 2961 2962 =for apidoc sv_utf8_upgrade_flags 2963 2964 Converts the PV of an SV to its UTF-8-encoded form. 2965 Forces the SV to string form if it is not already. 2966 Always sets the SvUTF8 flag to avoid future validity checks even 2967 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set, 2968 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and 2969 C<sv_utf8_upgrade_nomg> are implemented in terms of this function. 2970 2971 This is not as a general purpose byte encoding to Unicode interface: 2972 use the Encode extension for that. 2973 2974 =cut 2975 */ 2976 2977 STRLEN 2978 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) 2979 { 2980 dVAR; 2981 if (sv == &PL_sv_undef) 2982 return 0; 2983 if (!SvPOK(sv)) { 2984 STRLEN len = 0; 2985 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { 2986 (void) sv_2pv_flags(sv,&len, flags); 2987 if (SvUTF8(sv)) 2988 return len; 2989 } else { 2990 (void) SvPV_force(sv,len); 2991 } 2992 } 2993 2994 if (SvUTF8(sv)) { 2995 return SvCUR(sv); 2996 } 2997 2998 if (SvIsCOW(sv)) { 2999 sv_force_normal_flags(sv, 0); 3000 } 3001 3002 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) 3003 sv_recode_to_utf8(sv, PL_encoding); 3004 else { /* Assume Latin-1/EBCDIC */ 3005 /* This function could be much more efficient if we 3006 * had a FLAG in SVs to signal if there are any hibit 3007 * chars in the PV. Given that there isn't such a flag 3008 * make the loop as fast as possible. */ 3009 const U8 * const s = (U8 *) SvPVX_const(sv); 3010 const U8 * const e = (U8 *) SvEND(sv); 3011 const U8 *t = s; 3012 3013 while (t < e) { 3014 const U8 ch = *t++; 3015 /* Check for hi bit */ 3016 if (!NATIVE_IS_INVARIANT(ch)) { 3017 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ 3018 U8 * const recoded = bytes_to_utf8((U8*)s, &len); 3019 3020 SvPV_free(sv); /* No longer using what was there before. */ 3021 SvPV_set(sv, (char*)recoded); 3022 SvCUR_set(sv, len - 1); 3023 SvLEN_set(sv, len); /* No longer know the real size. */ 3024 break; 3025 } 3026 } 3027 /* Mark as UTF-8 even if no hibit - saves scanning loop */ 3028 SvUTF8_on(sv); 3029 } 3030 return SvCUR(sv); 3031 } 3032 3033 /* 3034 =for apidoc sv_utf8_downgrade 3035 3036 Attempts to convert the PV of an SV from characters to bytes. 3037 If the PV contains a character beyond byte, this conversion will fail; 3038 in this case, either returns false or, if C<fail_ok> is not 3039 true, croaks. 3040 3041 This is not as a general purpose Unicode to byte encoding interface: 3042 use the Encode extension for that. 3043 3044 =cut 3045 */ 3046 3047 bool 3048 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) 3049 { 3050 dVAR; 3051 if (SvPOKp(sv) && SvUTF8(sv)) { 3052 if (SvCUR(sv)) { 3053 U8 *s; 3054 STRLEN len; 3055 3056 if (SvIsCOW(sv)) { 3057 sv_force_normal_flags(sv, 0); 3058 } 3059 s = (U8 *) SvPV(sv, len); 3060 if (!utf8_to_bytes(s, &len)) { 3061 if (fail_ok) 3062 return FALSE; 3063 else { 3064 if (PL_op) 3065 Perl_croak(aTHX_ "Wide character in %s", 3066 OP_DESC(PL_op)); 3067 else 3068 Perl_croak(aTHX_ "Wide character"); 3069 } 3070 } 3071 SvCUR_set(sv, len); 3072 } 3073 } 3074 SvUTF8_off(sv); 3075 return TRUE; 3076 } 3077 3078 /* 3079 =for apidoc sv_utf8_encode 3080 3081 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8> 3082 flag off so that it looks like octets again. 3083 3084 =cut 3085 */ 3086 3087 void 3088 Perl_sv_utf8_encode(pTHX_ register SV *sv) 3089 { 3090 if (SvIsCOW(sv)) { 3091 sv_force_normal_flags(sv, 0); 3092 } 3093 if (SvREADONLY(sv)) { 3094 Perl_croak(aTHX_ PL_no_modify); 3095 } 3096 (void) sv_utf8_upgrade(sv); 3097 SvUTF8_off(sv); 3098 } 3099 3100 /* 3101 =for apidoc sv_utf8_decode 3102 3103 If the PV of the SV is an octet sequence in UTF-8 3104 and contains a multiple-byte character, the C<SvUTF8> flag is turned on 3105 so that it looks like a character. If the PV contains only single-byte 3106 characters, the C<SvUTF8> flag stays being off. 3107 Scans PV for validity and returns false if the PV is invalid UTF-8. 3108 3109 =cut 3110 */ 3111 3112 bool 3113 Perl_sv_utf8_decode(pTHX_ register SV *sv) 3114 { 3115 if (SvPOKp(sv)) { 3116 const U8 *c; 3117 const U8 *e; 3118 3119 /* The octets may have got themselves encoded - get them back as 3120 * bytes 3121 */ 3122 if (!sv_utf8_downgrade(sv, TRUE)) 3123 return FALSE; 3124 3125 /* it is actually just a matter of turning the utf8 flag on, but 3126 * we want to make sure everything inside is valid utf8 first. 3127 */ 3128 c = (const U8 *) SvPVX_const(sv); 3129 if (!is_utf8_string(c, SvCUR(sv)+1)) 3130 return FALSE; 3131 e = (const U8 *) SvEND(sv); 3132 while (c < e) { 3133 const U8 ch = *c++; 3134 if (!UTF8_IS_INVARIANT(ch)) { 3135 SvUTF8_on(sv); 3136 break; 3137 } 3138 } 3139 } 3140 return TRUE; 3141 } 3142 3143 /* 3144 =for apidoc sv_setsv 3145 3146 Copies the contents of the source SV C<ssv> into the destination SV 3147 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this 3148 function if the source SV needs to be reused. Does not handle 'set' magic. 3149 Loosely speaking, it performs a copy-by-value, obliterating any previous 3150 content of the destination. 3151 3152 You probably want to use one of the assortment of wrappers, such as 3153 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and 3154 C<SvSetMagicSV_nosteal>. 3155 3156 =for apidoc sv_setsv_flags 3157 3158 Copies the contents of the source SV C<ssv> into the destination SV 3159 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this 3160 function if the source SV needs to be reused. Does not handle 'set' magic. 3161 Loosely speaking, it performs a copy-by-value, obliterating any previous 3162 content of the destination. 3163 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on 3164 C<ssv> if appropriate, else not. If the C<flags> parameter has the 3165 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv> 3166 and C<sv_setsv_nomg> are implemented in terms of this function. 3167 3168 You probably want to use one of the assortment of wrappers, such as 3169 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and 3170 C<SvSetMagicSV_nosteal>. 3171 3172 This is the primary function for copying scalars, and most other 3173 copy-ish functions and macros use this underneath. 3174 3175 =cut 3176 */ 3177 3178 static void 3179 S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) 3180 { 3181 I32 mro_changes = 0; /* 1 = method, 2 = isa */ 3182 3183 if (dtype != SVt_PVGV) { 3184 const char * const name = GvNAME(sstr); 3185 const STRLEN len = GvNAMELEN(sstr); 3186 { 3187 if (dtype >= SVt_PV) { 3188 SvPV_free(dstr); 3189 SvPV_set(dstr, 0); 3190 SvLEN_set(dstr, 0); 3191 SvCUR_set(dstr, 0); 3192 } 3193 SvUPGRADE(dstr, SVt_PVGV); 3194 (void)SvOK_off(dstr); 3195 /* FIXME - why are we doing this, then turning it off and on again 3196 below? */ 3197 isGV_with_GP_on(dstr); 3198 } 3199 GvSTASH(dstr) = GvSTASH(sstr); 3200 if (GvSTASH(dstr)) 3201 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr); 3202 gv_name_set((GV *)dstr, name, len, GV_ADD); 3203 SvFAKE_on(dstr); /* can coerce to non-glob */ 3204 } 3205 3206 #ifdef GV_UNIQUE_CHECK 3207 if (GvUNIQUE((GV*)dstr)) { 3208 Perl_croak(aTHX_ PL_no_modify); 3209 } 3210 #endif 3211 3212 if(GvGP((GV*)sstr)) { 3213 /* If source has method cache entry, clear it */ 3214 if(GvCVGEN(sstr)) { 3215 SvREFCNT_dec(GvCV(sstr)); 3216 GvCV(sstr) = NULL; 3217 GvCVGEN(sstr) = 0; 3218 } 3219 /* If source has a real method, then a method is 3220 going to change */ 3221 else if(GvCV((GV*)sstr)) { 3222 mro_changes = 1; 3223 } 3224 } 3225 3226 /* If dest already had a real method, that's a change as well */ 3227 if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) { 3228 mro_changes = 1; 3229 } 3230 3231 if(strEQ(GvNAME((GV*)dstr),"ISA")) 3232 mro_changes = 2; 3233 3234 gp_free((GV*)dstr); 3235 isGV_with_GP_off(dstr); 3236 (void)SvOK_off(dstr); 3237 isGV_with_GP_on(dstr); 3238 GvINTRO_off(dstr); /* one-shot flag */ 3239 GvGP(dstr) = gp_ref(GvGP(sstr)); 3240 if (SvTAINTED(sstr)) 3241 SvTAINT(dstr); 3242 if (GvIMPORTED(dstr) != GVf_IMPORTED 3243 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) 3244 { 3245 GvIMPORTED_on(dstr); 3246 } 3247 GvMULTI_on(dstr); 3248 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr)); 3249 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); 3250 return; 3251 } 3252 3253 static void 3254 S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { 3255 SV * const sref = SvREFCNT_inc(SvRV(sstr)); 3256 SV *dref = NULL; 3257 const int intro = GvINTRO(dstr); 3258 SV **location; 3259 U8 import_flag = 0; 3260 const U32 stype = SvTYPE(sref); 3261 3262 3263 #ifdef GV_UNIQUE_CHECK 3264 if (GvUNIQUE((GV*)dstr)) { 3265 Perl_croak(aTHX_ PL_no_modify); 3266 } 3267 #endif 3268 3269 if (intro) { 3270 GvINTRO_off(dstr); /* one-shot flag */ 3271 GvLINE(dstr) = CopLINE(PL_curcop); 3272 GvEGV(dstr) = (GV*)dstr; 3273 } 3274 GvMULTI_on(dstr); 3275 switch (stype) { 3276 case SVt_PVCV: 3277 location = (SV **) &GvCV(dstr); 3278 import_flag = GVf_IMPORTED_CV; 3279 goto common; 3280 case SVt_PVHV: 3281 location = (SV **) &GvHV(dstr); 3282 import_flag = GVf_IMPORTED_HV; 3283 goto common; 3284 case SVt_PVAV: 3285 location = (SV **) &GvAV(dstr); 3286 import_flag = GVf_IMPORTED_AV; 3287 goto common; 3288 case SVt_PVIO: 3289 location = (SV **) &GvIOp(dstr); 3290 goto common; 3291 case SVt_PVFM: 3292 location = (SV **) &GvFORM(dstr); 3293 default: 3294 location = &GvSV(dstr); 3295 import_flag = GVf_IMPORTED_SV; 3296 common: 3297 if (intro) { 3298 if (stype == SVt_PVCV) { 3299 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/ 3300 if (GvCVGEN(dstr)) { 3301 SvREFCNT_dec(GvCV(dstr)); 3302 GvCV(dstr) = NULL; 3303 GvCVGEN(dstr) = 0; /* Switch off cacheness. */ 3304 } 3305 } 3306 SAVEGENERICSV(*location); 3307 } 3308 else 3309 dref = *location; 3310 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { 3311 CV* const cv = (CV*)*location; 3312 if (cv) { 3313 if (!GvCVGEN((GV*)dstr) && 3314 (CvROOT(cv) || CvXSUB(cv))) 3315 { 3316 /* Redefining a sub - warning is mandatory if 3317 it was a const and its value changed. */ 3318 if (CvCONST(cv) && CvCONST((CV*)sref) 3319 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) { 3320 NOOP; 3321 /* They are 2 constant subroutines generated from 3322 the same constant. This probably means that 3323 they are really the "same" proxy subroutine 3324 instantiated in 2 places. Most likely this is 3325 when a constant is exported twice. Don't warn. 3326 */ 3327 } 3328 else if (ckWARN(WARN_REDEFINE) 3329 || (CvCONST(cv) 3330 && (!CvCONST((CV*)sref) 3331 || sv_cmp(cv_const_sv(cv), 3332 cv_const_sv((CV*)sref))))) { 3333 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 3334 (const char *) 3335 (CvCONST(cv) 3336 ? "Constant subroutine %s::%s redefined" 3337 : "Subroutine %s::%s redefined"), 3338 HvNAME_get(GvSTASH((GV*)dstr)), 3339 GvENAME((GV*)dstr)); 3340 } 3341 } 3342 if (!intro) 3343 cv_ckproto_len(cv, (GV*)dstr, 3344 SvPOK(sref) ? SvPVX_const(sref) : NULL, 3345 SvPOK(sref) ? SvCUR(sref) : 0); 3346 } 3347 GvCVGEN(dstr) = 0; /* Switch off cacheness. */ 3348 GvASSUMECV_on(dstr); 3349 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ 3350 } 3351 *location = sref; 3352 if (import_flag && !(GvFLAGS(dstr) & import_flag) 3353 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { 3354 GvFLAGS(dstr) |= import_flag; 3355 } 3356 break; 3357 } 3358 SvREFCNT_dec(dref); 3359 if (SvTAINTED(sstr)) 3360 SvTAINT(dstr); 3361 return; 3362 } 3363 3364 void 3365 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 3366 { 3367 dVAR; 3368 register U32 sflags; 3369 register int dtype; 3370 register svtype stype; 3371 3372 if (sstr == dstr) 3373 return; 3374 3375 if (SvIS_FREED(dstr)) { 3376 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf 3377 " to a freed scalar %p", SVfARG(sstr), (void *)dstr); 3378 } 3379 SV_CHECK_THINKFIRST_COW_DROP(dstr); 3380 if (!sstr) 3381 sstr = &PL_sv_undef; 3382 if (SvIS_FREED(sstr)) { 3383 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", 3384 (void*)sstr, (void*)dstr); 3385 } 3386 stype = SvTYPE(sstr); 3387 dtype = SvTYPE(dstr); 3388 3389 (void)SvAMAGIC_off(dstr); 3390 if ( SvVOK(dstr) ) 3391 { 3392 /* need to nuke the magic */ 3393 mg_free(dstr); 3394 SvRMAGICAL_off(dstr); 3395 } 3396 3397 /* There's a lot of redundancy below but we're going for speed here */ 3398 3399 switch (stype) { 3400 case SVt_NULL: 3401 undef_sstr: 3402 if (dtype != SVt_PVGV) { 3403 (void)SvOK_off(dstr); 3404 return; 3405 } 3406 break; 3407 case SVt_IV: 3408 if (SvIOK(sstr)) { 3409 switch (dtype) { 3410 case SVt_NULL: 3411 sv_upgrade(dstr, SVt_IV); 3412 break; 3413 case SVt_NV: 3414 case SVt_RV: 3415 case SVt_PV: 3416 sv_upgrade(dstr, SVt_PVIV); 3417 break; 3418 case SVt_PVGV: 3419 goto end_of_first_switch; 3420 } 3421 (void)SvIOK_only(dstr); 3422 SvIV_set(dstr, SvIVX(sstr)); 3423 if (SvIsUV(sstr)) 3424 SvIsUV_on(dstr); 3425 /* SvTAINTED can only be true if the SV has taint magic, which in 3426 turn means that the SV type is PVMG (or greater). This is the 3427 case statement for SVt_IV, so this cannot be true (whatever gcov 3428 may say). */ 3429 assert(!SvTAINTED(sstr)); 3430 return; 3431 } 3432 goto undef_sstr; 3433 3434 case SVt_NV: 3435 if (SvNOK(sstr)) { 3436 switch (dtype) { 3437 case SVt_NULL: 3438 case SVt_IV: 3439 sv_upgrade(dstr, SVt_NV); 3440 break; 3441 case SVt_RV: 3442 case SVt_PV: 3443 case SVt_PVIV: 3444 sv_upgrade(dstr, SVt_PVNV); 3445 break; 3446 case SVt_PVGV: 3447 goto end_of_first_switch; 3448 } 3449 SvNV_set(dstr, SvNVX(sstr)); 3450 (void)SvNOK_only(dstr); 3451 /* SvTAINTED can only be true if the SV has taint magic, which in 3452 turn means that the SV type is PVMG (or greater). This is the 3453 case statement for SVt_NV, so this cannot be true (whatever gcov 3454 may say). */ 3455 assert(!SvTAINTED(sstr)); 3456 return; 3457 } 3458 goto undef_sstr; 3459 3460 case SVt_RV: 3461 if (dtype < SVt_RV) 3462 sv_upgrade(dstr, SVt_RV); 3463 break; 3464 case SVt_PVFM: 3465 #ifdef PERL_OLD_COPY_ON_WRITE 3466 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { 3467 if (dtype < SVt_PVIV) 3468 sv_upgrade(dstr, SVt_PVIV); 3469 break; 3470 } 3471 /* Fall through */ 3472 #endif 3473 case SVt_PV: 3474 if (dtype < SVt_PV) 3475 sv_upgrade(dstr, SVt_PV); 3476 break; 3477 case SVt_PVIV: 3478 if (dtype < SVt_PVIV) 3479 sv_upgrade(dstr, SVt_PVIV); 3480 break; 3481 case SVt_PVNV: 3482 if (dtype < SVt_PVNV) 3483 sv_upgrade(dstr, SVt_PVNV); 3484 break; 3485 default: 3486 { 3487 const char * const type = sv_reftype(sstr,0); 3488 if (PL_op) 3489 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op)); 3490 else 3491 Perl_croak(aTHX_ "Bizarre copy of %s", type); 3492 } 3493 break; 3494 3495 /* case SVt_BIND: */ 3496 case SVt_PVLV: 3497 case SVt_PVGV: 3498 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { 3499 glob_assign_glob(dstr, sstr, dtype); 3500 return; 3501 } 3502 /* SvVALID means that this PVGV is playing at being an FBM. */ 3503 /*FALLTHROUGH*/ 3504 3505 case SVt_PVMG: 3506 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { 3507 mg_get(sstr); 3508 if (SvTYPE(sstr) != stype) { 3509 stype = SvTYPE(sstr); 3510 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) { 3511 glob_assign_glob(dstr, sstr, dtype); 3512 return; 3513 } 3514 } 3515 } 3516 if (stype == SVt_PVLV) 3517 SvUPGRADE(dstr, SVt_PVNV); 3518 else 3519 SvUPGRADE(dstr, (svtype)stype); 3520 } 3521 end_of_first_switch: 3522 3523 /* dstr may have been upgraded. */ 3524 dtype = SvTYPE(dstr); 3525 sflags = SvFLAGS(sstr); 3526 3527 if (dtype == SVt_PVCV || dtype == SVt_PVFM) { 3528 /* Assigning to a subroutine sets the prototype. */ 3529 if (SvOK(sstr)) { 3530 STRLEN len; 3531 const char *const ptr = SvPV_const(sstr, len); 3532 3533 SvGROW(dstr, len + 1); 3534 Copy(ptr, SvPVX(dstr), len + 1, char); 3535 SvCUR_set(dstr, len); 3536 SvPOK_only(dstr); 3537 SvFLAGS(dstr) |= sflags & SVf_UTF8; 3538 } else { 3539 SvOK_off(dstr); 3540 } 3541 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { 3542 const char * const type = sv_reftype(dstr,0); 3543 if (PL_op) 3544 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op)); 3545 else 3546 Perl_croak(aTHX_ "Cannot copy to %s", type); 3547 } else if (sflags & SVf_ROK) { 3548 if (isGV_with_GP(dstr) && dtype == SVt_PVGV 3549 && SvTYPE(SvRV(sstr)) == SVt_PVGV) { 3550 sstr = SvRV(sstr); 3551 if (sstr == dstr) { 3552 if (GvIMPORTED(dstr) != GVf_IMPORTED 3553 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) 3554 { 3555 GvIMPORTED_on(dstr); 3556 } 3557 GvMULTI_on(dstr); 3558 return; 3559 } 3560 glob_assign_glob(dstr, sstr, dtype); 3561 return; 3562 } 3563 3564 if (dtype >= SVt_PV) { 3565 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { 3566 glob_assign_ref(dstr, sstr); 3567 return; 3568 } 3569 if (SvPVX_const(dstr)) { 3570 SvPV_free(dstr); 3571 SvLEN_set(dstr, 0); 3572 SvCUR_set(dstr, 0); 3573 } 3574 } 3575 (void)SvOK_off(dstr); 3576 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); 3577 SvFLAGS(dstr) |= sflags & SVf_ROK; 3578 assert(!(sflags & SVp_NOK)); 3579 assert(!(sflags & SVp_IOK)); 3580 assert(!(sflags & SVf_NOK)); 3581 assert(!(sflags & SVf_IOK)); 3582 } 3583 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { 3584 if (!(sflags & SVf_OK)) { 3585 if (ckWARN(WARN_MISC)) 3586 Perl_warner(aTHX_ packWARN(WARN_MISC), 3587 "Undefined value assigned to typeglob"); 3588 } 3589 else { 3590 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV); 3591 if (dstr != (SV*)gv) { 3592 if (GvGP(dstr)) 3593 gp_free((GV*)dstr); 3594 GvGP(dstr) = gp_ref(GvGP(gv)); 3595 } 3596 } 3597 } 3598 else if (sflags & SVp_POK) { 3599 bool isSwipe = 0; 3600 3601 /* 3602 * Check to see if we can just swipe the string. If so, it's a 3603 * possible small lose on short strings, but a big win on long ones. 3604 * It might even be a win on short strings if SvPVX_const(dstr) 3605 * has to be allocated and SvPVX_const(sstr) has to be freed. 3606 * Likewise if we can set up COW rather than doing an actual copy, we 3607 * drop to the else clause, as the swipe code and the COW setup code 3608 * have much in common. 3609 */ 3610 3611 /* Whichever path we take through the next code, we want this true, 3612 and doing it now facilitates the COW check. */ 3613 (void)SvPOK_only(dstr); 3614 3615 if ( 3616 /* If we're already COW then this clause is not true, and if COW 3617 is allowed then we drop down to the else and make dest COW 3618 with us. If caller hasn't said that we're allowed to COW 3619 shared hash keys then we don't do the COW setup, even if the 3620 source scalar is a shared hash key scalar. */ 3621 (((flags & SV_COW_SHARED_HASH_KEYS) 3622 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY) 3623 : 1 /* If making a COW copy is forbidden then the behaviour we 3624 desire is as if the source SV isn't actually already 3625 COW, even if it is. So we act as if the source flags 3626 are not COW, rather than actually testing them. */ 3627 ) 3628 #ifndef PERL_OLD_COPY_ON_WRITE 3629 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic 3630 when PERL_OLD_COPY_ON_WRITE is defined a little wrong. 3631 Conceptually PERL_OLD_COPY_ON_WRITE being defined should 3632 override SV_COW_SHARED_HASH_KEYS, because it means "always COW" 3633 but in turn, it's somewhat dead code, never expected to go 3634 live, but more kept as a placeholder on how to do it better 3635 in a newer implementation. */ 3636 /* If we are COW and dstr is a suitable target then we drop down 3637 into the else and make dest a COW of us. */ 3638 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS 3639 #endif 3640 ) 3641 && 3642 !(isSwipe = 3643 (sflags & SVs_TEMP) && /* slated for free anyway? */ 3644 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ 3645 (!(flags & SV_NOSTEAL)) && 3646 /* and we're allowed to steal temps */ 3647 SvREFCNT(sstr) == 1 && /* and no other references to it? */ 3648 SvLEN(sstr) && /* and really is a string */ 3649 /* and won't be needed again, potentially */ 3650 !(PL_op && PL_op->op_type == OP_AASSIGN)) 3651 #ifdef PERL_OLD_COPY_ON_WRITE 3652 && ((flags & SV_COW_SHARED_HASH_KEYS) 3653 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS 3654 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS 3655 && SvTYPE(sstr) >= SVt_PVIV)) 3656 : 1) 3657 #endif 3658 ) { 3659 /* Failed the swipe test, and it's not a shared hash key either. 3660 Have to copy the string. */ 3661 STRLEN len = SvCUR(sstr); 3662 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ 3663 Move(SvPVX_const(sstr),SvPVX(dstr),len,char); 3664 SvCUR_set(dstr, len); 3665 *SvEND(dstr) = '\0'; 3666 } else { 3667 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always 3668 be true in here. */ 3669 /* Either it's a shared hash key, or it's suitable for 3670 copy-on-write or we can swipe the string. */ 3671 if (DEBUG_C_TEST) { 3672 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); 3673 sv_dump(sstr); 3674 sv_dump(dstr); 3675 } 3676 #ifdef PERL_OLD_COPY_ON_WRITE 3677 if (!isSwipe) { 3678 /* I believe I should acquire a global SV mutex if 3679 it's a COW sv (not a shared hash key) to stop 3680 it going un copy-on-write. 3681 If the source SV has gone un copy on write between up there 3682 and down here, then (assert() that) it is of the correct 3683 form to make it copy on write again */ 3684 if ((sflags & (SVf_FAKE | SVf_READONLY)) 3685 != (SVf_FAKE | SVf_READONLY)) { 3686 SvREADONLY_on(sstr); 3687 SvFAKE_on(sstr); 3688 /* Make the source SV into a loop of 1. 3689 (about to become 2) */ 3690 SV_COW_NEXT_SV_SET(sstr, sstr); 3691 } 3692 } 3693 #endif 3694 /* Initial code is common. */ 3695 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ 3696 SvPV_free(dstr); 3697 } 3698 3699 if (!isSwipe) { 3700 /* making another shared SV. */ 3701 STRLEN cur = SvCUR(sstr); 3702 STRLEN len = SvLEN(sstr); 3703 #ifdef PERL_OLD_COPY_ON_WRITE 3704 if (len) { 3705 assert (SvTYPE(dstr) >= SVt_PVIV); 3706 /* SvIsCOW_normal */ 3707 /* splice us in between source and next-after-source. */ 3708 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); 3709 SV_COW_NEXT_SV_SET(sstr, dstr); 3710 SvPV_set(dstr, SvPVX_mutable(sstr)); 3711 } else 3712 #endif 3713 { 3714 /* SvIsCOW_shared_hash */ 3715 DEBUG_C(PerlIO_printf(Perl_debug_log, 3716 "Copy on write: Sharing hash\n")); 3717 3718 assert (SvTYPE(dstr) >= SVt_PV); 3719 SvPV_set(dstr, 3720 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); 3721 } 3722 SvLEN_set(dstr, len); 3723 SvCUR_set(dstr, cur); 3724 SvREADONLY_on(dstr); 3725 SvFAKE_on(dstr); 3726 /* Relesase a global SV mutex. */ 3727 } 3728 else 3729 { /* Passes the swipe test. */ 3730 SvPV_set(dstr, SvPVX_mutable(sstr)); 3731 SvLEN_set(dstr, SvLEN(sstr)); 3732 SvCUR_set(dstr, SvCUR(sstr)); 3733 3734 SvTEMP_off(dstr); 3735 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ 3736 SvPV_set(sstr, NULL); 3737 SvLEN_set(sstr, 0); 3738 SvCUR_set(sstr, 0); 3739 SvTEMP_off(sstr); 3740 } 3741 } 3742 if (sflags & SVp_NOK) { 3743 SvNV_set(dstr, SvNVX(sstr)); 3744 } 3745 if (sflags & SVp_IOK) { 3746 SvOOK_off(dstr); 3747 SvIV_set(dstr, SvIVX(sstr)); 3748 /* Must do this otherwise some other overloaded use of 0x80000000 3749 gets confused. I guess SVpbm_VALID */ 3750 if (sflags & SVf_IVisUV) 3751 SvIsUV_on(dstr); 3752 } 3753 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); 3754 { 3755 const MAGIC * const smg = SvVSTRING_mg(sstr); 3756 if (smg) { 3757 sv_magic(dstr, NULL, PERL_MAGIC_vstring, 3758 smg->mg_ptr, smg->mg_len); 3759 SvRMAGICAL_on(dstr); 3760 } 3761 } 3762 } 3763 else if (sflags & (SVp_IOK|SVp_NOK)) { 3764 (void)SvOK_off(dstr); 3765 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); 3766 if (sflags & SVp_IOK) { 3767 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ 3768 SvIV_set(dstr, SvIVX(sstr)); 3769 } 3770 if (sflags & SVp_NOK) { 3771 SvNV_set(dstr, SvNVX(sstr)); 3772 } 3773 } 3774 else { 3775 if (isGV_with_GP(sstr)) { 3776 /* This stringification rule for globs is spread in 3 places. 3777 This feels bad. FIXME. */ 3778 const U32 wasfake = sflags & SVf_FAKE; 3779 3780 /* FAKE globs can get coerced, so need to turn this off 3781 temporarily if it is on. */ 3782 SvFAKE_off(sstr); 3783 gv_efullname3(dstr, (GV *)sstr, "*"); 3784 SvFLAGS(sstr) |= wasfake; 3785 } 3786 else 3787 (void)SvOK_off(dstr); 3788 } 3789 if (SvTAINTED(sstr)) 3790 SvTAINT(dstr); 3791 } 3792 3793 /* 3794 =for apidoc sv_setsv_mg 3795 3796 Like C<sv_setsv>, but also handles 'set' magic. 3797 3798 =cut 3799 */ 3800 3801 void 3802 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) 3803 { 3804 sv_setsv(dstr,sstr); 3805 SvSETMAGIC(dstr); 3806 } 3807 3808 #ifdef PERL_OLD_COPY_ON_WRITE 3809 SV * 3810 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) 3811 { 3812 STRLEN cur = SvCUR(sstr); 3813 STRLEN len = SvLEN(sstr); 3814 register char *new_pv; 3815 3816 if (DEBUG_C_TEST) { 3817 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", 3818 (void*)sstr, (void*)dstr); 3819 sv_dump(sstr); 3820 if (dstr) 3821 sv_dump(dstr); 3822 } 3823 3824 if (dstr) { 3825 if (SvTHINKFIRST(dstr)) 3826 sv_force_normal_flags(dstr, SV_COW_DROP_PV); 3827 else if (SvPVX_const(dstr)) 3828 Safefree(SvPVX_const(dstr)); 3829 } 3830 else 3831 new_SV(dstr); 3832 SvUPGRADE(dstr, SVt_PVIV); 3833 3834 assert (SvPOK(sstr)); 3835 assert (SvPOKp(sstr)); 3836 assert (!SvIOK(sstr)); 3837 assert (!SvIOKp(sstr)); 3838 assert (!SvNOK(sstr)); 3839 assert (!SvNOKp(sstr)); 3840 3841 if (SvIsCOW(sstr)) { 3842 3843 if (SvLEN(sstr) == 0) { 3844 /* source is a COW shared hash key. */ 3845 DEBUG_C(PerlIO_printf(Perl_debug_log, 3846 "Fast copy on write: Sharing hash\n")); 3847 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); 3848 goto common_exit; 3849 } 3850 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); 3851 } else { 3852 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); 3853 SvUPGRADE(sstr, SVt_PVIV); 3854 SvREADONLY_on(sstr); 3855 SvFAKE_on(sstr); 3856 DEBUG_C(PerlIO_printf(Perl_debug_log, 3857 "Fast copy on write: Converting sstr to COW\n")); 3858 SV_COW_NEXT_SV_SET(dstr, sstr); 3859 } 3860 SV_COW_NEXT_SV_SET(sstr, dstr); 3861 new_pv = SvPVX_mutable(sstr); 3862 3863 common_exit: 3864 SvPV_set(dstr, new_pv); 3865 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY); 3866 if (SvUTF8(sstr)) 3867 SvUTF8_on(dstr); 3868 SvLEN_set(dstr, len); 3869 SvCUR_set(dstr, cur); 3870 if (DEBUG_C_TEST) { 3871 sv_dump(dstr); 3872 } 3873 return dstr; 3874 } 3875 #endif 3876 3877 /* 3878 =for apidoc sv_setpvn 3879 3880 Copies a string into an SV. The C<len> parameter indicates the number of 3881 bytes to be copied. If the C<ptr> argument is NULL the SV will become 3882 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>. 3883 3884 =cut 3885 */ 3886 3887 void 3888 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) 3889 { 3890 dVAR; 3891 register char *dptr; 3892 3893 SV_CHECK_THINKFIRST_COW_DROP(sv); 3894 if (!ptr) { 3895 (void)SvOK_off(sv); 3896 return; 3897 } 3898 else { 3899 /* len is STRLEN which is unsigned, need to copy to signed */ 3900 const IV iv = len; 3901 if (iv < 0) 3902 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen"); 3903 } 3904 SvUPGRADE(sv, SVt_PV); 3905 3906 dptr = SvGROW(sv, len + 1); 3907 Move(ptr,dptr,len,char); 3908 dptr[len] = '\0'; 3909 SvCUR_set(sv, len); 3910 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 3911 SvTAINT(sv); 3912 } 3913 3914 /* 3915 =for apidoc sv_setpvn_mg 3916 3917 Like C<sv_setpvn>, but also handles 'set' magic. 3918 3919 =cut 3920 */ 3921 3922 void 3923 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) 3924 { 3925 sv_setpvn(sv,ptr,len); 3926 SvSETMAGIC(sv); 3927 } 3928 3929 /* 3930 =for apidoc sv_setpv 3931 3932 Copies a string into an SV. The string must be null-terminated. Does not 3933 handle 'set' magic. See C<sv_setpv_mg>. 3934 3935 =cut 3936 */ 3937 3938 void 3939 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) 3940 { 3941 dVAR; 3942 register STRLEN len; 3943 3944 SV_CHECK_THINKFIRST_COW_DROP(sv); 3945 if (!ptr) { 3946 (void)SvOK_off(sv); 3947 return; 3948 } 3949 len = strlen(ptr); 3950 SvUPGRADE(sv, SVt_PV); 3951 3952 SvGROW(sv, len + 1); 3953 Move(ptr,SvPVX(sv),len+1,char); 3954 SvCUR_set(sv, len); 3955 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 3956 SvTAINT(sv); 3957 } 3958 3959 /* 3960 =for apidoc sv_setpv_mg 3961 3962 Like C<sv_setpv>, but also handles 'set' magic. 3963 3964 =cut 3965 */ 3966 3967 void 3968 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) 3969 { 3970 sv_setpv(sv,ptr); 3971 SvSETMAGIC(sv); 3972 } 3973 3974 /* 3975 =for apidoc sv_usepvn_flags 3976 3977 Tells an SV to use C<ptr> to find its string value. Normally the 3978 string is stored inside the SV but sv_usepvn allows the SV to use an 3979 outside string. The C<ptr> should point to memory that was allocated 3980 by C<malloc>. The string length, C<len>, must be supplied. By default 3981 this function will realloc (i.e. move) the memory pointed to by C<ptr>, 3982 so that pointer should not be freed or used by the programmer after 3983 giving it to sv_usepvn, and neither should any pointers from "behind" 3984 that pointer (e.g. ptr + 1) be used. 3985 3986 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> & 3987 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc 3988 will be skipped. (i.e. the buffer is actually at least 1 byte longer than 3989 C<len>, and already meets the requirements for storing in C<SvPVX>) 3990 3991 =cut 3992 */ 3993 3994 void 3995 Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) 3996 { 3997 dVAR; 3998 STRLEN allocate; 3999 SV_CHECK_THINKFIRST_COW_DROP(sv); 4000 SvUPGRADE(sv, SVt_PV); 4001 if (!ptr) { 4002 (void)SvOK_off(sv); 4003 if (flags & SV_SMAGIC) 4004 SvSETMAGIC(sv); 4005 return; 4006 } 4007 if (SvPVX_const(sv)) 4008 SvPV_free(sv); 4009 4010 #ifdef DEBUGGING 4011 if (flags & SV_HAS_TRAILING_NUL) 4012 assert(ptr[len] == '\0'); 4013 #endif 4014 4015 allocate = (flags & SV_HAS_TRAILING_NUL) 4016 ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); 4017 if (flags & SV_HAS_TRAILING_NUL) { 4018 /* It's long enough - do nothing. 4019 Specfically Perl_newCONSTSUB is relying on this. */ 4020 } else { 4021 #ifdef DEBUGGING 4022 /* Force a move to shake out bugs in callers. */ 4023 char *new_ptr = (char*)safemalloc(allocate); 4024 Copy(ptr, new_ptr, len, char); 4025 PoisonFree(ptr,len,char); 4026 Safefree(ptr); 4027 ptr = new_ptr; 4028 #else 4029 ptr = (char*) saferealloc (ptr, allocate); 4030 #endif 4031 } 4032 SvPV_set(sv, ptr); 4033 SvCUR_set(sv, len); 4034 SvLEN_set(sv, allocate); 4035 if (!(flags & SV_HAS_TRAILING_NUL)) { 4036 ptr[len] = '\0'; 4037 } 4038 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4039 SvTAINT(sv); 4040 if (flags & SV_SMAGIC) 4041 SvSETMAGIC(sv); 4042 } 4043 4044 #ifdef PERL_OLD_COPY_ON_WRITE 4045 /* Need to do this *after* making the SV normal, as we need the buffer 4046 pointer to remain valid until after we've copied it. If we let go too early, 4047 another thread could invalidate it by unsharing last of the same hash key 4048 (which it can do by means other than releasing copy-on-write Svs) 4049 or by changing the other copy-on-write SVs in the loop. */ 4050 STATIC void 4051 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after) 4052 { 4053 { /* this SV was SvIsCOW_normal(sv) */ 4054 /* we need to find the SV pointing to us. */ 4055 SV *current = SV_COW_NEXT_SV(after); 4056 4057 if (current == sv) { 4058 /* The SV we point to points back to us (there were only two of us 4059 in the loop.) 4060 Hence other SV is no longer copy on write either. */ 4061 SvFAKE_off(after); 4062 SvREADONLY_off(after); 4063 } else { 4064 /* We need to follow the pointers around the loop. */ 4065 SV *next; 4066 while ((next = SV_COW_NEXT_SV(current)) != sv) { 4067 assert (next); 4068 current = next; 4069 /* don't loop forever if the structure is bust, and we have 4070 a pointer into a closed loop. */ 4071 assert (current != after); 4072 assert (SvPVX_const(current) == pvx); 4073 } 4074 /* Make the SV before us point to the SV after us. */ 4075 SV_COW_NEXT_SV_SET(current, after); 4076 } 4077 } 4078 } 4079 #endif 4080 /* 4081 =for apidoc sv_force_normal_flags 4082 4083 Undo various types of fakery on an SV: if the PV is a shared string, make 4084 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to 4085 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when 4086 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set 4087 then a copy-on-write scalar drops its PV buffer (if any) and becomes 4088 SvPOK_off rather than making a copy. (Used where this scalar is about to be 4089 set to some other value.) In addition, the C<flags> parameter gets passed to 4090 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function 4091 with flags set to 0. 4092 4093 =cut 4094 */ 4095 4096 void 4097 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) 4098 { 4099 dVAR; 4100 #ifdef PERL_OLD_COPY_ON_WRITE 4101 if (SvREADONLY(sv)) { 4102 /* At this point I believe I should acquire a global SV mutex. */ 4103 if (SvFAKE(sv)) { 4104 const char * const pvx = SvPVX_const(sv); 4105 const STRLEN len = SvLEN(sv); 4106 const STRLEN cur = SvCUR(sv); 4107 /* next COW sv in the loop. If len is 0 then this is a shared-hash 4108 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as 4109 we'll fail an assertion. */ 4110 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; 4111 4112 if (DEBUG_C_TEST) { 4113 PerlIO_printf(Perl_debug_log, 4114 "Copy on write: Force normal %ld\n", 4115 (long) flags); 4116 sv_dump(sv); 4117 } 4118 SvFAKE_off(sv); 4119 SvREADONLY_off(sv); 4120 /* This SV doesn't own the buffer, so need to Newx() a new one: */ 4121 SvPV_set(sv, NULL); 4122 SvLEN_set(sv, 0); 4123 if (flags & SV_COW_DROP_PV) { 4124 /* OK, so we don't need to copy our buffer. */ 4125 SvPOK_off(sv); 4126 } else { 4127 SvGROW(sv, cur + 1); 4128 Move(pvx,SvPVX(sv),cur,char); 4129 SvCUR_set(sv, cur); 4130 *SvEND(sv) = '\0'; 4131 } 4132 if (len) { 4133 sv_release_COW(sv, pvx, next); 4134 } else { 4135 unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); 4136 } 4137 if (DEBUG_C_TEST) { 4138 sv_dump(sv); 4139 } 4140 } 4141 else if (IN_PERL_RUNTIME) 4142 Perl_croak(aTHX_ PL_no_modify); 4143 /* At this point I believe that I can drop the global SV mutex. */ 4144 } 4145 #else 4146 if (SvREADONLY(sv)) { 4147 if (SvFAKE(sv)) { 4148 const char * const pvx = SvPVX_const(sv); 4149 const STRLEN len = SvCUR(sv); 4150 SvFAKE_off(sv); 4151 SvREADONLY_off(sv); 4152 SvPV_set(sv, NULL); 4153 SvLEN_set(sv, 0); 4154 SvGROW(sv, len + 1); 4155 Move(pvx,SvPVX(sv),len,char); 4156 *SvEND(sv) = '\0'; 4157 unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); 4158 } 4159 else if (IN_PERL_RUNTIME) 4160 Perl_croak(aTHX_ PL_no_modify); 4161 } 4162 #endif 4163 if (SvROK(sv)) 4164 sv_unref_flags(sv, flags); 4165 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) 4166 sv_unglob(sv); 4167 } 4168 4169 /* 4170 =for apidoc sv_chop 4171 4172 Efficient removal of characters from the beginning of the string buffer. 4173 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside 4174 the string buffer. The C<ptr> becomes the first character of the adjusted 4175 string. Uses the "OOK hack". 4176 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer 4177 refer to the same chunk of data. 4178 4179 =cut 4180 */ 4181 4182 void 4183 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) 4184 { 4185 register STRLEN delta; 4186 if (!ptr || !SvPOKp(sv)) 4187 return; 4188 delta = ptr - SvPVX_const(sv); 4189 SV_CHECK_THINKFIRST(sv); 4190 if (SvTYPE(sv) < SVt_PVIV) 4191 sv_upgrade(sv,SVt_PVIV); 4192 4193 if (!SvOOK(sv)) { 4194 if (!SvLEN(sv)) { /* make copy of shared string */ 4195 const char *pvx = SvPVX_const(sv); 4196 const STRLEN len = SvCUR(sv); 4197 SvGROW(sv, len + 1); 4198 Move(pvx,SvPVX(sv),len,char); 4199 *SvEND(sv) = '\0'; 4200 } 4201 SvIV_set(sv, 0); 4202 /* Same SvOOK_on but SvOOK_on does a SvIOK_off 4203 and we do that anyway inside the SvNIOK_off 4204 */ 4205 SvFLAGS(sv) |= SVf_OOK; 4206 } 4207 SvNIOK_off(sv); 4208 SvLEN_set(sv, SvLEN(sv) - delta); 4209 SvCUR_set(sv, SvCUR(sv) - delta); 4210 SvPV_set(sv, SvPVX(sv) + delta); 4211 SvIV_set(sv, SvIVX(sv) + delta); 4212 } 4213 4214 /* 4215 =for apidoc sv_catpvn 4216 4217 Concatenates the string onto the end of the string which is in the SV. The 4218 C<len> indicates number of bytes to copy. If the SV has the UTF-8 4219 status set, then the bytes appended should be valid UTF-8. 4220 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>. 4221 4222 =for apidoc sv_catpvn_flags 4223 4224 Concatenates the string onto the end of the string which is in the SV. The 4225 C<len> indicates number of bytes to copy. If the SV has the UTF-8 4226 status set, then the bytes appended should be valid UTF-8. 4227 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if 4228 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented 4229 in terms of this function. 4230 4231 =cut 4232 */ 4233 4234 void 4235 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags) 4236 { 4237 dVAR; 4238 STRLEN dlen; 4239 const char * const dstr = SvPV_force_flags(dsv, dlen, flags); 4240 4241 SvGROW(dsv, dlen + slen + 1); 4242 if (sstr == dstr) 4243 sstr = SvPVX_const(dsv); 4244 Move(sstr, SvPVX(dsv) + dlen, slen, char); 4245 SvCUR_set(dsv, SvCUR(dsv) + slen); 4246 *SvEND(dsv) = '\0'; 4247 (void)SvPOK_only_UTF8(dsv); /* validate pointer */ 4248 SvTAINT(dsv); 4249 if (flags & SV_SMAGIC) 4250 SvSETMAGIC(dsv); 4251 } 4252 4253 /* 4254 =for apidoc sv_catsv 4255 4256 Concatenates the string from SV C<ssv> onto the end of the string in 4257 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but 4258 not 'set' magic. See C<sv_catsv_mg>. 4259 4260 =for apidoc sv_catsv_flags 4261 4262 Concatenates the string from SV C<ssv> onto the end of the string in 4263 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC> 4264 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv> 4265 and C<sv_catsv_nomg> are implemented in terms of this function. 4266 4267 =cut */ 4268 4269 void 4270 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) 4271 { 4272 dVAR; 4273 if (ssv) { 4274 STRLEN slen; 4275 const char *spv = SvPV_const(ssv, slen); 4276 if (spv) { 4277 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, 4278 gcc version 2.95.2 20000220 (Debian GNU/Linux) for 4279 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously 4280 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though 4281 dsv->sv_flags doesn't have that bit set. 4282 Andy Dougherty 12 Oct 2001 4283 */ 4284 const I32 sutf8 = DO_UTF8(ssv); 4285 I32 dutf8; 4286 4287 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) 4288 mg_get(dsv); 4289 dutf8 = DO_UTF8(dsv); 4290 4291 if (dutf8 != sutf8) { 4292 if (dutf8) { 4293 /* Not modifying source SV, so taking a temporary copy. */ 4294 SV* const csv = sv_2mortal(newSVpvn(spv, slen)); 4295 4296 sv_utf8_upgrade(csv); 4297 spv = SvPV_const(csv, slen); 4298 } 4299 else 4300 sv_utf8_upgrade_nomg(dsv); 4301 } 4302 sv_catpvn_nomg(dsv, spv, slen); 4303 } 4304 } 4305 if (flags & SV_SMAGIC) 4306 SvSETMAGIC(dsv); 4307 } 4308 4309 /* 4310 =for apidoc sv_catpv 4311 4312 Concatenates the string onto the end of the string which is in the SV. 4313 If the SV has the UTF-8 status set, then the bytes appended should be 4314 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>. 4315 4316 =cut */ 4317 4318 void 4319 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) 4320 { 4321 dVAR; 4322 register STRLEN len; 4323 STRLEN tlen; 4324 char *junk; 4325 4326 if (!ptr) 4327 return; 4328 junk = SvPV_force(sv, tlen); 4329 len = strlen(ptr); 4330 SvGROW(sv, tlen + len + 1); 4331 if (ptr == junk) 4332 ptr = SvPVX_const(sv); 4333 Move(ptr,SvPVX(sv)+tlen,len+1,char); 4334 SvCUR_set(sv, SvCUR(sv) + len); 4335 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4336 SvTAINT(sv); 4337 } 4338 4339 /* 4340 =for apidoc sv_catpv_mg 4341 4342 Like C<sv_catpv>, but also handles 'set' magic. 4343 4344 =cut 4345 */ 4346 4347 void 4348 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) 4349 { 4350 sv_catpv(sv,ptr); 4351 SvSETMAGIC(sv); 4352 } 4353 4354 /* 4355 =for apidoc newSV 4356 4357 Creates a new SV. A non-zero C<len> parameter indicates the number of 4358 bytes of preallocated string space the SV should have. An extra byte for a 4359 trailing NUL is also reserved. (SvPOK is not set for the SV even if string 4360 space is allocated.) The reference count for the new SV is set to 1. 4361 4362 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first 4363 parameter, I<x>, a debug aid which allowed callers to identify themselves. 4364 This aid has been superseded by a new build option, PERL_MEM_LOG (see 4365 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS 4366 modules supporting older perls. 4367 4368 =cut 4369 */ 4370 4371 SV * 4372 Perl_newSV(pTHX_ STRLEN len) 4373 { 4374 dVAR; 4375 register SV *sv; 4376 4377 new_SV(sv); 4378 if (len) { 4379 sv_upgrade(sv, SVt_PV); 4380 SvGROW(sv, len + 1); 4381 } 4382 return sv; 4383 } 4384 /* 4385 =for apidoc sv_magicext 4386 4387 Adds magic to an SV, upgrading it if necessary. Applies the 4388 supplied vtable and returns a pointer to the magic added. 4389 4390 Note that C<sv_magicext> will allow things that C<sv_magic> will not. 4391 In particular, you can add magic to SvREADONLY SVs, and add more than 4392 one instance of the same 'how'. 4393 4394 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is 4395 stored, if C<namlen> is zero then C<name> is stored as-is and - as another 4396 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed 4397 to contain an C<SV*> and is stored as-is with its REFCNT incremented. 4398 4399 (This is now used as a subroutine by C<sv_magic>.) 4400 4401 =cut 4402 */ 4403 MAGIC * 4404 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, 4405 const char* name, I32 namlen) 4406 { 4407 dVAR; 4408 MAGIC* mg; 4409 4410 SvUPGRADE(sv, SVt_PVMG); 4411 Newxz(mg, 1, MAGIC); 4412 mg->mg_moremagic = SvMAGIC(sv); 4413 SvMAGIC_set(sv, mg); 4414 4415 /* Sometimes a magic contains a reference loop, where the sv and 4416 object refer to each other. To prevent a reference loop that 4417 would prevent such objects being freed, we look for such loops 4418 and if we find one we avoid incrementing the object refcount. 4419 4420 Note we cannot do this to avoid self-tie loops as intervening RV must 4421 have its REFCNT incremented to keep it in existence. 4422 4423 */ 4424 if (!obj || obj == sv || 4425 how == PERL_MAGIC_arylen || 4426 how == PERL_MAGIC_qr || 4427 how == PERL_MAGIC_symtab || 4428 (SvTYPE(obj) == SVt_PVGV && 4429 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || 4430 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || 4431 GvFORM(obj) == (CV*)sv))) 4432 { 4433 mg->mg_obj = obj; 4434 } 4435 else { 4436 mg->mg_obj = SvREFCNT_inc_simple(obj); 4437 mg->mg_flags |= MGf_REFCOUNTED; 4438 } 4439 4440 /* Normal self-ties simply pass a null object, and instead of 4441 using mg_obj directly, use the SvTIED_obj macro to produce a 4442 new RV as needed. For glob "self-ties", we are tieing the PVIO 4443 with an RV obj pointing to the glob containing the PVIO. In 4444 this case, to avoid a reference loop, we need to weaken the 4445 reference. 4446 */ 4447 4448 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && 4449 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv) 4450 { 4451 sv_rvweaken(obj); 4452 } 4453 4454 mg->mg_type = how; 4455 mg->mg_len = namlen; 4456 if (name) { 4457 if (namlen > 0) 4458 mg->mg_ptr = savepvn(name, namlen); 4459 else if (namlen == HEf_SVKEY) 4460 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name); 4461 else 4462 mg->mg_ptr = (char *) name; 4463 } 4464 mg->mg_virtual = (MGVTBL *) vtable; 4465 4466 mg_magical(sv); 4467 if (SvGMAGICAL(sv)) 4468 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); 4469 return mg; 4470 } 4471 4472 /* 4473 =for apidoc sv_magic 4474 4475 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary, 4476 then adds a new magic item of type C<how> to the head of the magic list. 4477 4478 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the 4479 handling of the C<name> and C<namlen> arguments. 4480 4481 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also 4482 to add more than one instance of the same 'how'. 4483 4484 =cut 4485 */ 4486 4487 void 4488 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) 4489 { 4490 dVAR; 4491 const MGVTBL *vtable; 4492 MAGIC* mg; 4493 4494 #ifdef PERL_OLD_COPY_ON_WRITE 4495 if (SvIsCOW(sv)) 4496 sv_force_normal_flags(sv, 0); 4497 #endif 4498 if (SvREADONLY(sv)) { 4499 if ( 4500 /* its okay to attach magic to shared strings; the subsequent 4501 * upgrade to PVMG will unshare the string */ 4502 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG) 4503 4504 && IN_PERL_RUNTIME 4505 && how != PERL_MAGIC_regex_global 4506 && how != PERL_MAGIC_bm 4507 && how != PERL_MAGIC_fm 4508 && how != PERL_MAGIC_sv 4509 && how != PERL_MAGIC_backref 4510 ) 4511 { 4512 Perl_croak(aTHX_ PL_no_modify); 4513 } 4514 } 4515 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { 4516 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { 4517 /* sv_magic() refuses to add a magic of the same 'how' as an 4518 existing one 4519 */ 4520 if (how == PERL_MAGIC_taint) { 4521 mg->mg_len |= 1; 4522 /* Any scalar which already had taint magic on which someone 4523 (erroneously?) did SvIOK_on() or similar will now be 4524 incorrectly sporting public "OK" flags. */ 4525 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); 4526 } 4527 return; 4528 } 4529 } 4530 4531 switch (how) { 4532 case PERL_MAGIC_sv: 4533 vtable = &PL_vtbl_sv; 4534 break; 4535 case PERL_MAGIC_overload: 4536 vtable = &PL_vtbl_amagic; 4537 break; 4538 case PERL_MAGIC_overload_elem: 4539 vtable = &PL_vtbl_amagicelem; 4540 break; 4541 case PERL_MAGIC_overload_table: 4542 vtable = &PL_vtbl_ovrld; 4543 break; 4544 case PERL_MAGIC_bm: 4545 vtable = &PL_vtbl_bm; 4546 break; 4547 case PERL_MAGIC_regdata: 4548 vtable = &PL_vtbl_regdata; 4549 break; 4550 case PERL_MAGIC_regdatum: 4551 vtable = &PL_vtbl_regdatum; 4552 break; 4553 case PERL_MAGIC_env: 4554 vtable = &PL_vtbl_env; 4555 break; 4556 case PERL_MAGIC_fm: 4557 vtable = &PL_vtbl_fm; 4558 break; 4559 case PERL_MAGIC_envelem: 4560 vtable = &PL_vtbl_envelem; 4561 break; 4562 case PERL_MAGIC_regex_global: 4563 vtable = &PL_vtbl_mglob; 4564 break; 4565 case PERL_MAGIC_isa: 4566 vtable = &PL_vtbl_isa; 4567 break; 4568 case PERL_MAGIC_isaelem: 4569 vtable = &PL_vtbl_isaelem; 4570 break; 4571 case PERL_MAGIC_nkeys: 4572 vtable = &PL_vtbl_nkeys; 4573 break; 4574 case PERL_MAGIC_dbfile: 4575 vtable = NULL; 4576 break; 4577 case PERL_MAGIC_dbline: 4578 vtable = &PL_vtbl_dbline; 4579 break; 4580 #ifdef USE_LOCALE_COLLATE 4581 case PERL_MAGIC_collxfrm: 4582 vtable = &PL_vtbl_collxfrm; 4583 break; 4584 #endif /* USE_LOCALE_COLLATE */ 4585 case PERL_MAGIC_tied: 4586 vtable = &PL_vtbl_pack; 4587 break; 4588 case PERL_MAGIC_tiedelem: 4589 case PERL_MAGIC_tiedscalar: 4590 vtable = &PL_vtbl_packelem; 4591 break; 4592 case PERL_MAGIC_qr: 4593 vtable = &PL_vtbl_regexp; 4594 break; 4595 case PERL_MAGIC_hints: 4596 /* As this vtable is all NULL, we can reuse it. */ 4597 case PERL_MAGIC_sig: 4598 vtable = &PL_vtbl_sig; 4599 break; 4600 case PERL_MAGIC_sigelem: 4601 vtable = &PL_vtbl_sigelem; 4602 break; 4603 case PERL_MAGIC_taint: 4604 vtable = &PL_vtbl_taint; 4605 break; 4606 case PERL_MAGIC_uvar: 4607 vtable = &PL_vtbl_uvar; 4608 break; 4609 case PERL_MAGIC_vec: 4610 vtable = &PL_vtbl_vec; 4611 break; 4612 case PERL_MAGIC_arylen_p: 4613 case PERL_MAGIC_rhash: 4614 case PERL_MAGIC_symtab: 4615 case PERL_MAGIC_vstring: 4616 vtable = NULL; 4617 break; 4618 case PERL_MAGIC_utf8: 4619 vtable = &PL_vtbl_utf8; 4620 break; 4621 case PERL_MAGIC_substr: 4622 vtable = &PL_vtbl_substr; 4623 break; 4624 case PERL_MAGIC_defelem: 4625 vtable = &PL_vtbl_defelem; 4626 break; 4627 case PERL_MAGIC_arylen: 4628 vtable = &PL_vtbl_arylen; 4629 break; 4630 case PERL_MAGIC_pos: 4631 vtable = &PL_vtbl_pos; 4632 break; 4633 case PERL_MAGIC_backref: 4634 vtable = &PL_vtbl_backref; 4635 break; 4636 case PERL_MAGIC_hintselem: 4637 vtable = &PL_vtbl_hintselem; 4638 break; 4639 case PERL_MAGIC_ext: 4640 /* Reserved for use by extensions not perl internals. */ 4641 /* Useful for attaching extension internal data to perl vars. */ 4642 /* Note that multiple extensions may clash if magical scalars */ 4643 /* etc holding private data from one are passed to another. */ 4644 vtable = NULL; 4645 break; 4646 default: 4647 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); 4648 } 4649 4650 /* Rest of work is done else where */ 4651 mg = sv_magicext(sv,obj,how,vtable,name,namlen); 4652 4653 switch (how) { 4654 case PERL_MAGIC_taint: 4655 mg->mg_len = 1; 4656 break; 4657 case PERL_MAGIC_ext: 4658 case PERL_MAGIC_dbfile: 4659 SvRMAGICAL_on(sv); 4660 break; 4661 } 4662 } 4663 4664 /* 4665 =for apidoc sv_unmagic 4666 4667 Removes all magic of type C<type> from an SV. 4668 4669 =cut 4670 */ 4671 4672 int 4673 Perl_sv_unmagic(pTHX_ SV *sv, int type) 4674 { 4675 MAGIC* mg; 4676 MAGIC** mgp; 4677 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) 4678 return 0; 4679 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); 4680 for (mg = *mgp; mg; mg = *mgp) { 4681 if (mg->mg_type == type) { 4682 const MGVTBL* const vtbl = mg->mg_virtual; 4683 *mgp = mg->mg_moremagic; 4684 if (vtbl && vtbl->svt_free) 4685 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); 4686 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 4687 if (mg->mg_len > 0) 4688 Safefree(mg->mg_ptr); 4689 else if (mg->mg_len == HEf_SVKEY) 4690 SvREFCNT_dec((SV*)mg->mg_ptr); 4691 else if (mg->mg_type == PERL_MAGIC_utf8) 4692 Safefree(mg->mg_ptr); 4693 } 4694 if (mg->mg_flags & MGf_REFCOUNTED) 4695 SvREFCNT_dec(mg->mg_obj); 4696 Safefree(mg); 4697 } 4698 else 4699 mgp = &mg->mg_moremagic; 4700 } 4701 if (!SvMAGIC(sv)) { 4702 SvMAGICAL_off(sv); 4703 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 4704 SvMAGIC_set(sv, NULL); 4705 } 4706 4707 return 0; 4708 } 4709 4710 /* 4711 =for apidoc sv_rvweaken 4712 4713 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the 4714 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and 4715 push a back-reference to this RV onto the array of backreferences 4716 associated with that magic. If the RV is magical, set magic will be 4717 called after the RV is cleared. 4718 4719 =cut 4720 */ 4721 4722 SV * 4723 Perl_sv_rvweaken(pTHX_ SV *sv) 4724 { 4725 SV *tsv; 4726 if (!SvOK(sv)) /* let undefs pass */ 4727 return sv; 4728 if (!SvROK(sv)) 4729 Perl_croak(aTHX_ "Can't weaken a nonreference"); 4730 else if (SvWEAKREF(sv)) { 4731 if (ckWARN(WARN_MISC)) 4732 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); 4733 return sv; 4734 } 4735 tsv = SvRV(sv); 4736 Perl_sv_add_backref(aTHX_ tsv, sv); 4737 SvWEAKREF_on(sv); 4738 SvREFCNT_dec(tsv); 4739 return sv; 4740 } 4741 4742 /* Give tsv backref magic if it hasn't already got it, then push a 4743 * back-reference to sv onto the array associated with the backref magic. 4744 */ 4745 4746 void 4747 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) 4748 { 4749 dVAR; 4750 AV *av; 4751 4752 if (SvTYPE(tsv) == SVt_PVHV) { 4753 AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv); 4754 4755 av = *avp; 4756 if (!av) { 4757 /* There is no AV in the offical place - try a fixup. */ 4758 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref); 4759 4760 if (mg) { 4761 /* Aha. They've got it stowed in magic. Bring it back. */ 4762 av = (AV*)mg->mg_obj; 4763 /* Stop mg_free decreasing the refernce count. */ 4764 mg->mg_obj = NULL; 4765 /* Stop mg_free even calling the destructor, given that 4766 there's no AV to free up. */ 4767 mg->mg_virtual = 0; 4768 sv_unmagic(tsv, PERL_MAGIC_backref); 4769 } else { 4770 av = newAV(); 4771 AvREAL_off(av); 4772 SvREFCNT_inc_simple_void(av); 4773 } 4774 *avp = av; 4775 } 4776 } else { 4777 const MAGIC *const mg 4778 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; 4779 if (mg) 4780 av = (AV*)mg->mg_obj; 4781 else { 4782 av = newAV(); 4783 AvREAL_off(av); 4784 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); 4785 /* av now has a refcnt of 2, which avoids it getting freed 4786 * before us during global cleanup. The extra ref is removed 4787 * by magic_killbackrefs() when tsv is being freed */ 4788 } 4789 } 4790 if (AvFILLp(av) >= AvMAX(av)) { 4791 av_extend(av, AvFILLp(av)+1); 4792 } 4793 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ 4794 } 4795 4796 /* delete a back-reference to ourselves from the backref magic associated 4797 * with the SV we point to. 4798 */ 4799 4800 STATIC void 4801 S_sv_del_backref(pTHX_ SV *tsv, SV *sv) 4802 { 4803 dVAR; 4804 AV *av = NULL; 4805 SV **svp; 4806 I32 i; 4807 4808 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) { 4809 av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv); 4810 /* We mustn't attempt to "fix up" the hash here by moving the 4811 backreference array back to the hv_aux structure, as that is stored 4812 in the main HvARRAY(), and hfreentries assumes that no-one 4813 reallocates HvARRAY() while it is running. */ 4814 } 4815 if (!av) { 4816 const MAGIC *const mg 4817 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; 4818 if (mg) 4819 av = (AV *)mg->mg_obj; 4820 } 4821 if (!av) { 4822 if (PL_in_clean_all) 4823 return; 4824 Perl_croak(aTHX_ "panic: del_backref"); 4825 } 4826 4827 if (SvIS_FREED(av)) 4828 return; 4829 4830 svp = AvARRAY(av); 4831 /* We shouldn't be in here more than once, but for paranoia reasons lets 4832 not assume this. */ 4833 for (i = AvFILLp(av); i >= 0; i--) { 4834 if (svp[i] == sv) { 4835 const SSize_t fill = AvFILLp(av); 4836 if (i != fill) { 4837 /* We weren't the last entry. 4838 An unordered list has this property that you can take the 4839 last element off the end to fill the hole, and it's still 4840 an unordered list :-) 4841 */ 4842 svp[i] = svp[fill]; 4843 } 4844 svp[fill] = NULL; 4845 AvFILLp(av) = fill - 1; 4846 } 4847 } 4848 } 4849 4850 int 4851 Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) 4852 { 4853 SV **svp = AvARRAY(av); 4854 4855 PERL_UNUSED_ARG(sv); 4856 4857 /* Not sure why the av can get freed ahead of its sv, but somehow it does 4858 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */ 4859 if (svp && !SvIS_FREED(av)) { 4860 SV *const *const last = svp + AvFILLp(av); 4861 4862 while (svp <= last) { 4863 if (*svp) { 4864 SV *const referrer = *svp; 4865 if (SvWEAKREF(referrer)) { 4866 /* XXX Should we check that it hasn't changed? */ 4867 SvRV_set(referrer, 0); 4868 SvOK_off(referrer); 4869 SvWEAKREF_off(referrer); 4870 SvSETMAGIC(referrer); 4871 } else if (SvTYPE(referrer) == SVt_PVGV || 4872 SvTYPE(referrer) == SVt_PVLV) { 4873 /* You lookin' at me? */ 4874 assert(GvSTASH(referrer)); 4875 assert(GvSTASH(referrer) == (HV*)sv); 4876 GvSTASH(referrer) = 0; 4877 } else { 4878 Perl_croak(aTHX_ 4879 "panic: magic_killbackrefs (flags=%"UVxf")", 4880 (UV)SvFLAGS(referrer)); 4881 } 4882 4883 *svp = NULL; 4884 } 4885 svp++; 4886 } 4887 } 4888 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ 4889 return 0; 4890 } 4891 4892 /* 4893 =for apidoc sv_insert 4894 4895 Inserts a string at the specified offset/length within the SV. Similar to 4896 the Perl substr() function. 4897 4898 =cut 4899 */ 4900 4901 void 4902 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen) 4903 { 4904 dVAR; 4905 register char *big; 4906 register char *mid; 4907 register char *midend; 4908 register char *bigend; 4909 register I32 i; 4910 STRLEN curlen; 4911 4912 4913 if (!bigstr) 4914 Perl_croak(aTHX_ "Can't modify non-existent substring"); 4915 SvPV_force(bigstr, curlen); 4916 (void)SvPOK_only_UTF8(bigstr); 4917 if (offset + len > curlen) { 4918 SvGROW(bigstr, offset+len+1); 4919 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); 4920 SvCUR_set(bigstr, offset+len); 4921 } 4922 4923 SvTAINT(bigstr); 4924 i = littlelen - len; 4925 if (i > 0) { /* string might grow */ 4926 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); 4927 mid = big + offset + len; 4928 midend = bigend = big + SvCUR(bigstr); 4929 bigend += i; 4930 *bigend = '\0'; 4931 while (midend > mid) /* shove everything down */ 4932 *--bigend = *--midend; 4933 Move(little,big+offset,littlelen,char); 4934 SvCUR_set(bigstr, SvCUR(bigstr) + i); 4935 SvSETMAGIC(bigstr); 4936 return; 4937 } 4938 else if (i == 0) { 4939 Move(little,SvPVX(bigstr)+offset,len,char); 4940 SvSETMAGIC(bigstr); 4941 return; 4942 } 4943 4944 big = SvPVX(bigstr); 4945 mid = big + offset; 4946 midend = mid + len; 4947 bigend = big + SvCUR(bigstr); 4948 4949 if (midend > bigend) 4950 Perl_croak(aTHX_ "panic: sv_insert"); 4951 4952 if (mid - big > bigend - midend) { /* faster to shorten from end */ 4953 if (littlelen) { 4954 Move(little, mid, littlelen,char); 4955 mid += littlelen; 4956 } 4957 i = bigend - midend; 4958 if (i > 0) { 4959 Move(midend, mid, i,char); 4960 mid += i; 4961 } 4962 *mid = '\0'; 4963 SvCUR_set(bigstr, mid - big); 4964 } 4965 else if ((i = mid - big)) { /* faster from front */ 4966 midend -= littlelen; 4967 mid = midend; 4968 sv_chop(bigstr,midend-i); 4969 big += i; 4970 while (i--) 4971 *--midend = *--big; 4972 if (littlelen) 4973 Move(little, mid, littlelen,char); 4974 } 4975 else if (littlelen) { 4976 midend -= littlelen; 4977 sv_chop(bigstr,midend); 4978 Move(little,midend,littlelen,char); 4979 } 4980 else { 4981 sv_chop(bigstr,midend); 4982 } 4983 SvSETMAGIC(bigstr); 4984 } 4985 4986 /* 4987 =for apidoc sv_replace 4988 4989 Make the first argument a copy of the second, then delete the original. 4990 The target SV physically takes over ownership of the body of the source SV 4991 and inherits its flags; however, the target keeps any magic it owns, 4992 and any magic in the source is discarded. 4993 Note that this is a rather specialist SV copying operation; most of the 4994 time you'll want to use C<sv_setsv> or one of its many macro front-ends. 4995 4996 =cut 4997 */ 4998 4999 void 5000 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) 5001 { 5002 dVAR; 5003 const U32 refcnt = SvREFCNT(sv); 5004 SV_CHECK_THINKFIRST_COW_DROP(sv); 5005 if (SvREFCNT(nsv) != 1) { 5006 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%" 5007 UVuf " != 1)", (UV) SvREFCNT(nsv)); 5008 } 5009 if (SvMAGICAL(sv)) { 5010 if (SvMAGICAL(nsv)) 5011 mg_free(nsv); 5012 else 5013 sv_upgrade(nsv, SVt_PVMG); 5014 SvMAGIC_set(nsv, SvMAGIC(sv)); 5015 SvFLAGS(nsv) |= SvMAGICAL(sv); 5016 SvMAGICAL_off(sv); 5017 SvMAGIC_set(sv, NULL); 5018 } 5019 SvREFCNT(sv) = 0; 5020 sv_clear(sv); 5021 assert(!SvREFCNT(sv)); 5022 #ifdef DEBUG_LEAKING_SCALARS 5023 sv->sv_flags = nsv->sv_flags; 5024 sv->sv_any = nsv->sv_any; 5025 sv->sv_refcnt = nsv->sv_refcnt; 5026 sv->sv_u = nsv->sv_u; 5027 #else 5028 StructCopy(nsv,sv,SV); 5029 #endif 5030 /* Currently could join these into one piece of pointer arithmetic, but 5031 it would be unclear. */ 5032 if(SvTYPE(sv) == SVt_IV) 5033 SvANY(sv) 5034 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 5035 else if (SvTYPE(sv) == SVt_RV) { 5036 SvANY(sv) = &sv->sv_u.svu_rv; 5037 } 5038 5039 5040 #ifdef PERL_OLD_COPY_ON_WRITE 5041 if (SvIsCOW_normal(nsv)) { 5042 /* We need to follow the pointers around the loop to make the 5043 previous SV point to sv, rather than nsv. */ 5044 SV *next; 5045 SV *current = nsv; 5046 while ((next = SV_COW_NEXT_SV(current)) != nsv) { 5047 assert(next); 5048 current = next; 5049 assert(SvPVX_const(current) == SvPVX_const(nsv)); 5050 } 5051 /* Make the SV before us point to the SV after us. */ 5052 if (DEBUG_C_TEST) { 5053 PerlIO_printf(Perl_debug_log, "previous is\n"); 5054 sv_dump(current); 5055 PerlIO_printf(Perl_debug_log, 5056 "move it from 0x%"UVxf" to 0x%"UVxf"\n", 5057 (UV) SV_COW_NEXT_SV(current), (UV) sv); 5058 } 5059 SV_COW_NEXT_SV_SET(current, sv); 5060 } 5061 #endif 5062 SvREFCNT(sv) = refcnt; 5063 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ 5064 SvREFCNT(nsv) = 0; 5065 del_SV(nsv); 5066 } 5067 5068 /* 5069 =for apidoc sv_clear 5070 5071 Clear an SV: call any destructors, free up any memory used by the body, 5072 and free the body itself. The SV's head is I<not> freed, although 5073 its type is set to all 1's so that it won't inadvertently be assumed 5074 to be live during global destruction etc. 5075 This function should only be called when REFCNT is zero. Most of the time 5076 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>) 5077 instead. 5078 5079 =cut 5080 */ 5081 5082 void 5083 Perl_sv_clear(pTHX_ register SV *sv) 5084 { 5085 dVAR; 5086 const U32 type = SvTYPE(sv); 5087 const struct body_details *const sv_type_details 5088 = bodies_by_type + type; 5089 HV *stash; 5090 5091 assert(sv); 5092 assert(SvREFCNT(sv) == 0); 5093 5094 if (type <= SVt_IV) { 5095 /* See the comment in sv.h about the collusion between this early 5096 return and the overloading of the NULL and IV slots in the size 5097 table. */ 5098 return; 5099 } 5100 5101 if (SvOBJECT(sv)) { 5102 if (PL_defstash && /* Still have a symbol table? */ 5103 SvDESTROYABLE(sv)) 5104 { 5105 dSP; 5106 HV* stash; 5107 do { 5108 CV* destructor; 5109 stash = SvSTASH(sv); 5110 destructor = StashHANDLER(stash,DESTROY); 5111 if (destructor) { 5112 SV* const tmpref = newRV(sv); 5113 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ 5114 ENTER; 5115 PUSHSTACKi(PERLSI_DESTROY); 5116 EXTEND(SP, 2); 5117 PUSHMARK(SP); 5118 PUSHs(tmpref); 5119 PUTBACK; 5120 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); 5121 5122 5123 POPSTACK; 5124 SPAGAIN; 5125 LEAVE; 5126 if(SvREFCNT(tmpref) < 2) { 5127 /* tmpref is not kept alive! */ 5128 SvREFCNT(sv)--; 5129 SvRV_set(tmpref, NULL); 5130 SvROK_off(tmpref); 5131 } 5132 SvREFCNT_dec(tmpref); 5133 } 5134 } while (SvOBJECT(sv) && SvSTASH(sv) != stash); 5135 5136 5137 if (SvREFCNT(sv)) { 5138 if (PL_in_clean_objs) 5139 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", 5140 HvNAME_get(stash)); 5141 /* DESTROY gave object new lease on life */ 5142 return; 5143 } 5144 } 5145 5146 if (SvOBJECT(sv)) { 5147 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ 5148 SvOBJECT_off(sv); /* Curse the object. */ 5149 if (type != SVt_PVIO) 5150 --PL_sv_objcount; /* XXX Might want something more general */ 5151 } 5152 } 5153 if (type >= SVt_PVMG) { 5154 if (type == SVt_PVMG && SvPAD_OUR(sv)) { 5155 SvREFCNT_dec(SvOURSTASH(sv)); 5156 } else if (SvMAGIC(sv)) 5157 mg_free(sv); 5158 if (type == SVt_PVMG && SvPAD_TYPED(sv)) 5159 SvREFCNT_dec(SvSTASH(sv)); 5160 } 5161 switch (type) { 5162 /* case SVt_BIND: */ 5163 case SVt_PVIO: 5164 if (IoIFP(sv) && 5165 IoIFP(sv) != PerlIO_stdin() && 5166 IoIFP(sv) != PerlIO_stdout() && 5167 IoIFP(sv) != PerlIO_stderr()) 5168 { 5169 io_close((IO*)sv, FALSE); 5170 } 5171 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) 5172 PerlDir_close(IoDIRP(sv)); 5173 IoDIRP(sv) = (DIR*)NULL; 5174 Safefree(IoTOP_NAME(sv)); 5175 Safefree(IoFMT_NAME(sv)); 5176 Safefree(IoBOTTOM_NAME(sv)); 5177 goto freescalar; 5178 case SVt_PVCV: 5179 case SVt_PVFM: 5180 cv_undef((CV*)sv); 5181 goto freescalar; 5182 case SVt_PVHV: 5183 Perl_hv_kill_backrefs(aTHX_ (HV*)sv); 5184 hv_undef((HV*)sv); 5185 break; 5186 case SVt_PVAV: 5187 if (PL_comppad == (AV*)sv) { 5188 PL_comppad = NULL; 5189 PL_curpad = NULL; 5190 } 5191 av_undef((AV*)sv); 5192 break; 5193 case SVt_PVLV: 5194 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ 5195 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); 5196 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; 5197 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); 5198 } 5199 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ 5200 SvREFCNT_dec(LvTARG(sv)); 5201 case SVt_PVGV: 5202 if (isGV_with_GP(sv)) { 5203 if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) 5204 mro_method_changed_in(stash); 5205 gp_free((GV*)sv); 5206 if (GvNAME_HEK(sv)) 5207 unshare_hek(GvNAME_HEK(sv)); 5208 /* If we're in a stash, we don't own a reference to it. However it does 5209 have a back reference to us, which needs to be cleared. */ 5210 if (!SvVALID(sv) && (stash = GvSTASH(sv))) 5211 sv_del_backref((SV*)stash, sv); 5212 } 5213 /* FIXME. There are probably more unreferenced pointers to SVs in the 5214 interpreter struct that we should check and tidy in a similar 5215 fashion to this: */ 5216 if ((GV*)sv == PL_last_in_gv) 5217 PL_last_in_gv = NULL; 5218 case SVt_PVMG: 5219 case SVt_PVNV: 5220 case SVt_PVIV: 5221 freescalar: 5222 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ 5223 if (SvOOK(sv)) { 5224 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); 5225 /* Don't even bother with turning off the OOK flag. */ 5226 } 5227 case SVt_PV: 5228 case SVt_RV: 5229 if (SvROK(sv)) { 5230 SV * const target = SvRV(sv); 5231 if (SvWEAKREF(sv)) 5232 sv_del_backref(target, sv); 5233 else 5234 SvREFCNT_dec(target); 5235 } 5236 #ifdef PERL_OLD_COPY_ON_WRITE 5237 else if (SvPVX_const(sv)) { 5238 if (SvIsCOW(sv)) { 5239 /* I believe I need to grab the global SV mutex here and 5240 then recheck the COW status. */ 5241 if (DEBUG_C_TEST) { 5242 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); 5243 sv_dump(sv); 5244 } 5245 if (SvLEN(sv)) { 5246 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); 5247 } else { 5248 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); 5249 } 5250 5251 /* And drop it here. */ 5252 SvFAKE_off(sv); 5253 } else if (SvLEN(sv)) { 5254 Safefree(SvPVX_const(sv)); 5255 } 5256 } 5257 #else 5258 else if (SvPVX_const(sv) && SvLEN(sv)) 5259 Safefree(SvPVX_mutable(sv)); 5260 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { 5261 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); 5262 SvFAKE_off(sv); 5263 } 5264 #endif 5265 break; 5266 case SVt_NV: 5267 break; 5268 } 5269 5270 SvFLAGS(sv) &= SVf_BREAK; 5271 SvFLAGS(sv) |= SVTYPEMASK; 5272 5273 if (sv_type_details->arena) { 5274 del_body(((char *)SvANY(sv) + sv_type_details->offset), 5275 &PL_body_roots[type]); 5276 } 5277 else if (sv_type_details->body_size) { 5278 my_safefree(SvANY(sv)); 5279 } 5280 } 5281 5282 /* 5283 =for apidoc sv_newref 5284 5285 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper 5286 instead. 5287 5288 =cut 5289 */ 5290 5291 SV * 5292 Perl_sv_newref(pTHX_ SV *sv) 5293 { 5294 PERL_UNUSED_CONTEXT; 5295 if (sv) 5296 (SvREFCNT(sv))++; 5297 return sv; 5298 } 5299 5300 /* 5301 =for apidoc sv_free 5302 5303 Decrement an SV's reference count, and if it drops to zero, call 5304 C<sv_clear> to invoke destructors and free up any memory used by 5305 the body; finally, deallocate the SV's head itself. 5306 Normally called via a wrapper macro C<SvREFCNT_dec>. 5307 5308 =cut 5309 */ 5310 5311 void 5312 Perl_sv_free(pTHX_ SV *sv) 5313 { 5314 dVAR; 5315 if (!sv) 5316 return; 5317 if (SvREFCNT(sv) == 0) { 5318 if (SvFLAGS(sv) & SVf_BREAK) 5319 /* this SV's refcnt has been artificially decremented to 5320 * trigger cleanup */ 5321 return; 5322 if (PL_in_clean_all) /* All is fair */ 5323 return; 5324 if (SvREADONLY(sv) && SvIMMORTAL(sv)) { 5325 /* make sure SvREFCNT(sv)==0 happens very seldom */ 5326 SvREFCNT(sv) = (~(U32)0)/2; 5327 return; 5328 } 5329 if (ckWARN_d(WARN_INTERNAL)) { 5330 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 5331 "Attempt to free unreferenced scalar: SV 0x%"UVxf 5332 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 5333 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 5334 Perl_dump_sv_child(aTHX_ sv); 5335 #else 5336 #ifdef DEBUG_LEAKING_SCALARS 5337 sv_dump(sv); 5338 #endif 5339 #endif 5340 } 5341 return; 5342 } 5343 if (--(SvREFCNT(sv)) > 0) 5344 return; 5345 Perl_sv_free2(aTHX_ sv); 5346 } 5347 5348 void 5349 Perl_sv_free2(pTHX_ SV *sv) 5350 { 5351 dVAR; 5352 #ifdef DEBUGGING 5353 if (SvTEMP(sv)) { 5354 if (ckWARN_d(WARN_DEBUGGING)) 5355 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), 5356 "Attempt to free temp prematurely: SV 0x%"UVxf 5357 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 5358 return; 5359 } 5360 #endif 5361 if (SvREADONLY(sv) && SvIMMORTAL(sv)) { 5362 /* make sure SvREFCNT(sv)==0 happens very seldom */ 5363 SvREFCNT(sv) = (~(U32)0)/2; 5364 return; 5365 } 5366 sv_clear(sv); 5367 if (! SvREFCNT(sv)) 5368 del_SV(sv); 5369 } 5370 5371 /* 5372 =for apidoc sv_len 5373 5374 Returns the length of the string in the SV. Handles magic and type 5375 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot. 5376 5377 =cut 5378 */ 5379 5380 STRLEN 5381 Perl_sv_len(pTHX_ register SV *sv) 5382 { 5383 STRLEN len; 5384 5385 if (!sv) 5386 return 0; 5387 5388 if (SvGMAGICAL(sv)) 5389 len = mg_length(sv); 5390 else 5391 (void)SvPV_const(sv, len); 5392 return len; 5393 } 5394 5395 /* 5396 =for apidoc sv_len_utf8 5397 5398 Returns the number of characters in the string in an SV, counting wide 5399 UTF-8 bytes as a single character. Handles magic and type coercion. 5400 5401 =cut 5402 */ 5403 5404 /* 5405 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the 5406 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below. 5407 * (Note that the mg_len is not the length of the mg_ptr field. 5408 * This allows the cache to store the character length of the string without 5409 * needing to malloc() extra storage to attach to the mg_ptr.) 5410 * 5411 */ 5412 5413 STRLEN 5414 Perl_sv_len_utf8(pTHX_ register SV *sv) 5415 { 5416 if (!sv) 5417 return 0; 5418 5419 if (SvGMAGICAL(sv)) 5420 return mg_length(sv); 5421 else 5422 { 5423 STRLEN len; 5424 const U8 *s = (U8*)SvPV_const(sv, len); 5425 5426 if (PL_utf8cache) { 5427 STRLEN ulen; 5428 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 5429 5430 if (mg && mg->mg_len != -1) { 5431 ulen = mg->mg_len; 5432 if (PL_utf8cache < 0) { 5433 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); 5434 if (real != ulen) { 5435 /* Need to turn the assertions off otherwise we may 5436 recurse infinitely while printing error messages. 5437 */ 5438 SAVEI8(PL_utf8cache); 5439 PL_utf8cache = 0; 5440 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf 5441 " real %"UVuf" for %"SVf, 5442 (UV) ulen, (UV) real, SVfARG(sv)); 5443 } 5444 } 5445 } 5446 else { 5447 ulen = Perl_utf8_length(aTHX_ s, s + len); 5448 if (!SvREADONLY(sv)) { 5449 if (!mg) { 5450 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8, 5451 &PL_vtbl_utf8, 0, 0); 5452 } 5453 assert(mg); 5454 mg->mg_len = ulen; 5455 } 5456 } 5457 return ulen; 5458 } 5459 return Perl_utf8_length(aTHX_ s, s + len); 5460 } 5461 } 5462 5463 /* Walk forwards to find the byte corresponding to the passed in UTF-8 5464 offset. */ 5465 static STRLEN 5466 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, 5467 STRLEN uoffset) 5468 { 5469 const U8 *s = start; 5470 5471 while (s < send && uoffset--) 5472 s += UTF8SKIP(s); 5473 if (s > send) { 5474 /* This is the existing behaviour. Possibly it should be a croak, as 5475 it's actually a bounds error */ 5476 s = send; 5477 } 5478 return s - start; 5479 } 5480 5481 /* Given the length of the string in both bytes and UTF-8 characters, decide 5482 whether to walk forwards or backwards to find the byte corresponding to 5483 the passed in UTF-8 offset. */ 5484 static STRLEN 5485 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, 5486 STRLEN uoffset, STRLEN uend) 5487 { 5488 STRLEN backw = uend - uoffset; 5489 if (uoffset < 2 * backw) { 5490 /* The assumption is that going forwards is twice the speed of going 5491 forward (that's where the 2 * backw comes from). 5492 (The real figure of course depends on the UTF-8 data.) */ 5493 return sv_pos_u2b_forwards(start, send, uoffset); 5494 } 5495 5496 while (backw--) { 5497 send--; 5498 while (UTF8_IS_CONTINUATION(*send)) 5499 send--; 5500 } 5501 return send - start; 5502 } 5503 5504 /* For the string representation of the given scalar, find the byte 5505 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0 5506 give another position in the string, *before* the sought offset, which 5507 (which is always true, as 0, 0 is a valid pair of positions), which should 5508 help reduce the amount of linear searching. 5509 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which 5510 will be used to reduce the amount of linear searching. The cache will be 5511 created if necessary, and the found value offered to it for update. */ 5512 static STRLEN 5513 S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, 5514 const U8 *const send, STRLEN uoffset, 5515 STRLEN uoffset0, STRLEN boffset0) { 5516 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ 5517 bool found = FALSE; 5518 5519 assert (uoffset >= uoffset0); 5520 5521 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache 5522 && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { 5523 if ((*mgp)->mg_ptr) { 5524 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; 5525 if (cache[0] == uoffset) { 5526 /* An exact match. */ 5527 return cache[1]; 5528 } 5529 if (cache[2] == uoffset) { 5530 /* An exact match. */ 5531 return cache[3]; 5532 } 5533 5534 if (cache[0] < uoffset) { 5535 /* The cache already knows part of the way. */ 5536 if (cache[0] > uoffset0) { 5537 /* The cache knows more than the passed in pair */ 5538 uoffset0 = cache[0]; 5539 boffset0 = cache[1]; 5540 } 5541 if ((*mgp)->mg_len != -1) { 5542 /* And we know the end too. */ 5543 boffset = boffset0 5544 + sv_pos_u2b_midway(start + boffset0, send, 5545 uoffset - uoffset0, 5546 (*mgp)->mg_len - uoffset0); 5547 } else { 5548 boffset = boffset0 5549 + sv_pos_u2b_forwards(start + boffset0, 5550 send, uoffset - uoffset0); 5551 } 5552 } 5553 else if (cache[2] < uoffset) { 5554 /* We're between the two cache entries. */ 5555 if (cache[2] > uoffset0) { 5556 /* and the cache knows more than the passed in pair */ 5557 uoffset0 = cache[2]; 5558 boffset0 = cache[3]; 5559 } 5560 5561 boffset = boffset0 5562 + sv_pos_u2b_midway(start + boffset0, 5563 start + cache[1], 5564 uoffset - uoffset0, 5565 cache[0] - uoffset0); 5566 } else { 5567 boffset = boffset0 5568 + sv_pos_u2b_midway(start + boffset0, 5569 start + cache[3], 5570 uoffset - uoffset0, 5571 cache[2] - uoffset0); 5572 } 5573 found = TRUE; 5574 } 5575 else if ((*mgp)->mg_len != -1) { 5576 /* If we can take advantage of a passed in offset, do so. */ 5577 /* In fact, offset0 is either 0, or less than offset, so don't 5578 need to worry about the other possibility. */ 5579 boffset = boffset0 5580 + sv_pos_u2b_midway(start + boffset0, send, 5581 uoffset - uoffset0, 5582 (*mgp)->mg_len - uoffset0); 5583 found = TRUE; 5584 } 5585 } 5586 5587 if (!found || PL_utf8cache < 0) { 5588 const STRLEN real_boffset 5589 = boffset0 + sv_pos_u2b_forwards(start + boffset0, 5590 send, uoffset - uoffset0); 5591 5592 if (found && PL_utf8cache < 0) { 5593 if (real_boffset != boffset) { 5594 /* Need to turn the assertions off otherwise we may recurse 5595 infinitely while printing error messages. */ 5596 SAVEI8(PL_utf8cache); 5597 PL_utf8cache = 0; 5598 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf 5599 " real %"UVuf" for %"SVf, 5600 (UV) boffset, (UV) real_boffset, SVfARG(sv)); 5601 } 5602 } 5603 boffset = real_boffset; 5604 } 5605 5606 S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start); 5607 return boffset; 5608 } 5609 5610 5611 /* 5612 =for apidoc sv_pos_u2b 5613 5614 Converts the value pointed to by offsetp from a count of UTF-8 chars from 5615 the start of the string, to a count of the equivalent number of bytes; if 5616 lenp is non-zero, it does the same to lenp, but this time starting from 5617 the offset, rather than from the start of the string. Handles magic and 5618 type coercion. 5619 5620 =cut 5621 */ 5622 5623 /* 5624 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential 5625 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and 5626 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). 5627 * 5628 */ 5629 5630 void 5631 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) 5632 { 5633 const U8 *start; 5634 STRLEN len; 5635 5636 if (!sv) 5637 return; 5638 5639 start = (U8*)SvPV_const(sv, len); 5640 if (len) { 5641 STRLEN uoffset = (STRLEN) *offsetp; 5642 const U8 * const send = start + len; 5643 MAGIC *mg = NULL; 5644 const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, 5645 uoffset, 0, 0); 5646 5647 *offsetp = (I32) boffset; 5648 5649 if (lenp) { 5650 /* Convert the relative offset to absolute. */ 5651 const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; 5652 const STRLEN boffset2 5653 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, 5654 uoffset, boffset) - boffset; 5655 5656 *lenp = boffset2; 5657 } 5658 } 5659 else { 5660 *offsetp = 0; 5661 if (lenp) 5662 *lenp = 0; 5663 } 5664 5665 return; 5666 } 5667 5668 /* Create and update the UTF8 magic offset cache, with the proffered utf8/ 5669 byte length pairing. The (byte) length of the total SV is passed in too, 5670 as blen, because for some (more esoteric) SVs, the call to SvPV_const() 5671 may not have updated SvCUR, so we can't rely on reading it directly. 5672 5673 The proffered utf8/byte length pairing isn't used if the cache already has 5674 two pairs, and swapping either for the proffered pair would increase the 5675 RMS of the intervals between known byte offsets. 5676 5677 The cache itself consists of 4 STRLEN values 5678 0: larger UTF-8 offset 5679 1: corresponding byte offset 5680 2: smaller UTF-8 offset 5681 3: corresponding byte offset 5682 5683 Unused cache pairs have the value 0, 0. 5684 Keeping the cache "backwards" means that the invariant of 5685 cache[0] >= cache[2] is maintained even with empty slots, which means that 5686 the code that uses it doesn't need to worry if only 1 entry has actually 5687 been set to non-zero. It also makes the "position beyond the end of the 5688 cache" logic much simpler, as the first slot is always the one to start 5689 from. 5690 */ 5691 static void 5692 S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, 5693 STRLEN blen) 5694 { 5695 STRLEN *cache; 5696 if (SvREADONLY(sv)) 5697 return; 5698 5699 if (!*mgp) { 5700 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 5701 0); 5702 (*mgp)->mg_len = -1; 5703 } 5704 assert(*mgp); 5705 5706 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) { 5707 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); 5708 (*mgp)->mg_ptr = (char *) cache; 5709 } 5710 assert(cache); 5711 5712 if (PL_utf8cache < 0) { 5713 const U8 *start = (const U8 *) SvPVX_const(sv); 5714 const STRLEN realutf8 = utf8_length(start, start + byte); 5715 5716 if (realutf8 != utf8) { 5717 /* Need to turn the assertions off otherwise we may recurse 5718 infinitely while printing error messages. */ 5719 SAVEI8(PL_utf8cache); 5720 PL_utf8cache = 0; 5721 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf 5722 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv)); 5723 } 5724 } 5725 5726 /* Cache is held with the later position first, to simplify the code 5727 that deals with unbounded ends. */ 5728 5729 ASSERT_UTF8_CACHE(cache); 5730 if (cache[1] == 0) { 5731 /* Cache is totally empty */ 5732 cache[0] = utf8; 5733 cache[1] = byte; 5734 } else if (cache[3] == 0) { 5735 if (byte > cache[1]) { 5736 /* New one is larger, so goes first. */ 5737 cache[2] = cache[0]; 5738 cache[3] = cache[1]; 5739 cache[0] = utf8; 5740 cache[1] = byte; 5741 } else { 5742 cache[2] = utf8; 5743 cache[3] = byte; 5744 } 5745 } else { 5746 #define THREEWAY_SQUARE(a,b,c,d) \ 5747 ((float)((d) - (c))) * ((float)((d) - (c))) \ 5748 + ((float)((c) - (b))) * ((float)((c) - (b))) \ 5749 + ((float)((b) - (a))) * ((float)((b) - (a))) 5750 5751 /* Cache has 2 slots in use, and we know three potential pairs. 5752 Keep the two that give the lowest RMS distance. Do the 5753 calcualation in bytes simply because we always know the byte 5754 length. squareroot has the same ordering as the positive value, 5755 so don't bother with the actual square root. */ 5756 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen); 5757 if (byte > cache[1]) { 5758 /* New position is after the existing pair of pairs. */ 5759 const float keep_earlier 5760 = THREEWAY_SQUARE(0, cache[3], byte, blen); 5761 const float keep_later 5762 = THREEWAY_SQUARE(0, cache[1], byte, blen); 5763 5764 if (keep_later < keep_earlier) { 5765 if (keep_later < existing) { 5766 cache[2] = cache[0]; 5767 cache[3] = cache[1]; 5768 cache[0] = utf8; 5769 cache[1] = byte; 5770 } 5771 } 5772 else { 5773 if (keep_earlier < existing) { 5774 cache[0] = utf8; 5775 cache[1] = byte; 5776 } 5777 } 5778 } 5779 else if (byte > cache[3]) { 5780 /* New position is between the existing pair of pairs. */ 5781 const float keep_earlier 5782 = THREEWAY_SQUARE(0, cache[3], byte, blen); 5783 const float keep_later 5784 = THREEWAY_SQUARE(0, byte, cache[1], blen); 5785 5786 if (keep_later < keep_earlier) { 5787 if (keep_later < existing) { 5788 cache[2] = utf8; 5789 cache[3] = byte; 5790 } 5791 } 5792 else { 5793 if (keep_earlier < existing) { 5794 cache[0] = utf8; 5795 cache[1] = byte; 5796 } 5797 } 5798 } 5799 else { 5800 /* New position is before the existing pair of pairs. */ 5801 const float keep_earlier 5802 = THREEWAY_SQUARE(0, byte, cache[3], blen); 5803 const float keep_later 5804 = THREEWAY_SQUARE(0, byte, cache[1], blen); 5805 5806 if (keep_later < keep_earlier) { 5807 if (keep_later < existing) { 5808 cache[2] = utf8; 5809 cache[3] = byte; 5810 } 5811 } 5812 else { 5813 if (keep_earlier < existing) { 5814 cache[0] = cache[2]; 5815 cache[1] = cache[3]; 5816 cache[2] = utf8; 5817 cache[3] = byte; 5818 } 5819 } 5820 } 5821 } 5822 ASSERT_UTF8_CACHE(cache); 5823 } 5824 5825 /* We already know all of the way, now we may be able to walk back. The same 5826 assumption is made as in S_sv_pos_u2b_midway(), namely that walking 5827 backward is half the speed of walking forward. */ 5828 static STRLEN 5829 S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, 5830 STRLEN endu) 5831 { 5832 const STRLEN forw = target - s; 5833 STRLEN backw = end - target; 5834 5835 if (forw < 2 * backw) { 5836 return utf8_length(s, target); 5837 } 5838 5839 while (end > target) { 5840 end--; 5841 while (UTF8_IS_CONTINUATION(*end)) { 5842 end--; 5843 } 5844 endu--; 5845 } 5846 return endu; 5847 } 5848 5849 /* 5850 =for apidoc sv_pos_b2u 5851 5852 Converts the value pointed to by offsetp from a count of bytes from the 5853 start of the string, to a count of the equivalent number of UTF-8 chars. 5854 Handles magic and type coercion. 5855 5856 =cut 5857 */ 5858 5859 /* 5860 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential 5861 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and 5862 * byte offsets. 5863 * 5864 */ 5865 void 5866 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) 5867 { 5868 const U8* s; 5869 const STRLEN byte = *offsetp; 5870 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */ 5871 STRLEN blen; 5872 MAGIC* mg = NULL; 5873 const U8* send; 5874 bool found = FALSE; 5875 5876 if (!sv) 5877 return; 5878 5879 s = (const U8*)SvPV_const(sv, blen); 5880 5881 if (blen < byte) 5882 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); 5883 5884 send = s + byte; 5885 5886 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache 5887 && (mg = mg_find(sv, PERL_MAGIC_utf8))) { 5888 if (mg->mg_ptr) { 5889 STRLEN * const cache = (STRLEN *) mg->mg_ptr; 5890 if (cache[1] == byte) { 5891 /* An exact match. */ 5892 *offsetp = cache[0]; 5893 return; 5894 } 5895 if (cache[3] == byte) { 5896 /* An exact match. */ 5897 *offsetp = cache[2]; 5898 return; 5899 } 5900 5901 if (cache[1] < byte) { 5902 /* We already know part of the way. */ 5903 if (mg->mg_len != -1) { 5904 /* Actually, we know the end too. */ 5905 len = cache[0] 5906 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, 5907 s + blen, mg->mg_len - cache[0]); 5908 } else { 5909 len = cache[0] + utf8_length(s + cache[1], send); 5910 } 5911 } 5912 else if (cache[3] < byte) { 5913 /* We're between the two cached pairs, so we do the calculation 5914 offset by the byte/utf-8 positions for the earlier pair, 5915 then add the utf-8 characters from the string start to 5916 there. */ 5917 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, 5918 s + cache[1], cache[0] - cache[2]) 5919 + cache[2]; 5920 5921 } 5922 else { /* cache[3] > byte */ 5923 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], 5924 cache[2]); 5925 5926 } 5927 ASSERT_UTF8_CACHE(cache); 5928 found = TRUE; 5929 } else if (mg->mg_len != -1) { 5930 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); 5931 found = TRUE; 5932 } 5933 } 5934 if (!found || PL_utf8cache < 0) { 5935 const STRLEN real_len = utf8_length(s, send); 5936 5937 if (found && PL_utf8cache < 0) { 5938 if (len != real_len) { 5939 /* Need to turn the assertions off otherwise we may recurse 5940 infinitely while printing error messages. */ 5941 SAVEI8(PL_utf8cache); 5942 PL_utf8cache = 0; 5943 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf 5944 " real %"UVuf" for %"SVf, 5945 (UV) len, (UV) real_len, SVfARG(sv)); 5946 } 5947 } 5948 len = real_len; 5949 } 5950 *offsetp = len; 5951 5952 S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen); 5953 } 5954 5955 /* 5956 =for apidoc sv_eq 5957 5958 Returns a boolean indicating whether the strings in the two SVs are 5959 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will 5960 coerce its args to strings if necessary. 5961 5962 =cut 5963 */ 5964 5965 I32 5966 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) 5967 { 5968 dVAR; 5969 const char *pv1; 5970 STRLEN cur1; 5971 const char *pv2; 5972 STRLEN cur2; 5973 I32 eq = 0; 5974 char *tpv = NULL; 5975 SV* svrecode = NULL; 5976 5977 if (!sv1) { 5978 pv1 = ""; 5979 cur1 = 0; 5980 } 5981 else { 5982 /* if pv1 and pv2 are the same, second SvPV_const call may 5983 * invalidate pv1, so we may need to make a copy */ 5984 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { 5985 pv1 = SvPV_const(sv1, cur1); 5986 sv1 = sv_2mortal(newSVpvn(pv1, cur1)); 5987 if (SvUTF8(sv2)) SvUTF8_on(sv1); 5988 } 5989 pv1 = SvPV_const(sv1, cur1); 5990 } 5991 5992 if (!sv2){ 5993 pv2 = ""; 5994 cur2 = 0; 5995 } 5996 else 5997 pv2 = SvPV_const(sv2, cur2); 5998 5999 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { 6000 /* Differing utf8ness. 6001 * Do not UTF8size the comparands as a side-effect. */ 6002 if (PL_encoding) { 6003 if (SvUTF8(sv1)) { 6004 svrecode = newSVpvn(pv2, cur2); 6005 sv_recode_to_utf8(svrecode, PL_encoding); 6006 pv2 = SvPV_const(svrecode, cur2); 6007 } 6008 else { 6009 svrecode = newSVpvn(pv1, cur1); 6010 sv_recode_to_utf8(svrecode, PL_encoding); 6011 pv1 = SvPV_const(svrecode, cur1); 6012 } 6013 /* Now both are in UTF-8. */ 6014 if (cur1 != cur2) { 6015 SvREFCNT_dec(svrecode); 6016 return FALSE; 6017 } 6018 } 6019 else { 6020 bool is_utf8 = TRUE; 6021 6022 if (SvUTF8(sv1)) { 6023 /* sv1 is the UTF-8 one, 6024 * if is equal it must be downgrade-able */ 6025 char * const pv = (char*)bytes_from_utf8((const U8*)pv1, 6026 &cur1, &is_utf8); 6027 if (pv != pv1) 6028 pv1 = tpv = pv; 6029 } 6030 else { 6031 /* sv2 is the UTF-8 one, 6032 * if is equal it must be downgrade-able */ 6033 char * const pv = (char *)bytes_from_utf8((const U8*)pv2, 6034 &cur2, &is_utf8); 6035 if (pv != pv2) 6036 pv2 = tpv = pv; 6037 } 6038 if (is_utf8) { 6039 /* Downgrade not possible - cannot be eq */ 6040 assert (tpv == 0); 6041 return FALSE; 6042 } 6043 } 6044 } 6045 6046 if (cur1 == cur2) 6047 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); 6048 6049 SvREFCNT_dec(svrecode); 6050 if (tpv) 6051 Safefree(tpv); 6052 6053 return eq; 6054 } 6055 6056 /* 6057 =for apidoc sv_cmp 6058 6059 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the 6060 string in C<sv1> is less than, equal to, or greater than the string in 6061 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will 6062 coerce its args to strings if necessary. See also C<sv_cmp_locale>. 6063 6064 =cut 6065 */ 6066 6067 I32 6068 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) 6069 { 6070 dVAR; 6071 STRLEN cur1, cur2; 6072 const char *pv1, *pv2; 6073 char *tpv = NULL; 6074 I32 cmp; 6075 SV *svrecode = NULL; 6076 6077 if (!sv1) { 6078 pv1 = ""; 6079 cur1 = 0; 6080 } 6081 else 6082 pv1 = SvPV_const(sv1, cur1); 6083 6084 if (!sv2) { 6085 pv2 = ""; 6086 cur2 = 0; 6087 } 6088 else 6089 pv2 = SvPV_const(sv2, cur2); 6090 6091 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { 6092 /* Differing utf8ness. 6093 * Do not UTF8size the comparands as a side-effect. */ 6094 if (SvUTF8(sv1)) { 6095 if (PL_encoding) { 6096 svrecode = newSVpvn(pv2, cur2); 6097 sv_recode_to_utf8(svrecode, PL_encoding); 6098 pv2 = SvPV_const(svrecode, cur2); 6099 } 6100 else { 6101 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2); 6102 } 6103 } 6104 else { 6105 if (PL_encoding) { 6106 svrecode = newSVpvn(pv1, cur1); 6107 sv_recode_to_utf8(svrecode, PL_encoding); 6108 pv1 = SvPV_const(svrecode, cur1); 6109 } 6110 else { 6111 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1); 6112 } 6113 } 6114 } 6115 6116 if (!cur1) { 6117 cmp = cur2 ? -1 : 0; 6118 } else if (!cur2) { 6119 cmp = 1; 6120 } else { 6121 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2); 6122 6123 if (retval) { 6124 cmp = retval < 0 ? -1 : 1; 6125 } else if (cur1 == cur2) { 6126 cmp = 0; 6127 } else { 6128 cmp = cur1 < cur2 ? -1 : 1; 6129 } 6130 } 6131 6132 SvREFCNT_dec(svrecode); 6133 if (tpv) 6134 Safefree(tpv); 6135 6136 return cmp; 6137 } 6138 6139 /* 6140 =for apidoc sv_cmp_locale 6141 6142 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 6143 'use bytes' aware, handles get magic, and will coerce its args to strings 6144 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>. 6145 6146 =cut 6147 */ 6148 6149 I32 6150 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) 6151 { 6152 dVAR; 6153 #ifdef USE_LOCALE_COLLATE 6154 6155 char *pv1, *pv2; 6156 STRLEN len1, len2; 6157 I32 retval; 6158 6159 if (PL_collation_standard) 6160 goto raw_compare; 6161 6162 len1 = 0; 6163 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL; 6164 len2 = 0; 6165 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL; 6166 6167 if (!pv1 || !len1) { 6168 if (pv2 && len2) 6169 return -1; 6170 else 6171 goto raw_compare; 6172 } 6173 else { 6174 if (!pv2 || !len2) 6175 return 1; 6176 } 6177 6178 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); 6179 6180 if (retval) 6181 return retval < 0 ? -1 : 1; 6182 6183 /* 6184 * When the result of collation is equality, that doesn't mean 6185 * that there are no differences -- some locales exclude some 6186 * characters from consideration. So to avoid false equalities, 6187 * we use the raw string as a tiebreaker. 6188 */ 6189 6190 raw_compare: 6191 /*FALLTHROUGH*/ 6192 6193 #endif /* USE_LOCALE_COLLATE */ 6194 6195 return sv_cmp(sv1, sv2); 6196 } 6197 6198 6199 #ifdef USE_LOCALE_COLLATE 6200 6201 /* 6202 =for apidoc sv_collxfrm 6203 6204 Add Collate Transform magic to an SV if it doesn't already have it. 6205 6206 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the 6207 scalar data of the variable, but transformed to such a format that a normal 6208 memory comparison can be used to compare the data according to the locale 6209 settings. 6210 6211 =cut 6212 */ 6213 6214 char * 6215 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) 6216 { 6217 dVAR; 6218 MAGIC *mg; 6219 6220 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; 6221 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { 6222 const char *s; 6223 char *xf; 6224 STRLEN len, xlen; 6225 6226 if (mg) 6227 Safefree(mg->mg_ptr); 6228 s = SvPV_const(sv, len); 6229 if ((xf = mem_collxfrm(s, len, &xlen))) { 6230 if (SvREADONLY(sv)) { 6231 SAVEFREEPV(xf); 6232 *nxp = xlen; 6233 return xf + sizeof(PL_collation_ix); 6234 } 6235 if (! mg) { 6236 #ifdef PERL_OLD_COPY_ON_WRITE 6237 if (SvIsCOW(sv)) 6238 sv_force_normal_flags(sv, 0); 6239 #endif 6240 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, 6241 0, 0); 6242 assert(mg); 6243 } 6244 mg->mg_ptr = xf; 6245 mg->mg_len = xlen; 6246 } 6247 else { 6248 if (mg) { 6249 mg->mg_ptr = NULL; 6250 mg->mg_len = -1; 6251 } 6252 } 6253 } 6254 if (mg && mg->mg_ptr) { 6255 *nxp = mg->mg_len; 6256 return mg->mg_ptr + sizeof(PL_collation_ix); 6257 } 6258 else { 6259 *nxp = 0; 6260 return NULL; 6261 } 6262 } 6263 6264 #endif /* USE_LOCALE_COLLATE */ 6265 6266 /* 6267 =for apidoc sv_gets 6268 6269 Get a line from the filehandle and store it into the SV, optionally 6270 appending to the currently-stored string. 6271 6272 =cut 6273 */ 6274 6275 char * 6276 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) 6277 { 6278 dVAR; 6279 const char *rsptr; 6280 STRLEN rslen; 6281 register STDCHAR rslast; 6282 register STDCHAR *bp; 6283 register I32 cnt; 6284 I32 i = 0; 6285 I32 rspara = 0; 6286 6287 if (SvTHINKFIRST(sv)) 6288 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); 6289 /* XXX. If you make this PVIV, then copy on write can copy scalars read 6290 from <>. 6291 However, perlbench says it's slower, because the existing swipe code 6292 is faster than copy on write. 6293 Swings and roundabouts. */ 6294 SvUPGRADE(sv, SVt_PV); 6295 6296 SvSCREAM_off(sv); 6297 6298 if (append) { 6299 if (PerlIO_isutf8(fp)) { 6300 if (!SvUTF8(sv)) { 6301 sv_utf8_upgrade_nomg(sv); 6302 sv_pos_u2b(sv,&append,0); 6303 } 6304 } else if (SvUTF8(sv)) { 6305 SV * const tsv = newSV(0); 6306 sv_gets(tsv, fp, 0); 6307 sv_utf8_upgrade_nomg(tsv); 6308 SvCUR_set(sv,append); 6309 sv_catsv(sv,tsv); 6310 sv_free(tsv); 6311 goto return_string_or_null; 6312 } 6313 } 6314 6315 SvPOK_only(sv); 6316 if (PerlIO_isutf8(fp)) 6317 SvUTF8_on(sv); 6318 6319 if (IN_PERL_COMPILETIME) { 6320 /* we always read code in line mode */ 6321 rsptr = "\n"; 6322 rslen = 1; 6323 } 6324 else if (RsSNARF(PL_rs)) { 6325 /* If it is a regular disk file use size from stat() as estimate 6326 of amount we are going to read -- may result in mallocing 6327 more memory than we really need if the layers below reduce 6328 the size we read (e.g. CRLF or a gzip layer). 6329 */ 6330 Stat_t st; 6331 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { 6332 const Off_t offset = PerlIO_tell(fp); 6333 if (offset != (Off_t) -1 && st.st_size + append > offset) { 6334 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); 6335 } 6336 } 6337 rsptr = NULL; 6338 rslen = 0; 6339 } 6340 else if (RsRECORD(PL_rs)) { 6341 I32 bytesread; 6342 char *buffer; 6343 U32 recsize; 6344 6345 /* Grab the size of the record we're getting */ 6346 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ 6347 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; 6348 /* Go yank in */ 6349 #ifdef VMS 6350 /* VMS wants read instead of fread, because fread doesn't respect */ 6351 /* RMS record boundaries. This is not necessarily a good thing to be */ 6352 /* doing, but we've got no other real choice - except avoid stdio 6353 as implementation - perhaps write a :vms layer ? 6354 */ 6355 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); 6356 #else 6357 bytesread = PerlIO_read(fp, buffer, recsize); 6358 #endif 6359 if (bytesread < 0) 6360 bytesread = 0; 6361 SvCUR_set(sv, bytesread += append); 6362 buffer[bytesread] = '\0'; 6363 goto return_string_or_null; 6364 } 6365 else if (RsPARA(PL_rs)) { 6366 rsptr = "\n\n"; 6367 rslen = 2; 6368 rspara = 1; 6369 } 6370 else { 6371 /* Get $/ i.e. PL_rs into same encoding as stream wants */ 6372 if (PerlIO_isutf8(fp)) { 6373 rsptr = SvPVutf8(PL_rs, rslen); 6374 } 6375 else { 6376 if (SvUTF8(PL_rs)) { 6377 if (!sv_utf8_downgrade(PL_rs, TRUE)) { 6378 Perl_croak(aTHX_ "Wide character in $/"); 6379 } 6380 } 6381 rsptr = SvPV_const(PL_rs, rslen); 6382 } 6383 } 6384 6385 rslast = rslen ? rsptr[rslen - 1] : '\0'; 6386 6387 if (rspara) { /* have to do this both before and after */ 6388 do { /* to make sure file boundaries work right */ 6389 if (PerlIO_eof(fp)) 6390 return 0; 6391 i = PerlIO_getc(fp); 6392 if (i != '\n') { 6393 if (i == -1) 6394 return 0; 6395 PerlIO_ungetc(fp,i); 6396 break; 6397 } 6398 } while (i != EOF); 6399 } 6400 6401 /* See if we know enough about I/O mechanism to cheat it ! */ 6402 6403 /* This used to be #ifdef test - it is made run-time test for ease 6404 of abstracting out stdio interface. One call should be cheap 6405 enough here - and may even be a macro allowing compile 6406 time optimization. 6407 */ 6408 6409 if (PerlIO_fast_gets(fp)) { 6410 6411 /* 6412 * We're going to steal some values from the stdio struct 6413 * and put EVERYTHING in the innermost loop into registers. 6414 */ 6415 register STDCHAR *ptr; 6416 STRLEN bpx; 6417 I32 shortbuffered; 6418 6419 #if defined(VMS) && defined(PERLIO_IS_STDIO) 6420 /* An ungetc()d char is handled separately from the regular 6421 * buffer, so we getc() it back out and stuff it in the buffer. 6422 */ 6423 i = PerlIO_getc(fp); 6424 if (i == EOF) return 0; 6425 *(--((*fp)->_ptr)) = (unsigned char) i; 6426 (*fp)->_cnt++; 6427 #endif 6428 6429 /* Here is some breathtakingly efficient cheating */ 6430 6431 cnt = PerlIO_get_cnt(fp); /* get count into register */ 6432 /* make sure we have the room */ 6433 if ((I32)(SvLEN(sv) - append) <= cnt + 1) { 6434 /* Not room for all of it 6435 if we are looking for a separator and room for some 6436 */ 6437 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { 6438 /* just process what we have room for */ 6439 shortbuffered = cnt - SvLEN(sv) + append + 1; 6440 cnt -= shortbuffered; 6441 } 6442 else { 6443 shortbuffered = 0; 6444 /* remember that cnt can be negative */ 6445 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); 6446 } 6447 } 6448 else 6449 shortbuffered = 0; 6450 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */ 6451 ptr = (STDCHAR*)PerlIO_get_ptr(fp); 6452 DEBUG_P(PerlIO_printf(Perl_debug_log, 6453 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 6454 DEBUG_P(PerlIO_printf(Perl_debug_log, 6455 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 6456 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 6457 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); 6458 for (;;) { 6459 screamer: 6460 if (cnt > 0) { 6461 if (rslen) { 6462 while (cnt > 0) { /* this | eat */ 6463 cnt--; 6464 if ((*bp++ = *ptr++) == rslast) /* really | dust */ 6465 goto thats_all_folks; /* screams | sed :-) */ 6466 } 6467 } 6468 else { 6469 Copy(ptr, bp, cnt, char); /* this | eat */ 6470 bp += cnt; /* screams | dust */ 6471 ptr += cnt; /* louder | sed :-) */ 6472 cnt = 0; 6473 } 6474 } 6475 6476 if (shortbuffered) { /* oh well, must extend */ 6477 cnt = shortbuffered; 6478 shortbuffered = 0; 6479 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ 6480 SvCUR_set(sv, bpx); 6481 SvGROW(sv, SvLEN(sv) + append + cnt + 2); 6482 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ 6483 continue; 6484 } 6485 6486 DEBUG_P(PerlIO_printf(Perl_debug_log, 6487 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", 6488 PTR2UV(ptr),(long)cnt)); 6489 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ 6490 #if 0 6491 DEBUG_P(PerlIO_printf(Perl_debug_log, 6492 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 6493 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 6494 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 6495 #endif 6496 /* This used to call 'filbuf' in stdio form, but as that behaves like 6497 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing 6498 another abstraction. */ 6499 i = PerlIO_getc(fp); /* get more characters */ 6500 #if 0 6501 DEBUG_P(PerlIO_printf(Perl_debug_log, 6502 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 6503 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 6504 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 6505 #endif 6506 cnt = PerlIO_get_cnt(fp); 6507 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ 6508 DEBUG_P(PerlIO_printf(Perl_debug_log, 6509 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 6510 6511 if (i == EOF) /* all done for ever? */ 6512 goto thats_really_all_folks; 6513 6514 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ 6515 SvCUR_set(sv, bpx); 6516 SvGROW(sv, bpx + cnt + 2); 6517 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ 6518 6519 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ 6520 6521 if (rslen && (STDCHAR)i == rslast) /* all done for now? */ 6522 goto thats_all_folks; 6523 } 6524 6525 thats_all_folks: 6526 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || 6527 memNE((char*)bp - rslen, rsptr, rslen)) 6528 goto screamer; /* go back to the fray */ 6529 thats_really_all_folks: 6530 if (shortbuffered) 6531 cnt += shortbuffered; 6532 DEBUG_P(PerlIO_printf(Perl_debug_log, 6533 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 6534 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ 6535 DEBUG_P(PerlIO_printf(Perl_debug_log, 6536 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 6537 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 6538 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 6539 *bp = '\0'; 6540 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ 6541 DEBUG_P(PerlIO_printf(Perl_debug_log, 6542 "Screamer: done, len=%ld, string=|%.*s|\n", 6543 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); 6544 } 6545 else 6546 { 6547 /*The big, slow, and stupid way. */ 6548 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ 6549 STDCHAR *buf = NULL; 6550 Newx(buf, 8192, STDCHAR); 6551 assert(buf); 6552 #else 6553 STDCHAR buf[8192]; 6554 #endif 6555 6556 screamer2: 6557 if (rslen) { 6558 register const STDCHAR * const bpe = buf + sizeof(buf); 6559 bp = buf; 6560 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) 6561 ; /* keep reading */ 6562 cnt = bp - buf; 6563 } 6564 else { 6565 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); 6566 /* Accomodate broken VAXC compiler, which applies U8 cast to 6567 * both args of ?: operator, causing EOF to change into 255 6568 */ 6569 if (cnt > 0) 6570 i = (U8)buf[cnt - 1]; 6571 else 6572 i = EOF; 6573 } 6574 6575 if (cnt < 0) 6576 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ 6577 if (append) 6578 sv_catpvn(sv, (char *) buf, cnt); 6579 else 6580 sv_setpvn(sv, (char *) buf, cnt); 6581 6582 if (i != EOF && /* joy */ 6583 (!rslen || 6584 SvCUR(sv) < rslen || 6585 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) 6586 { 6587 append = -1; 6588 /* 6589 * If we're reading from a TTY and we get a short read, 6590 * indicating that the user hit his EOF character, we need 6591 * to notice it now, because if we try to read from the TTY 6592 * again, the EOF condition will disappear. 6593 * 6594 * The comparison of cnt to sizeof(buf) is an optimization 6595 * that prevents unnecessary calls to feof(). 6596 * 6597 * - jik 9/25/96 6598 */ 6599 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) 6600 goto screamer2; 6601 } 6602 6603 #ifdef USE_HEAP_INSTEAD_OF_STACK 6604 Safefree(buf); 6605 #endif 6606 } 6607 6608 if (rspara) { /* have to do this both before and after */ 6609 while (i != EOF) { /* to make sure file boundaries work right */ 6610 i = PerlIO_getc(fp); 6611 if (i != '\n') { 6612 PerlIO_ungetc(fp,i); 6613 break; 6614 } 6615 } 6616 } 6617 6618 return_string_or_null: 6619 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; 6620 } 6621 6622 /* 6623 =for apidoc sv_inc 6624 6625 Auto-increment of the value in the SV, doing string to numeric conversion 6626 if necessary. Handles 'get' magic. 6627 6628 =cut 6629 */ 6630 6631 void 6632 Perl_sv_inc(pTHX_ register SV *sv) 6633 { 6634 dVAR; 6635 register char *d; 6636 int flags; 6637 6638 if (!sv) 6639 return; 6640 SvGETMAGIC(sv); 6641 if (SvTHINKFIRST(sv)) { 6642 if (SvIsCOW(sv)) 6643 sv_force_normal_flags(sv, 0); 6644 if (SvREADONLY(sv)) { 6645 if (IN_PERL_RUNTIME) 6646 Perl_croak(aTHX_ PL_no_modify); 6647 } 6648 if (SvROK(sv)) { 6649 IV i; 6650 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) 6651 return; 6652 i = PTR2IV(SvRV(sv)); 6653 sv_unref(sv); 6654 sv_setiv(sv, i); 6655 } 6656 } 6657 flags = SvFLAGS(sv); 6658 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { 6659 /* It's (privately or publicly) a float, but not tested as an 6660 integer, so test it to see. */ 6661 (void) SvIV(sv); 6662 flags = SvFLAGS(sv); 6663 } 6664 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 6665 /* It's publicly an integer, or privately an integer-not-float */ 6666 #ifdef PERL_PRESERVE_IVUV 6667 oops_its_int: 6668 #endif 6669 if (SvIsUV(sv)) { 6670 if (SvUVX(sv) == UV_MAX) 6671 sv_setnv(sv, UV_MAX_P1); 6672 else 6673 (void)SvIOK_only_UV(sv); 6674 SvUV_set(sv, SvUVX(sv) + 1); 6675 } else { 6676 if (SvIVX(sv) == IV_MAX) 6677 sv_setuv(sv, (UV)IV_MAX + 1); 6678 else { 6679 (void)SvIOK_only(sv); 6680 SvIV_set(sv, SvIVX(sv) + 1); 6681 } 6682 } 6683 return; 6684 } 6685 if (flags & SVp_NOK) { 6686 (void)SvNOK_only(sv); 6687 SvNV_set(sv, SvNVX(sv) + 1.0); 6688 return; 6689 } 6690 6691 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { 6692 if ((flags & SVTYPEMASK) < SVt_PVIV) 6693 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); 6694 (void)SvIOK_only(sv); 6695 SvIV_set(sv, 1); 6696 return; 6697 } 6698 d = SvPVX(sv); 6699 while (isALPHA(*d)) d++; 6700 while (isDIGIT(*d)) d++; 6701 if (*d) { 6702 #ifdef PERL_PRESERVE_IVUV 6703 /* Got to punt this as an integer if needs be, but we don't issue 6704 warnings. Probably ought to make the sv_iv_please() that does 6705 the conversion if possible, and silently. */ 6706 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); 6707 if (numtype && !(numtype & IS_NUMBER_INFINITY)) { 6708 /* Need to try really hard to see if it's an integer. 6709 9.22337203685478e+18 is an integer. 6710 but "9.22337203685478e+18" + 0 is UV=9223372036854779904 6711 so $a="9.22337203685478e+18"; $a+0; $a++ 6712 needs to be the same as $a="9.22337203685478e+18"; $a++ 6713 or we go insane. */ 6714 6715 (void) sv_2iv(sv); 6716 if (SvIOK(sv)) 6717 goto oops_its_int; 6718 6719 /* sv_2iv *should* have made this an NV */ 6720 if (flags & SVp_NOK) { 6721 (void)SvNOK_only(sv); 6722 SvNV_set(sv, SvNVX(sv) + 1.0); 6723 return; 6724 } 6725 /* I don't think we can get here. Maybe I should assert this 6726 And if we do get here I suspect that sv_setnv will croak. NWC 6727 Fall through. */ 6728 #if defined(USE_LONG_DOUBLE) 6729 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", 6730 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 6731 #else 6732 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", 6733 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 6734 #endif 6735 } 6736 #endif /* PERL_PRESERVE_IVUV */ 6737 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); 6738 return; 6739 } 6740 d--; 6741 while (d >= SvPVX_const(sv)) { 6742 if (isDIGIT(*d)) { 6743 if (++*d <= '9') 6744 return; 6745 *(d--) = '0'; 6746 } 6747 else { 6748 #ifdef EBCDIC 6749 /* MKS: The original code here died if letters weren't consecutive. 6750 * at least it didn't have to worry about non-C locales. The 6751 * new code assumes that ('z'-'a')==('Z'-'A'), letters are 6752 * arranged in order (although not consecutively) and that only 6753 * [A-Za-z] are accepted by isALPHA in the C locale. 6754 */ 6755 if (*d != 'z' && *d != 'Z') { 6756 do { ++*d; } while (!isALPHA(*d)); 6757 return; 6758 } 6759 *(d--) -= 'z' - 'a'; 6760 #else 6761 ++*d; 6762 if (isALPHA(*d)) 6763 return; 6764 *(d--) -= 'z' - 'a' + 1; 6765 #endif 6766 } 6767 } 6768 /* oh,oh, the number grew */ 6769 SvGROW(sv, SvCUR(sv) + 2); 6770 SvCUR_set(sv, SvCUR(sv) + 1); 6771 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) 6772 *d = d[-1]; 6773 if (isDIGIT(d[1])) 6774 *d = '1'; 6775 else 6776 *d = d[1]; 6777 } 6778 6779 /* 6780 =for apidoc sv_dec 6781 6782 Auto-decrement of the value in the SV, doing string to numeric conversion 6783 if necessary. Handles 'get' magic. 6784 6785 =cut 6786 */ 6787 6788 void 6789 Perl_sv_dec(pTHX_ register SV *sv) 6790 { 6791 dVAR; 6792 int flags; 6793 6794 if (!sv) 6795 return; 6796 SvGETMAGIC(sv); 6797 if (SvTHINKFIRST(sv)) { 6798 if (SvIsCOW(sv)) 6799 sv_force_normal_flags(sv, 0); 6800 if (SvREADONLY(sv)) { 6801 if (IN_PERL_RUNTIME) 6802 Perl_croak(aTHX_ PL_no_modify); 6803 } 6804 if (SvROK(sv)) { 6805 IV i; 6806 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) 6807 return; 6808 i = PTR2IV(SvRV(sv)); 6809 sv_unref(sv); 6810 sv_setiv(sv, i); 6811 } 6812 } 6813 /* Unlike sv_inc we don't have to worry about string-never-numbers 6814 and keeping them magic. But we mustn't warn on punting */ 6815 flags = SvFLAGS(sv); 6816 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 6817 /* It's publicly an integer, or privately an integer-not-float */ 6818 #ifdef PERL_PRESERVE_IVUV 6819 oops_its_int: 6820 #endif 6821 if (SvIsUV(sv)) { 6822 if (SvUVX(sv) == 0) { 6823 (void)SvIOK_only(sv); 6824 SvIV_set(sv, -1); 6825 } 6826 else { 6827 (void)SvIOK_only_UV(sv); 6828 SvUV_set(sv, SvUVX(sv) - 1); 6829 } 6830 } else { 6831 if (SvIVX(sv) == IV_MIN) 6832 sv_setnv(sv, (NV)IV_MIN - 1.0); 6833 else { 6834 (void)SvIOK_only(sv); 6835 SvIV_set(sv, SvIVX(sv) - 1); 6836 } 6837 } 6838 return; 6839 } 6840 if (flags & SVp_NOK) { 6841 SvNV_set(sv, SvNVX(sv) - 1.0); 6842 (void)SvNOK_only(sv); 6843 return; 6844 } 6845 if (!(flags & SVp_POK)) { 6846 if ((flags & SVTYPEMASK) < SVt_PVIV) 6847 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); 6848 SvIV_set(sv, -1); 6849 (void)SvIOK_only(sv); 6850 return; 6851 } 6852 #ifdef PERL_PRESERVE_IVUV 6853 { 6854 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); 6855 if (numtype && !(numtype & IS_NUMBER_INFINITY)) { 6856 /* Need to try really hard to see if it's an integer. 6857 9.22337203685478e+18 is an integer. 6858 but "9.22337203685478e+18" + 0 is UV=9223372036854779904 6859 so $a="9.22337203685478e+18"; $a+0; $a-- 6860 needs to be the same as $a="9.22337203685478e+18"; $a-- 6861 or we go insane. */ 6862 6863 (void) sv_2iv(sv); 6864 if (SvIOK(sv)) 6865 goto oops_its_int; 6866 6867 /* sv_2iv *should* have made this an NV */ 6868 if (flags & SVp_NOK) { 6869 (void)SvNOK_only(sv); 6870 SvNV_set(sv, SvNVX(sv) - 1.0); 6871 return; 6872 } 6873 /* I don't think we can get here. Maybe I should assert this 6874 And if we do get here I suspect that sv_setnv will croak. NWC 6875 Fall through. */ 6876 #if defined(USE_LONG_DOUBLE) 6877 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", 6878 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 6879 #else 6880 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", 6881 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 6882 #endif 6883 } 6884 } 6885 #endif /* PERL_PRESERVE_IVUV */ 6886 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ 6887 } 6888 6889 /* 6890 =for apidoc sv_mortalcopy 6891 6892 Creates a new SV which is a copy of the original SV (using C<sv_setsv>). 6893 The new SV is marked as mortal. It will be destroyed "soon", either by an 6894 explicit call to FREETMPS, or by an implicit call at places such as 6895 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>. 6896 6897 =cut 6898 */ 6899 6900 /* Make a string that will exist for the duration of the expression 6901 * evaluation. Actually, it may have to last longer than that, but 6902 * hopefully we won't free it until it has been assigned to a 6903 * permanent location. */ 6904 6905 SV * 6906 Perl_sv_mortalcopy(pTHX_ SV *oldstr) 6907 { 6908 dVAR; 6909 register SV *sv; 6910 6911 new_SV(sv); 6912 sv_setsv(sv,oldstr); 6913 EXTEND_MORTAL(1); 6914 PL_tmps_stack[++PL_tmps_ix] = sv; 6915 SvTEMP_on(sv); 6916 return sv; 6917 } 6918 6919 /* 6920 =for apidoc sv_newmortal 6921 6922 Creates a new null SV which is mortal. The reference count of the SV is 6923 set to 1. It will be destroyed "soon", either by an explicit call to 6924 FREETMPS, or by an implicit call at places such as statement boundaries. 6925 See also C<sv_mortalcopy> and C<sv_2mortal>. 6926 6927 =cut 6928 */ 6929 6930 SV * 6931 Perl_sv_newmortal(pTHX) 6932 { 6933 dVAR; 6934 register SV *sv; 6935 6936 new_SV(sv); 6937 SvFLAGS(sv) = SVs_TEMP; 6938 EXTEND_MORTAL(1); 6939 PL_tmps_stack[++PL_tmps_ix] = sv; 6940 return sv; 6941 } 6942 6943 /* 6944 =for apidoc sv_2mortal 6945 6946 Marks an existing SV as mortal. The SV will be destroyed "soon", either 6947 by an explicit call to FREETMPS, or by an implicit call at places such as 6948 statement boundaries. SvTEMP() is turned on which means that the SV's 6949 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal> 6950 and C<sv_mortalcopy>. 6951 6952 =cut 6953 */ 6954 6955 SV * 6956 Perl_sv_2mortal(pTHX_ register SV *sv) 6957 { 6958 dVAR; 6959 if (!sv) 6960 return NULL; 6961 if (SvREADONLY(sv) && SvIMMORTAL(sv)) 6962 return sv; 6963 EXTEND_MORTAL(1); 6964 PL_tmps_stack[++PL_tmps_ix] = sv; 6965 SvTEMP_on(sv); 6966 return sv; 6967 } 6968 6969 /* 6970 =for apidoc newSVpv 6971 6972 Creates a new SV and copies a string into it. The reference count for the 6973 SV is set to 1. If C<len> is zero, Perl will compute the length using 6974 strlen(). For efficiency, consider using C<newSVpvn> instead. 6975 6976 =cut 6977 */ 6978 6979 SV * 6980 Perl_newSVpv(pTHX_ const char *s, STRLEN len) 6981 { 6982 dVAR; 6983 register SV *sv; 6984 6985 new_SV(sv); 6986 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); 6987 return sv; 6988 } 6989 6990 /* 6991 =for apidoc newSVpvn 6992 6993 Creates a new SV and copies a string into it. The reference count for the 6994 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length 6995 string. You are responsible for ensuring that the source string is at least 6996 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined. 6997 6998 =cut 6999 */ 7000 7001 SV * 7002 Perl_newSVpvn(pTHX_ const char *s, STRLEN len) 7003 { 7004 dVAR; 7005 register SV *sv; 7006 7007 new_SV(sv); 7008 sv_setpvn(sv,s,len); 7009 return sv; 7010 } 7011 7012 7013 /* 7014 =for apidoc newSVhek 7015 7016 Creates a new SV from the hash key structure. It will generate scalars that 7017 point to the shared string table where possible. Returns a new (undefined) 7018 SV if the hek is NULL. 7019 7020 =cut 7021 */ 7022 7023 SV * 7024 Perl_newSVhek(pTHX_ const HEK *hek) 7025 { 7026 dVAR; 7027 if (!hek) { 7028 SV *sv; 7029 7030 new_SV(sv); 7031 return sv; 7032 } 7033 7034 if (HEK_LEN(hek) == HEf_SVKEY) { 7035 return newSVsv(*(SV**)HEK_KEY(hek)); 7036 } else { 7037 const int flags = HEK_FLAGS(hek); 7038 if (flags & HVhek_WASUTF8) { 7039 /* Trouble :-) 7040 Andreas would like keys he put in as utf8 to come back as utf8 7041 */ 7042 STRLEN utf8_len = HEK_LEN(hek); 7043 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); 7044 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len); 7045 7046 SvUTF8_on (sv); 7047 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ 7048 return sv; 7049 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) { 7050 /* We don't have a pointer to the hv, so we have to replicate the 7051 flag into every HEK. This hv is using custom a hasing 7052 algorithm. Hence we can't return a shared string scalar, as 7053 that would contain the (wrong) hash value, and might get passed 7054 into an hv routine with a regular hash. 7055 Similarly, a hash that isn't using shared hash keys has to have 7056 the flag in every key so that we know not to try to call 7057 share_hek_kek on it. */ 7058 7059 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); 7060 if (HEK_UTF8(hek)) 7061 SvUTF8_on (sv); 7062 return sv; 7063 } 7064 /* This will be overwhelminly the most common case. */ 7065 { 7066 /* Inline most of newSVpvn_share(), because share_hek_hek() is far 7067 more efficient than sharepvn(). */ 7068 SV *sv; 7069 7070 new_SV(sv); 7071 sv_upgrade(sv, SVt_PV); 7072 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); 7073 SvCUR_set(sv, HEK_LEN(hek)); 7074 SvLEN_set(sv, 0); 7075 SvREADONLY_on(sv); 7076 SvFAKE_on(sv); 7077 SvPOK_on(sv); 7078 if (HEK_UTF8(hek)) 7079 SvUTF8_on(sv); 7080 return sv; 7081 } 7082 } 7083 } 7084 7085 /* 7086 =for apidoc newSVpvn_share 7087 7088 Creates a new SV with its SvPVX_const pointing to a shared string in the string 7089 table. If the string does not already exist in the table, it is created 7090 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that 7091 value is used; otherwise the hash is computed. The string's hash can be later 7092 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is 7093 that as the string table is used for shared hash keys these strings will have 7094 SvPVX_const == HeKEY and hash lookup will avoid string compare. 7095 7096 =cut 7097 */ 7098 7099 SV * 7100 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) 7101 { 7102 dVAR; 7103 register SV *sv; 7104 bool is_utf8 = FALSE; 7105 const char *const orig_src = src; 7106 7107 if (len < 0) { 7108 STRLEN tmplen = -len; 7109 is_utf8 = TRUE; 7110 /* See the note in hv.c:hv_fetch() --jhi */ 7111 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); 7112 len = tmplen; 7113 } 7114 if (!hash) 7115 PERL_HASH(hash, src, len); 7116 new_SV(sv); 7117 sv_upgrade(sv, SVt_PV); 7118 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); 7119 SvCUR_set(sv, len); 7120 SvLEN_set(sv, 0); 7121 SvREADONLY_on(sv); 7122 SvFAKE_on(sv); 7123 SvPOK_on(sv); 7124 if (is_utf8) 7125 SvUTF8_on(sv); 7126 if (src != orig_src) 7127 Safefree(src); 7128 return sv; 7129 } 7130 7131 7132 #if defined(PERL_IMPLICIT_CONTEXT) 7133 7134 /* pTHX_ magic can't cope with varargs, so this is a no-context 7135 * version of the main function, (which may itself be aliased to us). 7136 * Don't access this version directly. 7137 */ 7138 7139 SV * 7140 Perl_newSVpvf_nocontext(const char* pat, ...) 7141 { 7142 dTHX; 7143 register SV *sv; 7144 va_list args; 7145 va_start(args, pat); 7146 sv = vnewSVpvf(pat, &args); 7147 va_end(args); 7148 return sv; 7149 } 7150 #endif 7151 7152 /* 7153 =for apidoc newSVpvf 7154 7155 Creates a new SV and initializes it with the string formatted like 7156 C<sprintf>. 7157 7158 =cut 7159 */ 7160 7161 SV * 7162 Perl_newSVpvf(pTHX_ const char* pat, ...) 7163 { 7164 register SV *sv; 7165 va_list args; 7166 va_start(args, pat); 7167 sv = vnewSVpvf(pat, &args); 7168 va_end(args); 7169 return sv; 7170 } 7171 7172 /* backend for newSVpvf() and newSVpvf_nocontext() */ 7173 7174 SV * 7175 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) 7176 { 7177 dVAR; 7178 register SV *sv; 7179 new_SV(sv); 7180 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 7181 return sv; 7182 } 7183 7184 /* 7185 =for apidoc newSVnv 7186 7187 Creates a new SV and copies a floating point value into it. 7188 The reference count for the SV is set to 1. 7189 7190 =cut 7191 */ 7192 7193 SV * 7194 Perl_newSVnv(pTHX_ NV n) 7195 { 7196 dVAR; 7197 register SV *sv; 7198 7199 new_SV(sv); 7200 sv_setnv(sv,n); 7201 return sv; 7202 } 7203 7204 /* 7205 =for apidoc newSViv 7206 7207 Creates a new SV and copies an integer into it. The reference count for the 7208 SV is set to 1. 7209 7210 =cut 7211 */ 7212 7213 SV * 7214 Perl_newSViv(pTHX_ IV i) 7215 { 7216 dVAR; 7217 register SV *sv; 7218 7219 new_SV(sv); 7220 sv_setiv(sv,i); 7221 return sv; 7222 } 7223 7224 /* 7225 =for apidoc newSVuv 7226 7227 Creates a new SV and copies an unsigned integer into it. 7228 The reference count for the SV is set to 1. 7229 7230 =cut 7231 */ 7232 7233 SV * 7234 Perl_newSVuv(pTHX_ UV u) 7235 { 7236 dVAR; 7237 register SV *sv; 7238 7239 new_SV(sv); 7240 sv_setuv(sv,u); 7241 return sv; 7242 } 7243 7244 /* 7245 =for apidoc newSV_type 7246 7247 Creates a new SV, of the type specified. The reference count for the new SV 7248 is set to 1. 7249 7250 =cut 7251 */ 7252 7253 SV * 7254 Perl_newSV_type(pTHX_ svtype type) 7255 { 7256 register SV *sv; 7257 7258 new_SV(sv); 7259 sv_upgrade(sv, type); 7260 return sv; 7261 } 7262 7263 /* 7264 =for apidoc newRV_noinc 7265 7266 Creates an RV wrapper for an SV. The reference count for the original 7267 SV is B<not> incremented. 7268 7269 =cut 7270 */ 7271 7272 SV * 7273 Perl_newRV_noinc(pTHX_ SV *tmpRef) 7274 { 7275 dVAR; 7276 register SV *sv = newSV_type(SVt_RV); 7277 SvTEMP_off(tmpRef); 7278 SvRV_set(sv, tmpRef); 7279 SvROK_on(sv); 7280 return sv; 7281 } 7282 7283 /* newRV_inc is the official function name to use now. 7284 * newRV_inc is in fact #defined to newRV in sv.h 7285 */ 7286 7287 SV * 7288 Perl_newRV(pTHX_ SV *sv) 7289 { 7290 dVAR; 7291 return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); 7292 } 7293 7294 /* 7295 =for apidoc newSVsv 7296 7297 Creates a new SV which is an exact duplicate of the original SV. 7298 (Uses C<sv_setsv>). 7299 7300 =cut 7301 */ 7302 7303 SV * 7304 Perl_newSVsv(pTHX_ register SV *old) 7305 { 7306 dVAR; 7307 register SV *sv; 7308 7309 if (!old) 7310 return NULL; 7311 if (SvTYPE(old) == SVTYPEMASK) { 7312 if (ckWARN_d(WARN_INTERNAL)) 7313 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); 7314 return NULL; 7315 } 7316 new_SV(sv); 7317 /* SV_GMAGIC is the default for sv_setv() 7318 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games 7319 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */ 7320 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL); 7321 return sv; 7322 } 7323 7324 /* 7325 =for apidoc sv_reset 7326 7327 Underlying implementation for the C<reset> Perl function. 7328 Note that the perl-level function is vaguely deprecated. 7329 7330 =cut 7331 */ 7332 7333 void 7334 Perl_sv_reset(pTHX_ register const char *s, HV *stash) 7335 { 7336 dVAR; 7337 char todo[PERL_UCHAR_MAX+1]; 7338 7339 if (!stash) 7340 return; 7341 7342 if (!*s) { /* reset ?? searches */ 7343 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); 7344 if (mg) { 7345 const U32 count = mg->mg_len / sizeof(PMOP**); 7346 PMOP **pmp = (PMOP**) mg->mg_ptr; 7347 PMOP *const *const end = pmp + count; 7348 7349 while (pmp < end) { 7350 #ifdef USE_ITHREADS 7351 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); 7352 #else 7353 (*pmp)->op_pmflags &= ~PMf_USED; 7354 #endif 7355 ++pmp; 7356 } 7357 } 7358 return; 7359 } 7360 7361 /* reset variables */ 7362 7363 if (!HvARRAY(stash)) 7364 return; 7365 7366 Zero(todo, 256, char); 7367 while (*s) { 7368 I32 max; 7369 I32 i = (unsigned char)*s; 7370 if (s[1] == '-') { 7371 s += 2; 7372 } 7373 max = (unsigned char)*s++; 7374 for ( ; i <= max; i++) { 7375 todo[i] = 1; 7376 } 7377 for (i = 0; i <= (I32) HvMAX(stash); i++) { 7378 HE *entry; 7379 for (entry = HvARRAY(stash)[i]; 7380 entry; 7381 entry = HeNEXT(entry)) 7382 { 7383 register GV *gv; 7384 register SV *sv; 7385 7386 if (!todo[(U8)*HeKEY(entry)]) 7387 continue; 7388 gv = (GV*)HeVAL(entry); 7389 sv = GvSV(gv); 7390 if (sv) { 7391 if (SvTHINKFIRST(sv)) { 7392 if (!SvREADONLY(sv) && SvROK(sv)) 7393 sv_unref(sv); 7394 /* XXX Is this continue a bug? Why should THINKFIRST 7395 exempt us from resetting arrays and hashes? */ 7396 continue; 7397 } 7398 SvOK_off(sv); 7399 if (SvTYPE(sv) >= SVt_PV) { 7400 SvCUR_set(sv, 0); 7401 if (SvPVX_const(sv) != NULL) 7402 *SvPVX(sv) = '\0'; 7403 SvTAINT(sv); 7404 } 7405 } 7406 if (GvAV(gv)) { 7407 av_clear(GvAV(gv)); 7408 } 7409 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { 7410 #if defined(VMS) 7411 Perl_die(aTHX_ "Can't reset %%ENV on this system"); 7412 #else /* ! VMS */ 7413 hv_clear(GvHV(gv)); 7414 # if defined(USE_ENVIRON_ARRAY) 7415 if (gv == PL_envgv) 7416 my_clearenv(); 7417 # endif /* USE_ENVIRON_ARRAY */ 7418 #endif /* VMS */ 7419 } 7420 } 7421 } 7422 } 7423 } 7424 7425 /* 7426 =for apidoc sv_2io 7427 7428 Using various gambits, try to get an IO from an SV: the IO slot if its a 7429 GV; or the recursive result if we're an RV; or the IO slot of the symbol 7430 named after the PV if we're a string. 7431 7432 =cut 7433 */ 7434 7435 IO* 7436 Perl_sv_2io(pTHX_ SV *sv) 7437 { 7438 IO* io; 7439 GV* gv; 7440 7441 switch (SvTYPE(sv)) { 7442 case SVt_PVIO: 7443 io = (IO*)sv; 7444 break; 7445 case SVt_PVGV: 7446 gv = (GV*)sv; 7447 io = GvIO(gv); 7448 if (!io) 7449 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); 7450 break; 7451 default: 7452 if (!SvOK(sv)) 7453 Perl_croak(aTHX_ PL_no_usym, "filehandle"); 7454 if (SvROK(sv)) 7455 return sv_2io(SvRV(sv)); 7456 gv = gv_fetchsv(sv, 0, SVt_PVIO); 7457 if (gv) 7458 io = GvIO(gv); 7459 else 7460 io = 0; 7461 if (!io) 7462 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv)); 7463 break; 7464 } 7465 return io; 7466 } 7467 7468 /* 7469 =for apidoc sv_2cv 7470 7471 Using various gambits, try to get a CV from an SV; in addition, try if 7472 possible to set C<*st> and C<*gvp> to the stash and GV associated with it. 7473 The flags in C<lref> are passed to sv_fetchsv. 7474 7475 =cut 7476 */ 7477 7478 CV * 7479 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) 7480 { 7481 dVAR; 7482 GV *gv = NULL; 7483 CV *cv = NULL; 7484 7485 if (!sv) { 7486 *st = NULL; 7487 *gvp = NULL; 7488 return NULL; 7489 } 7490 switch (SvTYPE(sv)) { 7491 case SVt_PVCV: 7492 *st = CvSTASH(sv); 7493 *gvp = NULL; 7494 return (CV*)sv; 7495 case SVt_PVHV: 7496 case SVt_PVAV: 7497 *st = NULL; 7498 *gvp = NULL; 7499 return NULL; 7500 case SVt_PVGV: 7501 gv = (GV*)sv; 7502 *gvp = gv; 7503 *st = GvESTASH(gv); 7504 goto fix_gv; 7505 7506 default: 7507 SvGETMAGIC(sv); 7508 if (SvROK(sv)) { 7509 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ 7510 tryAMAGICunDEREF(to_cv); 7511 7512 sv = SvRV(sv); 7513 if (SvTYPE(sv) == SVt_PVCV) { 7514 cv = (CV*)sv; 7515 *gvp = NULL; 7516 *st = CvSTASH(cv); 7517 return cv; 7518 } 7519 else if(isGV(sv)) 7520 gv = (GV*)sv; 7521 else 7522 Perl_croak(aTHX_ "Not a subroutine reference"); 7523 } 7524 else if (isGV(sv)) 7525 gv = (GV*)sv; 7526 else 7527 gv = gv_fetchsv(sv, lref, SVt_PVCV); 7528 *gvp = gv; 7529 if (!gv) { 7530 *st = NULL; 7531 return NULL; 7532 } 7533 /* Some flags to gv_fetchsv mean don't really create the GV */ 7534 if (SvTYPE(gv) != SVt_PVGV) { 7535 *st = NULL; 7536 return NULL; 7537 } 7538 *st = GvESTASH(gv); 7539 fix_gv: 7540 if (lref && !GvCVu(gv)) { 7541 SV *tmpsv; 7542 ENTER; 7543 tmpsv = newSV(0); 7544 gv_efullname3(tmpsv, gv, NULL); 7545 /* XXX this is probably not what they think they're getting. 7546 * It has the same effect as "sub name;", i.e. just a forward 7547 * declaration! */ 7548 newSUB(start_subparse(FALSE, 0), 7549 newSVOP(OP_CONST, 0, tmpsv), 7550 NULL, NULL); 7551 LEAVE; 7552 if (!GvCVu(gv)) 7553 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", 7554 SVfARG(sv)); 7555 } 7556 return GvCVu(gv); 7557 } 7558 } 7559 7560 /* 7561 =for apidoc sv_true 7562 7563 Returns true if the SV has a true value by Perl's rules. 7564 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may 7565 instead use an in-line version. 7566 7567 =cut 7568 */ 7569 7570 I32 7571 Perl_sv_true(pTHX_ register SV *sv) 7572 { 7573 if (!sv) 7574 return 0; 7575 if (SvPOK(sv)) { 7576 register const XPV* const tXpv = (XPV*)SvANY(sv); 7577 if (tXpv && 7578 (tXpv->xpv_cur > 1 || 7579 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) 7580 return 1; 7581 else 7582 return 0; 7583 } 7584 else { 7585 if (SvIOK(sv)) 7586 return SvIVX(sv) != 0; 7587 else { 7588 if (SvNOK(sv)) 7589 return SvNVX(sv) != 0.0; 7590 else 7591 return sv_2bool(sv); 7592 } 7593 } 7594 } 7595 7596 /* 7597 =for apidoc sv_pvn_force 7598 7599 Get a sensible string out of the SV somehow. 7600 A private implementation of the C<SvPV_force> macro for compilers which 7601 can't cope with complex macro expressions. Always use the macro instead. 7602 7603 =for apidoc sv_pvn_force_flags 7604 7605 Get a sensible string out of the SV somehow. 7606 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if 7607 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are 7608 implemented in terms of this function. 7609 You normally want to use the various wrapper macros instead: see 7610 C<SvPV_force> and C<SvPV_force_nomg> 7611 7612 =cut 7613 */ 7614 7615 char * 7616 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) 7617 { 7618 dVAR; 7619 if (SvTHINKFIRST(sv) && !SvROK(sv)) 7620 sv_force_normal_flags(sv, 0); 7621 7622 if (SvPOK(sv)) { 7623 if (lp) 7624 *lp = SvCUR(sv); 7625 } 7626 else { 7627 char *s; 7628 STRLEN len; 7629 7630 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) { 7631 const char * const ref = sv_reftype(sv,0); 7632 if (PL_op) 7633 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", 7634 ref, OP_NAME(PL_op)); 7635 else 7636 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); 7637 } 7638 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) 7639 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), 7640 OP_NAME(PL_op)); 7641 s = sv_2pv_flags(sv, &len, flags); 7642 if (lp) 7643 *lp = len; 7644 7645 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ 7646 if (SvROK(sv)) 7647 sv_unref(sv); 7648 SvUPGRADE(sv, SVt_PV); /* Never FALSE */ 7649 SvGROW(sv, len + 1); 7650 Move(s,SvPVX(sv),len,char); 7651 SvCUR_set(sv, len); 7652 SvPVX(sv)[len] = '\0'; 7653 } 7654 if (!SvPOK(sv)) { 7655 SvPOK_on(sv); /* validate pointer */ 7656 SvTAINT(sv); 7657 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 7658 PTR2UV(sv),SvPVX_const(sv))); 7659 } 7660 } 7661 return SvPVX_mutable(sv); 7662 } 7663 7664 /* 7665 =for apidoc sv_pvbyten_force 7666 7667 The backend for the C<SvPVbytex_force> macro. Always use the macro instead. 7668 7669 =cut 7670 */ 7671 7672 char * 7673 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) 7674 { 7675 sv_pvn_force(sv,lp); 7676 sv_utf8_downgrade(sv,0); 7677 *lp = SvCUR(sv); 7678 return SvPVX(sv); 7679 } 7680 7681 /* 7682 =for apidoc sv_pvutf8n_force 7683 7684 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead. 7685 7686 =cut 7687 */ 7688 7689 char * 7690 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) 7691 { 7692 sv_pvn_force(sv,lp); 7693 sv_utf8_upgrade(sv); 7694 *lp = SvCUR(sv); 7695 return SvPVX(sv); 7696 } 7697 7698 /* 7699 =for apidoc sv_reftype 7700 7701 Returns a string describing what the SV is a reference to. 7702 7703 =cut 7704 */ 7705 7706 const char * 7707 Perl_sv_reftype(pTHX_ const SV *sv, int ob) 7708 { 7709 /* The fact that I don't need to downcast to char * everywhere, only in ?: 7710 inside return suggests a const propagation bug in g++. */ 7711 if (ob && SvOBJECT(sv)) { 7712 char * const name = HvNAME_get(SvSTASH(sv)); 7713 return name ? name : (char *) "__ANON__"; 7714 } 7715 else { 7716 switch (SvTYPE(sv)) { 7717 case SVt_NULL: 7718 case SVt_IV: 7719 case SVt_NV: 7720 case SVt_RV: 7721 case SVt_PV: 7722 case SVt_PVIV: 7723 case SVt_PVNV: 7724 case SVt_PVMG: 7725 if (SvVOK(sv)) 7726 return "VSTRING"; 7727 if (SvROK(sv)) 7728 return "REF"; 7729 else 7730 return "SCALAR"; 7731 7732 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" 7733 /* tied lvalues should appear to be 7734 * scalars for backwards compatitbility */ 7735 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') 7736 ? "SCALAR" : "LVALUE"); 7737 case SVt_PVAV: return "ARRAY"; 7738 case SVt_PVHV: return "HASH"; 7739 case SVt_PVCV: return "CODE"; 7740 case SVt_PVGV: return "GLOB"; 7741 case SVt_PVFM: return "FORMAT"; 7742 case SVt_PVIO: return "IO"; 7743 case SVt_BIND: return "BIND"; 7744 default: return "UNKNOWN"; 7745 } 7746 } 7747 } 7748 7749 /* 7750 =for apidoc sv_isobject 7751 7752 Returns a boolean indicating whether the SV is an RV pointing to a blessed 7753 object. If the SV is not an RV, or if the object is not blessed, then this 7754 will return false. 7755 7756 =cut 7757 */ 7758 7759 int 7760 Perl_sv_isobject(pTHX_ SV *sv) 7761 { 7762 if (!sv) 7763 return 0; 7764 SvGETMAGIC(sv); 7765 if (!SvROK(sv)) 7766 return 0; 7767 sv = (SV*)SvRV(sv); 7768 if (!SvOBJECT(sv)) 7769 return 0; 7770 return 1; 7771 } 7772 7773 /* 7774 =for apidoc sv_isa 7775 7776 Returns a boolean indicating whether the SV is blessed into the specified 7777 class. This does not check for subtypes; use C<sv_derived_from> to verify 7778 an inheritance relationship. 7779 7780 =cut 7781 */ 7782 7783 int 7784 Perl_sv_isa(pTHX_ SV *sv, const char *name) 7785 { 7786 const char *hvname; 7787 if (!sv) 7788 return 0; 7789 SvGETMAGIC(sv); 7790 if (!SvROK(sv)) 7791 return 0; 7792 sv = (SV*)SvRV(sv); 7793 if (!SvOBJECT(sv)) 7794 return 0; 7795 hvname = HvNAME_get(SvSTASH(sv)); 7796 if (!hvname) 7797 return 0; 7798 7799 return strEQ(hvname, name); 7800 } 7801 7802 /* 7803 =for apidoc newSVrv 7804 7805 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then 7806 it will be upgraded to one. If C<classname> is non-null then the new SV will 7807 be blessed in the specified package. The new SV is returned and its 7808 reference count is 1. 7809 7810 =cut 7811 */ 7812 7813 SV* 7814 Perl_newSVrv(pTHX_ SV *rv, const char *classname) 7815 { 7816 dVAR; 7817 SV *sv; 7818 7819 new_SV(sv); 7820 7821 SV_CHECK_THINKFIRST_COW_DROP(rv); 7822 (void)SvAMAGIC_off(rv); 7823 7824 if (SvTYPE(rv) >= SVt_PVMG) { 7825 const U32 refcnt = SvREFCNT(rv); 7826 SvREFCNT(rv) = 0; 7827 sv_clear(rv); 7828 SvFLAGS(rv) = 0; 7829 SvREFCNT(rv) = refcnt; 7830 7831 sv_upgrade(rv, SVt_RV); 7832 } else if (SvROK(rv)) { 7833 SvREFCNT_dec(SvRV(rv)); 7834 } else if (SvTYPE(rv) < SVt_RV) 7835 sv_upgrade(rv, SVt_RV); 7836 else if (SvTYPE(rv) > SVt_RV) { 7837 SvPV_free(rv); 7838 SvCUR_set(rv, 0); 7839 SvLEN_set(rv, 0); 7840 } 7841 7842 SvOK_off(rv); 7843 SvRV_set(rv, sv); 7844 SvROK_on(rv); 7845 7846 if (classname) { 7847 HV* const stash = gv_stashpv(classname, GV_ADD); 7848 (void)sv_bless(rv, stash); 7849 } 7850 return sv; 7851 } 7852 7853 /* 7854 =for apidoc sv_setref_pv 7855 7856 Copies a pointer into a new SV, optionally blessing the SV. The C<rv> 7857 argument will be upgraded to an RV. That RV will be modified to point to 7858 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed 7859 into the SV. The C<classname> argument indicates the package for the 7860 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 7861 will have a reference count of 1, and the RV will be returned. 7862 7863 Do not use with other Perl types such as HV, AV, SV, CV, because those 7864 objects will become corrupted by the pointer copy process. 7865 7866 Note that C<sv_setref_pvn> copies the string while this copies the pointer. 7867 7868 =cut 7869 */ 7870 7871 SV* 7872 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) 7873 { 7874 dVAR; 7875 if (!pv) { 7876 sv_setsv(rv, &PL_sv_undef); 7877 SvSETMAGIC(rv); 7878 } 7879 else 7880 sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); 7881 return rv; 7882 } 7883 7884 /* 7885 =for apidoc sv_setref_iv 7886 7887 Copies an integer into a new SV, optionally blessing the SV. The C<rv> 7888 argument will be upgraded to an RV. That RV will be modified to point to 7889 the new SV. The C<classname> argument indicates the package for the 7890 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 7891 will have a reference count of 1, and the RV will be returned. 7892 7893 =cut 7894 */ 7895 7896 SV* 7897 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) 7898 { 7899 sv_setiv(newSVrv(rv,classname), iv); 7900 return rv; 7901 } 7902 7903 /* 7904 =for apidoc sv_setref_uv 7905 7906 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv> 7907 argument will be upgraded to an RV. That RV will be modified to point to 7908 the new SV. The C<classname> argument indicates the package for the 7909 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 7910 will have a reference count of 1, and the RV will be returned. 7911 7912 =cut 7913 */ 7914 7915 SV* 7916 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv) 7917 { 7918 sv_setuv(newSVrv(rv,classname), uv); 7919 return rv; 7920 } 7921 7922 /* 7923 =for apidoc sv_setref_nv 7924 7925 Copies a double into a new SV, optionally blessing the SV. The C<rv> 7926 argument will be upgraded to an RV. That RV will be modified to point to 7927 the new SV. The C<classname> argument indicates the package for the 7928 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 7929 will have a reference count of 1, and the RV will be returned. 7930 7931 =cut 7932 */ 7933 7934 SV* 7935 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) 7936 { 7937 sv_setnv(newSVrv(rv,classname), nv); 7938 return rv; 7939 } 7940 7941 /* 7942 =for apidoc sv_setref_pvn 7943 7944 Copies a string into a new SV, optionally blessing the SV. The length of the 7945 string must be specified with C<n>. The C<rv> argument will be upgraded to 7946 an RV. That RV will be modified to point to the new SV. The C<classname> 7947 argument indicates the package for the blessing. Set C<classname> to 7948 C<NULL> to avoid the blessing. The new SV will have a reference count 7949 of 1, and the RV will be returned. 7950 7951 Note that C<sv_setref_pv> copies the pointer while this copies the string. 7952 7953 =cut 7954 */ 7955 7956 SV* 7957 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n) 7958 { 7959 sv_setpvn(newSVrv(rv,classname), pv, n); 7960 return rv; 7961 } 7962 7963 /* 7964 =for apidoc sv_bless 7965 7966 Blesses an SV into a specified package. The SV must be an RV. The package 7967 must be designated by its stash (see C<gv_stashpv()>). The reference count 7968 of the SV is unaffected. 7969 7970 =cut 7971 */ 7972 7973 SV* 7974 Perl_sv_bless(pTHX_ SV *sv, HV *stash) 7975 { 7976 dVAR; 7977 SV *tmpRef; 7978 if (!SvROK(sv)) 7979 Perl_croak(aTHX_ "Can't bless non-reference value"); 7980 tmpRef = SvRV(sv); 7981 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { 7982 if (SvIsCOW(tmpRef)) 7983 sv_force_normal_flags(tmpRef, 0); 7984 if (SvREADONLY(tmpRef)) 7985 Perl_croak(aTHX_ PL_no_modify); 7986 if (SvOBJECT(tmpRef)) { 7987 if (SvTYPE(tmpRef) != SVt_PVIO) 7988 --PL_sv_objcount; 7989 SvREFCNT_dec(SvSTASH(tmpRef)); 7990 } 7991 } 7992 SvOBJECT_on(tmpRef); 7993 if (SvTYPE(tmpRef) != SVt_PVIO) 7994 ++PL_sv_objcount; 7995 SvUPGRADE(tmpRef, SVt_PVMG); 7996 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash)); 7997 7998 if (Gv_AMG(stash)) 7999 SvAMAGIC_on(sv); 8000 else 8001 (void)SvAMAGIC_off(sv); 8002 8003 if(SvSMAGICAL(tmpRef)) 8004 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) 8005 mg_set(tmpRef); 8006 8007 8008 8009 return sv; 8010 } 8011 8012 /* Downgrades a PVGV to a PVMG. 8013 */ 8014 8015 STATIC void 8016 S_sv_unglob(pTHX_ SV *sv) 8017 { 8018 dVAR; 8019 void *xpvmg; 8020 HV *stash; 8021 SV * const temp = sv_newmortal(); 8022 8023 assert(SvTYPE(sv) == SVt_PVGV); 8024 SvFAKE_off(sv); 8025 gv_efullname3(temp, (GV *) sv, "*"); 8026 8027 if (GvGP(sv)) { 8028 if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) 8029 mro_method_changed_in(stash); 8030 gp_free((GV*)sv); 8031 } 8032 if (GvSTASH(sv)) { 8033 sv_del_backref((SV*)GvSTASH(sv), sv); 8034 GvSTASH(sv) = NULL; 8035 } 8036 GvMULTI_off(sv); 8037 if (GvNAME_HEK(sv)) { 8038 unshare_hek(GvNAME_HEK(sv)); 8039 } 8040 isGV_with_GP_off(sv); 8041 8042 /* need to keep SvANY(sv) in the right arena */ 8043 xpvmg = new_XPVMG(); 8044 StructCopy(SvANY(sv), xpvmg, XPVMG); 8045 del_XPVGV(SvANY(sv)); 8046 SvANY(sv) = xpvmg; 8047 8048 SvFLAGS(sv) &= ~SVTYPEMASK; 8049 SvFLAGS(sv) |= SVt_PVMG; 8050 8051 /* Intentionally not calling any local SET magic, as this isn't so much a 8052 set operation as merely an internal storage change. */ 8053 sv_setsv_flags(sv, temp, 0); 8054 } 8055 8056 /* 8057 =for apidoc sv_unref_flags 8058 8059 Unsets the RV status of the SV, and decrements the reference count of 8060 whatever was being referenced by the RV. This can almost be thought of 8061 as a reversal of C<newSVrv>. The C<cflags> argument can contain 8062 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented 8063 (otherwise the decrementing is conditional on the reference count being 8064 different from one or the reference being a readonly SV). 8065 See C<SvROK_off>. 8066 8067 =cut 8068 */ 8069 8070 void 8071 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) 8072 { 8073 SV* const target = SvRV(ref); 8074 8075 if (SvWEAKREF(ref)) { 8076 sv_del_backref(target, ref); 8077 SvWEAKREF_off(ref); 8078 SvRV_set(ref, NULL); 8079 return; 8080 } 8081 SvRV_set(ref, NULL); 8082 SvROK_off(ref); 8083 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was 8084 assigned to as BEGIN {$a = \"Foo"} will fail. */ 8085 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) 8086 SvREFCNT_dec(target); 8087 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ 8088 sv_2mortal(target); /* Schedule for freeing later */ 8089 } 8090 8091 /* 8092 =for apidoc sv_untaint 8093 8094 Untaint an SV. Use C<SvTAINTED_off> instead. 8095 =cut 8096 */ 8097 8098 void 8099 Perl_sv_untaint(pTHX_ SV *sv) 8100 { 8101 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 8102 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); 8103 if (mg) 8104 mg->mg_len &= ~1; 8105 } 8106 } 8107 8108 /* 8109 =for apidoc sv_tainted 8110 8111 Test an SV for taintedness. Use C<SvTAINTED> instead. 8112 =cut 8113 */ 8114 8115 bool 8116 Perl_sv_tainted(pTHX_ SV *sv) 8117 { 8118 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 8119 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); 8120 if (mg && (mg->mg_len & 1) ) 8121 return TRUE; 8122 } 8123 return FALSE; 8124 } 8125 8126 /* 8127 =for apidoc sv_setpviv 8128 8129 Copies an integer into the given SV, also updating its string value. 8130 Does not handle 'set' magic. See C<sv_setpviv_mg>. 8131 8132 =cut 8133 */ 8134 8135 void 8136 Perl_sv_setpviv(pTHX_ SV *sv, IV iv) 8137 { 8138 char buf[TYPE_CHARS(UV)]; 8139 char *ebuf; 8140 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); 8141 8142 sv_setpvn(sv, ptr, ebuf - ptr); 8143 } 8144 8145 /* 8146 =for apidoc sv_setpviv_mg 8147 8148 Like C<sv_setpviv>, but also handles 'set' magic. 8149 8150 =cut 8151 */ 8152 8153 void 8154 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) 8155 { 8156 sv_setpviv(sv, iv); 8157 SvSETMAGIC(sv); 8158 } 8159 8160 #if defined(PERL_IMPLICIT_CONTEXT) 8161 8162 /* pTHX_ magic can't cope with varargs, so this is a no-context 8163 * version of the main function, (which may itself be aliased to us). 8164 * Don't access this version directly. 8165 */ 8166 8167 void 8168 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) 8169 { 8170 dTHX; 8171 va_list args; 8172 va_start(args, pat); 8173 sv_vsetpvf(sv, pat, &args); 8174 va_end(args); 8175 } 8176 8177 /* pTHX_ magic can't cope with varargs, so this is a no-context 8178 * version of the main function, (which may itself be aliased to us). 8179 * Don't access this version directly. 8180 */ 8181 8182 void 8183 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) 8184 { 8185 dTHX; 8186 va_list args; 8187 va_start(args, pat); 8188 sv_vsetpvf_mg(sv, pat, &args); 8189 va_end(args); 8190 } 8191 #endif 8192 8193 /* 8194 =for apidoc sv_setpvf 8195 8196 Works like C<sv_catpvf> but copies the text into the SV instead of 8197 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>. 8198 8199 =cut 8200 */ 8201 8202 void 8203 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) 8204 { 8205 va_list args; 8206 va_start(args, pat); 8207 sv_vsetpvf(sv, pat, &args); 8208 va_end(args); 8209 } 8210 8211 /* 8212 =for apidoc sv_vsetpvf 8213 8214 Works like C<sv_vcatpvf> but copies the text into the SV instead of 8215 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>. 8216 8217 Usually used via its frontend C<sv_setpvf>. 8218 8219 =cut 8220 */ 8221 8222 void 8223 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) 8224 { 8225 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 8226 } 8227 8228 /* 8229 =for apidoc sv_setpvf_mg 8230 8231 Like C<sv_setpvf>, but also handles 'set' magic. 8232 8233 =cut 8234 */ 8235 8236 void 8237 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) 8238 { 8239 va_list args; 8240 va_start(args, pat); 8241 sv_vsetpvf_mg(sv, pat, &args); 8242 va_end(args); 8243 } 8244 8245 /* 8246 =for apidoc sv_vsetpvf_mg 8247 8248 Like C<sv_vsetpvf>, but also handles 'set' magic. 8249 8250 Usually used via its frontend C<sv_setpvf_mg>. 8251 8252 =cut 8253 */ 8254 8255 void 8256 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) 8257 { 8258 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 8259 SvSETMAGIC(sv); 8260 } 8261 8262 #if defined(PERL_IMPLICIT_CONTEXT) 8263 8264 /* pTHX_ magic can't cope with varargs, so this is a no-context 8265 * version of the main function, (which may itself be aliased to us). 8266 * Don't access this version directly. 8267 */ 8268 8269 void 8270 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) 8271 { 8272 dTHX; 8273 va_list args; 8274 va_start(args, pat); 8275 sv_vcatpvf(sv, pat, &args); 8276 va_end(args); 8277 } 8278 8279 /* pTHX_ magic can't cope with varargs, so this is a no-context 8280 * version of the main function, (which may itself be aliased to us). 8281 * Don't access this version directly. 8282 */ 8283 8284 void 8285 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) 8286 { 8287 dTHX; 8288 va_list args; 8289 va_start(args, pat); 8290 sv_vcatpvf_mg(sv, pat, &args); 8291 va_end(args); 8292 } 8293 #endif 8294 8295 /* 8296 =for apidoc sv_catpvf 8297 8298 Processes its arguments like C<sprintf> and appends the formatted 8299 output to an SV. If the appended data contains "wide" characters 8300 (including, but not limited to, SVs with a UTF-8 PV formatted with %s, 8301 and characters >255 formatted with %c), the original SV might get 8302 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See 8303 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be 8304 valid UTF-8; if the original SV was bytes, the pattern should be too. 8305 8306 =cut */ 8307 8308 void 8309 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) 8310 { 8311 va_list args; 8312 va_start(args, pat); 8313 sv_vcatpvf(sv, pat, &args); 8314 va_end(args); 8315 } 8316 8317 /* 8318 =for apidoc sv_vcatpvf 8319 8320 Processes its arguments like C<vsprintf> and appends the formatted output 8321 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>. 8322 8323 Usually used via its frontend C<sv_catpvf>. 8324 8325 =cut 8326 */ 8327 8328 void 8329 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) 8330 { 8331 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 8332 } 8333 8334 /* 8335 =for apidoc sv_catpvf_mg 8336 8337 Like C<sv_catpvf>, but also handles 'set' magic. 8338 8339 =cut 8340 */ 8341 8342 void 8343 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) 8344 { 8345 va_list args; 8346 va_start(args, pat); 8347 sv_vcatpvf_mg(sv, pat, &args); 8348 va_end(args); 8349 } 8350 8351 /* 8352 =for apidoc sv_vcatpvf_mg 8353 8354 Like C<sv_vcatpvf>, but also handles 'set' magic. 8355 8356 Usually used via its frontend C<sv_catpvf_mg>. 8357 8358 =cut 8359 */ 8360 8361 void 8362 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) 8363 { 8364 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 8365 SvSETMAGIC(sv); 8366 } 8367 8368 /* 8369 =for apidoc sv_vsetpvfn 8370 8371 Works like C<sv_vcatpvfn> but copies the text into the SV instead of 8372 appending it. 8373 8374 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>. 8375 8376 =cut 8377 */ 8378 8379 void 8380 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) 8381 { 8382 sv_setpvn(sv, "", 0); 8383 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); 8384 } 8385 8386 STATIC I32 8387 S_expect_number(pTHX_ char** pattern) 8388 { 8389 dVAR; 8390 I32 var = 0; 8391 switch (**pattern) { 8392 case '1': case '2': case '3': 8393 case '4': case '5': case '6': 8394 case '7': case '8': case '9': 8395 var = *(*pattern)++ - '0'; 8396 while (isDIGIT(**pattern)) { 8397 const I32 tmp = var * 10 + (*(*pattern)++ - '0'); 8398 if (tmp < var) 8399 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn")); 8400 var = tmp; 8401 } 8402 } 8403 return var; 8404 } 8405 8406 STATIC char * 8407 S_F0convert(NV nv, char *endbuf, STRLEN *len) 8408 { 8409 const int neg = nv < 0; 8410 UV uv; 8411 8412 if (neg) 8413 nv = -nv; 8414 if (nv < UV_MAX) { 8415 char *p = endbuf; 8416 nv += 0.5; 8417 uv = (UV)nv; 8418 if (uv & 1 && uv == nv) 8419 uv--; /* Round to even */ 8420 do { 8421 const unsigned dig = uv % 10; 8422 *--p = '0' + dig; 8423 } while (uv /= 10); 8424 if (neg) 8425 *--p = '-'; 8426 *len = endbuf - p; 8427 return p; 8428 } 8429 return NULL; 8430 } 8431 8432 8433 /* 8434 =for apidoc sv_vcatpvfn 8435 8436 Processes its arguments like C<vsprintf> and appends the formatted output 8437 to an SV. Uses an array of SVs if the C style variable argument list is 8438 missing (NULL). When running with taint checks enabled, indicates via 8439 C<maybe_tainted> if results are untrustworthy (often due to the use of 8440 locales). 8441 8442 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>. 8443 8444 =cut 8445 */ 8446 8447 8448 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ 8449 vecstr = (U8*)SvPV_const(vecsv,veclen);\ 8450 vec_utf8 = DO_UTF8(vecsv); 8451 8452 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ 8453 8454 void 8455 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) 8456 { 8457 dVAR; 8458 char *p; 8459 char *q; 8460 const char *patend; 8461 STRLEN origlen; 8462 I32 svix = 0; 8463 static const char nullstr[] = "(null)"; 8464 SV *argsv = NULL; 8465 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */ 8466 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */ 8467 SV *nsv = NULL; 8468 /* Times 4: a decimal digit takes more than 3 binary digits. 8469 * NV_DIG: mantissa takes than many decimal digits. 8470 * Plus 32: Playing safe. */ 8471 char ebuf[IV_DIG * 4 + NV_DIG + 32]; 8472 /* large enough for "%#.#f" --chip */ 8473 /* what about long double NVs? --jhi */ 8474 8475 PERL_UNUSED_ARG(maybe_tainted); 8476 8477 /* no matter what, this is a string now */ 8478 (void)SvPV_force(sv, origlen); 8479 8480 /* special-case "", "%s", and "%-p" (SVf - see below) */ 8481 if (patlen == 0) 8482 return; 8483 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { 8484 if (args) { 8485 const char * const s = va_arg(*args, char*); 8486 sv_catpv(sv, s ? s : nullstr); 8487 } 8488 else if (svix < svmax) { 8489 sv_catsv(sv, *svargs); 8490 } 8491 return; 8492 } 8493 if (args && patlen == 3 && pat[0] == '%' && 8494 pat[1] == '-' && pat[2] == 'p') { 8495 argsv = (SV*)va_arg(*args, void*); 8496 sv_catsv(sv, argsv); 8497 return; 8498 } 8499 8500 #ifndef USE_LONG_DOUBLE 8501 /* special-case "%.<number>[gf]" */ 8502 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' 8503 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { 8504 unsigned digits = 0; 8505 const char *pp; 8506 8507 pp = pat + 2; 8508 while (*pp >= '0' && *pp <= '9') 8509 digits = 10 * digits + (*pp++ - '0'); 8510 if (pp - pat == (int)patlen - 1) { 8511 NV nv; 8512 8513 if (svix < svmax) 8514 nv = SvNV(*svargs); 8515 else 8516 return; 8517 if (*pp == 'g') { 8518 /* Add check for digits != 0 because it seems that some 8519 gconverts are buggy in this case, and we don't yet have 8520 a Configure test for this. */ 8521 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { 8522 /* 0, point, slack */ 8523 Gconvert(nv, (int)digits, 0, ebuf); 8524 sv_catpv(sv, ebuf); 8525 if (*ebuf) /* May return an empty string for digits==0 */ 8526 return; 8527 } 8528 } else if (!digits) { 8529 STRLEN l; 8530 8531 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { 8532 sv_catpvn(sv, p, l); 8533 return; 8534 } 8535 } 8536 } 8537 } 8538 #endif /* !USE_LONG_DOUBLE */ 8539 8540 if (!args && svix < svmax && DO_UTF8(*svargs)) 8541 has_utf8 = TRUE; 8542 8543 patend = (char*)pat + patlen; 8544 for (p = (char*)pat; p < patend; p = q) { 8545 bool alt = FALSE; 8546 bool left = FALSE; 8547 bool vectorize = FALSE; 8548 bool vectorarg = FALSE; 8549 bool vec_utf8 = FALSE; 8550 char fill = ' '; 8551 char plus = 0; 8552 char intsize = 0; 8553 STRLEN width = 0; 8554 STRLEN zeros = 0; 8555 bool has_precis = FALSE; 8556 STRLEN precis = 0; 8557 const I32 osvix = svix; 8558 bool is_utf8 = FALSE; /* is this item utf8? */ 8559 #ifdef HAS_LDBL_SPRINTF_BUG 8560 /* This is to try to fix a bug with irix/nonstop-ux/powerux and 8561 with sfio - Allen <allens@cpan.org> */ 8562 bool fix_ldbl_sprintf_bug = FALSE; 8563 #endif 8564 8565 char esignbuf[4]; 8566 U8 utf8buf[UTF8_MAXBYTES+1]; 8567 STRLEN esignlen = 0; 8568 8569 const char *eptr = NULL; 8570 STRLEN elen = 0; 8571 SV *vecsv = NULL; 8572 const U8 *vecstr = NULL; 8573 STRLEN veclen = 0; 8574 char c = 0; 8575 int i; 8576 unsigned base = 0; 8577 IV iv = 0; 8578 UV uv = 0; 8579 /* we need a long double target in case HAS_LONG_DOUBLE but 8580 not USE_LONG_DOUBLE 8581 */ 8582 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE 8583 long double nv; 8584 #else 8585 NV nv; 8586 #endif 8587 STRLEN have; 8588 STRLEN need; 8589 STRLEN gap; 8590 const char *dotstr = "."; 8591 STRLEN dotstrlen = 1; 8592 I32 efix = 0; /* explicit format parameter index */ 8593 I32 ewix = 0; /* explicit width index */ 8594 I32 epix = 0; /* explicit precision index */ 8595 I32 evix = 0; /* explicit vector index */ 8596 bool asterisk = FALSE; 8597 8598 /* echo everything up to the next format specification */ 8599 for (q = p; q < patend && *q != '%'; ++q) ; 8600 if (q > p) { 8601 if (has_utf8 && !pat_utf8) 8602 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv); 8603 else 8604 sv_catpvn(sv, p, q - p); 8605 p = q; 8606 } 8607 if (q++ >= patend) 8608 break; 8609 8610 /* 8611 We allow format specification elements in this order: 8612 \d+\$ explicit format parameter index 8613 [-+ 0#]+ flags 8614 v|\*(\d+\$)?v vector with optional (optionally specified) arg 8615 0 flag (as above): repeated to allow "v02" 8616 \d+|\*(\d+\$)? width using optional (optionally specified) arg 8617 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg 8618 [hlqLV] size 8619 [%bcdefginopsuxDFOUX] format (mandatory) 8620 */ 8621 8622 if (args) { 8623 /* 8624 As of perl5.9.3, printf format checking is on by default. 8625 Internally, perl uses %p formats to provide an escape to 8626 some extended formatting. This block deals with those 8627 extensions: if it does not match, (char*)q is reset and 8628 the normal format processing code is used. 8629 8630 Currently defined extensions are: 8631 %p include pointer address (standard) 8632 %-p (SVf) include an SV (previously %_) 8633 %-<num>p include an SV with precision <num> 8634 %<num>p reserved for future extensions 8635 8636 Robin Barker 2005-07-14 8637 8638 %1p (VDf) removed. RMB 2007-10-19 8639 */ 8640 char* r = q; 8641 bool sv = FALSE; 8642 STRLEN n = 0; 8643 if (*q == '-') 8644 sv = *q++; 8645 n = expect_number(&q); 8646 if (*q++ == 'p') { 8647 if (sv) { /* SVf */ 8648 if (n) { 8649 precis = n; 8650 has_precis = TRUE; 8651 } 8652 argsv = (SV*)va_arg(*args, void*); 8653 eptr = SvPV_const(argsv, elen); 8654 if (DO_UTF8(argsv)) 8655 is_utf8 = TRUE; 8656 goto string; 8657 } 8658 else if (n) { 8659 if (ckWARN_d(WARN_INTERNAL)) 8660 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 8661 "internal %%<num>p might conflict with future printf extensions"); 8662 } 8663 } 8664 q = r; 8665 } 8666 8667 if ( (width = expect_number(&q)) ) { 8668 if (*q == '$') { 8669 ++q; 8670 efix = width; 8671 } else { 8672 goto gotwidth; 8673 } 8674 } 8675 8676 /* FLAGS */ 8677 8678 while (*q) { 8679 switch (*q) { 8680 case ' ': 8681 case '+': 8682 if (plus == '+' && *q == ' ') /* '+' over ' ' */ 8683 q++; 8684 else 8685 plus = *q++; 8686 continue; 8687 8688 case '-': 8689 left = TRUE; 8690 q++; 8691 continue; 8692 8693 case '0': 8694 fill = *q++; 8695 continue; 8696 8697 case '#': 8698 alt = TRUE; 8699 q++; 8700 continue; 8701 8702 default: 8703 break; 8704 } 8705 break; 8706 } 8707 8708 tryasterisk: 8709 if (*q == '*') { 8710 q++; 8711 if ( (ewix = expect_number(&q)) ) 8712 if (*q++ != '$') 8713 goto unknown; 8714 asterisk = TRUE; 8715 } 8716 if (*q == 'v') { 8717 q++; 8718 if (vectorize) 8719 goto unknown; 8720 if ((vectorarg = asterisk)) { 8721 evix = ewix; 8722 ewix = 0; 8723 asterisk = FALSE; 8724 } 8725 vectorize = TRUE; 8726 goto tryasterisk; 8727 } 8728 8729 if (!asterisk) 8730 { 8731 if( *q == '0' ) 8732 fill = *q++; 8733 width = expect_number(&q); 8734 } 8735 8736 if (vectorize) { 8737 if (vectorarg) { 8738 if (args) 8739 vecsv = va_arg(*args, SV*); 8740 else if (evix) { 8741 vecsv = (evix > 0 && evix <= svmax) 8742 ? svargs[evix-1] : &PL_sv_undef; 8743 } else { 8744 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef; 8745 } 8746 dotstr = SvPV_const(vecsv, dotstrlen); 8747 /* Keep the DO_UTF8 test *after* the SvPV call, else things go 8748 bad with tied or overloaded values that return UTF8. */ 8749 if (DO_UTF8(vecsv)) 8750 is_utf8 = TRUE; 8751 else if (has_utf8) { 8752 vecsv = sv_mortalcopy(vecsv); 8753 sv_utf8_upgrade(vecsv); 8754 dotstr = SvPV_const(vecsv, dotstrlen); 8755 is_utf8 = TRUE; 8756 } 8757 } 8758 if (args) { 8759 VECTORIZE_ARGS 8760 } 8761 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { 8762 vecsv = svargs[efix ? efix-1 : svix++]; 8763 vecstr = (U8*)SvPV_const(vecsv,veclen); 8764 vec_utf8 = DO_UTF8(vecsv); 8765 8766 /* if this is a version object, we need to convert 8767 * back into v-string notation and then let the 8768 * vectorize happen normally 8769 */ 8770 if (sv_derived_from(vecsv, "version")) { 8771 char *version = savesvpv(vecsv); 8772 if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) { 8773 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 8774 "vector argument not supported with alpha versions"); 8775 goto unknown; 8776 } 8777 vecsv = sv_newmortal(); 8778 scan_vstring(version, version + veclen, vecsv); 8779 vecstr = (U8*)SvPV_const(vecsv, veclen); 8780 vec_utf8 = DO_UTF8(vecsv); 8781 Safefree(version); 8782 } 8783 } 8784 else { 8785 vecstr = (U8*)""; 8786 veclen = 0; 8787 } 8788 } 8789 8790 if (asterisk) { 8791 if (args) 8792 i = va_arg(*args, int); 8793 else 8794 i = (ewix ? ewix <= svmax : svix < svmax) ? 8795 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; 8796 left |= (i < 0); 8797 width = (i < 0) ? -i : i; 8798 } 8799 gotwidth: 8800 8801 /* PRECISION */ 8802 8803 if (*q == '.') { 8804 q++; 8805 if (*q == '*') { 8806 q++; 8807 if ( ((epix = expect_number(&q))) && (*q++ != '$') ) 8808 goto unknown; 8809 /* XXX: todo, support specified precision parameter */ 8810 if (epix) 8811 goto unknown; 8812 if (args) 8813 i = va_arg(*args, int); 8814 else 8815 i = (ewix ? ewix <= svmax : svix < svmax) 8816 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; 8817 precis = i; 8818 has_precis = !(i < 0); 8819 } 8820 else { 8821 precis = 0; 8822 while (isDIGIT(*q)) 8823 precis = precis * 10 + (*q++ - '0'); 8824 has_precis = TRUE; 8825 } 8826 } 8827 8828 /* SIZE */ 8829 8830 switch (*q) { 8831 #ifdef WIN32 8832 case 'I': /* Ix, I32x, and I64x */ 8833 # ifdef WIN64 8834 if (q[1] == '6' && q[2] == '4') { 8835 q += 3; 8836 intsize = 'q'; 8837 break; 8838 } 8839 # endif 8840 if (q[1] == '3' && q[2] == '2') { 8841 q += 3; 8842 break; 8843 } 8844 # ifdef WIN64 8845 intsize = 'q'; 8846 # endif 8847 q++; 8848 break; 8849 #endif 8850 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) 8851 case 'L': /* Ld */ 8852 /*FALLTHROUGH*/ 8853 #ifdef HAS_QUAD 8854 case 'q': /* qd */ 8855 #endif 8856 intsize = 'q'; 8857 q++; 8858 break; 8859 #endif 8860 case 'l': 8861 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) 8862 if (*(q + 1) == 'l') { /* lld, llf */ 8863 intsize = 'q'; 8864 q += 2; 8865 break; 8866 } 8867 #endif 8868 /*FALLTHROUGH*/ 8869 case 'h': 8870 /*FALLTHROUGH*/ 8871 case 'V': 8872 intsize = *q++; 8873 break; 8874 } 8875 8876 /* CONVERSION */ 8877 8878 if (*q == '%') { 8879 eptr = q++; 8880 elen = 1; 8881 if (vectorize) { 8882 c = '%'; 8883 goto unknown; 8884 } 8885 goto string; 8886 } 8887 8888 if (!vectorize && !args) { 8889 if (efix) { 8890 const I32 i = efix-1; 8891 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef; 8892 } else { 8893 argsv = (svix >= 0 && svix < svmax) 8894 ? svargs[svix++] : &PL_sv_undef; 8895 } 8896 } 8897 8898 switch (c = *q++) { 8899 8900 /* STRINGS */ 8901 8902 case 'c': 8903 if (vectorize) 8904 goto unknown; 8905 uv = (args) ? va_arg(*args, int) : SvIV(argsv); 8906 if ((uv > 255 || 8907 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) 8908 && !IN_BYTES) { 8909 eptr = (char*)utf8buf; 8910 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; 8911 is_utf8 = TRUE; 8912 } 8913 else { 8914 c = (char)uv; 8915 eptr = &c; 8916 elen = 1; 8917 } 8918 goto string; 8919 8920 case 's': 8921 if (vectorize) 8922 goto unknown; 8923 if (args) { 8924 eptr = va_arg(*args, char*); 8925 if (eptr) 8926 #ifdef MACOS_TRADITIONAL 8927 /* On MacOS, %#s format is used for Pascal strings */ 8928 if (alt) 8929 elen = *eptr++; 8930 else 8931 #endif 8932 elen = strlen(eptr); 8933 else { 8934 eptr = (char *)nullstr; 8935 elen = sizeof nullstr - 1; 8936 } 8937 } 8938 else { 8939 eptr = SvPV_const(argsv, elen); 8940 if (DO_UTF8(argsv)) { 8941 I32 old_precis = precis; 8942 if (has_precis && precis < elen) { 8943 I32 p = precis; 8944 sv_pos_u2b(argsv, &p, 0); /* sticks at end */ 8945 precis = p; 8946 } 8947 if (width) { /* fudge width (can't fudge elen) */ 8948 if (has_precis && precis < elen) 8949 width += precis - old_precis; 8950 else 8951 width += elen - sv_len_utf8(argsv); 8952 } 8953 is_utf8 = TRUE; 8954 } 8955 } 8956 8957 string: 8958 if (has_precis && elen > precis) 8959 elen = precis; 8960 break; 8961 8962 /* INTEGERS */ 8963 8964 case 'p': 8965 if (alt || vectorize) 8966 goto unknown; 8967 uv = PTR2UV(args ? va_arg(*args, void*) : argsv); 8968 base = 16; 8969 goto integer; 8970 8971 case 'D': 8972 #ifdef IV_IS_QUAD 8973 intsize = 'q'; 8974 #else 8975 intsize = 'l'; 8976 #endif 8977 /*FALLTHROUGH*/ 8978 case 'd': 8979 case 'i': 8980 #if vdNUMBER 8981 format_vd: 8982 #endif 8983 if (vectorize) { 8984 STRLEN ulen; 8985 if (!veclen) 8986 continue; 8987 if (vec_utf8) 8988 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 8989 UTF8_ALLOW_ANYUV); 8990 else { 8991 uv = *vecstr; 8992 ulen = 1; 8993 } 8994 vecstr += ulen; 8995 veclen -= ulen; 8996 if (plus) 8997 esignbuf[esignlen++] = plus; 8998 } 8999 else if (args) { 9000 switch (intsize) { 9001 case 'h': iv = (short)va_arg(*args, int); break; 9002 case 'l': iv = va_arg(*args, long); break; 9003 case 'V': iv = va_arg(*args, IV); break; 9004 default: iv = va_arg(*args, int); break; 9005 #ifdef HAS_QUAD 9006 case 'q': iv = va_arg(*args, Quad_t); break; 9007 #endif 9008 } 9009 } 9010 else { 9011 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ 9012 switch (intsize) { 9013 case 'h': iv = (short)tiv; break; 9014 case 'l': iv = (long)tiv; break; 9015 case 'V': 9016 default: iv = tiv; break; 9017 #ifdef HAS_QUAD 9018 case 'q': iv = (Quad_t)tiv; break; 9019 #endif 9020 } 9021 } 9022 if ( !vectorize ) /* we already set uv above */ 9023 { 9024 if (iv >= 0) { 9025 uv = iv; 9026 if (plus) 9027 esignbuf[esignlen++] = plus; 9028 } 9029 else { 9030 uv = -iv; 9031 esignbuf[esignlen++] = '-'; 9032 } 9033 } 9034 base = 10; 9035 goto integer; 9036 9037 case 'U': 9038 #ifdef IV_IS_QUAD 9039 intsize = 'q'; 9040 #else 9041 intsize = 'l'; 9042 #endif 9043 /*FALLTHROUGH*/ 9044 case 'u': 9045 base = 10; 9046 goto uns_integer; 9047 9048 case 'B': 9049 case 'b': 9050 base = 2; 9051 goto uns_integer; 9052 9053 case 'O': 9054 #ifdef IV_IS_QUAD 9055 intsize = 'q'; 9056 #else 9057 intsize = 'l'; 9058 #endif 9059 /*FALLTHROUGH*/ 9060 case 'o': 9061 base = 8; 9062 goto uns_integer; 9063 9064 case 'X': 9065 case 'x': 9066 base = 16; 9067 9068 uns_integer: 9069 if (vectorize) { 9070 STRLEN ulen; 9071 vector: 9072 if (!veclen) 9073 continue; 9074 if (vec_utf8) 9075 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 9076 UTF8_ALLOW_ANYUV); 9077 else { 9078 uv = *vecstr; 9079 ulen = 1; 9080 } 9081 vecstr += ulen; 9082 veclen -= ulen; 9083 } 9084 else if (args) { 9085 switch (intsize) { 9086 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; 9087 case 'l': uv = va_arg(*args, unsigned long); break; 9088 case 'V': uv = va_arg(*args, UV); break; 9089 default: uv = va_arg(*args, unsigned); break; 9090 #ifdef HAS_QUAD 9091 case 'q': uv = va_arg(*args, Uquad_t); break; 9092 #endif 9093 } 9094 } 9095 else { 9096 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ 9097 switch (intsize) { 9098 case 'h': uv = (unsigned short)tuv; break; 9099 case 'l': uv = (unsigned long)tuv; break; 9100 case 'V': 9101 default: uv = tuv; break; 9102 #ifdef HAS_QUAD 9103 case 'q': uv = (Uquad_t)tuv; break; 9104 #endif 9105 } 9106 } 9107 9108 integer: 9109 { 9110 char *ptr = ebuf + sizeof ebuf; 9111 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ 9112 zeros = 0; 9113 9114 switch (base) { 9115 unsigned dig; 9116 case 16: 9117 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); 9118 do { 9119 dig = uv & 15; 9120 *--ptr = p[dig]; 9121 } while (uv >>= 4); 9122 if (tempalt) { 9123 esignbuf[esignlen++] = '0'; 9124 esignbuf[esignlen++] = c; /* 'x' or 'X' */ 9125 } 9126 break; 9127 case 8: 9128 do { 9129 dig = uv & 7; 9130 *--ptr = '0' + dig; 9131 } while (uv >>= 3); 9132 if (alt && *ptr != '0') 9133 *--ptr = '0'; 9134 break; 9135 case 2: 9136 do { 9137 dig = uv & 1; 9138 *--ptr = '0' + dig; 9139 } while (uv >>= 1); 9140 if (tempalt) { 9141 esignbuf[esignlen++] = '0'; 9142 esignbuf[esignlen++] = c; 9143 } 9144 break; 9145 default: /* it had better be ten or less */ 9146 do { 9147 dig = uv % base; 9148 *--ptr = '0' + dig; 9149 } while (uv /= base); 9150 break; 9151 } 9152 elen = (ebuf + sizeof ebuf) - ptr; 9153 eptr = ptr; 9154 if (has_precis) { 9155 if (precis > elen) 9156 zeros = precis - elen; 9157 else if (precis == 0 && elen == 1 && *eptr == '0' 9158 && !(base == 8 && alt)) /* "%#.0o" prints "0" */ 9159 elen = 0; 9160 9161 /* a precision nullifies the 0 flag. */ 9162 if (fill == '0') 9163 fill = ' '; 9164 } 9165 } 9166 break; 9167 9168 /* FLOATING POINT */ 9169 9170 case 'F': 9171 c = 'f'; /* maybe %F isn't supported here */ 9172 /*FALLTHROUGH*/ 9173 case 'e': case 'E': 9174 case 'f': 9175 case 'g': case 'G': 9176 if (vectorize) 9177 goto unknown; 9178 9179 /* This is evil, but floating point is even more evil */ 9180 9181 /* for SV-style calling, we can only get NV 9182 for C-style calling, we assume %f is double; 9183 for simplicity we allow any of %Lf, %llf, %qf for long double 9184 */ 9185 switch (intsize) { 9186 case 'V': 9187 #if defined(USE_LONG_DOUBLE) 9188 intsize = 'q'; 9189 #endif 9190 break; 9191 /* [perl #20339] - we should accept and ignore %lf rather than die */ 9192 case 'l': 9193 /*FALLTHROUGH*/ 9194 default: 9195 #if defined(USE_LONG_DOUBLE) 9196 intsize = args ? 0 : 'q'; 9197 #endif 9198 break; 9199 case 'q': 9200 #if defined(HAS_LONG_DOUBLE) 9201 break; 9202 #else 9203 /*FALLTHROUGH*/ 9204 #endif 9205 case 'h': 9206 goto unknown; 9207 } 9208 9209 /* now we need (long double) if intsize == 'q', else (double) */ 9210 nv = (args) ? 9211 #if LONG_DOUBLESIZE > DOUBLESIZE 9212 intsize == 'q' ? 9213 va_arg(*args, long double) : 9214 va_arg(*args, double) 9215 #else 9216 va_arg(*args, double) 9217 #endif 9218 : SvNV(argsv); 9219 9220 need = 0; 9221 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything 9222 else. frexp() has some unspecified behaviour for those three */ 9223 if (c != 'e' && c != 'E' && (nv * 0) == 0) { 9224 i = PERL_INT_MIN; 9225 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this 9226 will cast our (long double) to (double) */ 9227 (void)Perl_frexp(nv, &i); 9228 if (i == PERL_INT_MIN) 9229 Perl_die(aTHX_ "panic: frexp"); 9230 if (i > 0) 9231 need = BIT_DIGITS(i); 9232 } 9233 need += has_precis ? precis : 6; /* known default */ 9234 9235 if (need < width) 9236 need = width; 9237 9238 #ifdef HAS_LDBL_SPRINTF_BUG 9239 /* This is to try to fix a bug with irix/nonstop-ux/powerux and 9240 with sfio - Allen <allens@cpan.org> */ 9241 9242 # ifdef DBL_MAX 9243 # define MY_DBL_MAX DBL_MAX 9244 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ 9245 # if DOUBLESIZE >= 8 9246 # define MY_DBL_MAX 1.7976931348623157E+308L 9247 # else 9248 # define MY_DBL_MAX 3.40282347E+38L 9249 # endif 9250 # endif 9251 9252 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */ 9253 # define MY_DBL_MAX_BUG 1L 9254 # else 9255 # define MY_DBL_MAX_BUG MY_DBL_MAX 9256 # endif 9257 9258 # ifdef DBL_MIN 9259 # define MY_DBL_MIN DBL_MIN 9260 # else /* XXX guessing! -Allen */ 9261 # if DOUBLESIZE >= 8 9262 # define MY_DBL_MIN 2.2250738585072014E-308L 9263 # else 9264 # define MY_DBL_MIN 1.17549435E-38L 9265 # endif 9266 # endif 9267 9268 if ((intsize == 'q') && (c == 'f') && 9269 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && 9270 (need < DBL_DIG)) { 9271 /* it's going to be short enough that 9272 * long double precision is not needed */ 9273 9274 if ((nv <= 0L) && (nv >= -0L)) 9275 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ 9276 else { 9277 /* would use Perl_fp_class as a double-check but not 9278 * functional on IRIX - see perl.h comments */ 9279 9280 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { 9281 /* It's within the range that a double can represent */ 9282 #if defined(DBL_MAX) && !defined(DBL_MIN) 9283 if ((nv >= ((long double)1/DBL_MAX)) || 9284 (nv <= (-(long double)1/DBL_MAX))) 9285 #endif 9286 fix_ldbl_sprintf_bug = TRUE; 9287 } 9288 } 9289 if (fix_ldbl_sprintf_bug == TRUE) { 9290 double temp; 9291 9292 intsize = 0; 9293 temp = (double)nv; 9294 nv = (NV)temp; 9295 } 9296 } 9297 9298 # undef MY_DBL_MAX 9299 # undef MY_DBL_MAX_BUG 9300 # undef MY_DBL_MIN 9301 9302 #endif /* HAS_LDBL_SPRINTF_BUG */ 9303 9304 need += 20; /* fudge factor */ 9305 if (PL_efloatsize < need) { 9306 Safefree(PL_efloatbuf); 9307 PL_efloatsize = need + 20; /* more fudge */ 9308 Newx(PL_efloatbuf, PL_efloatsize, char); 9309 PL_efloatbuf[0] = '\0'; 9310 } 9311 9312 if ( !(width || left || plus || alt) && fill != '0' 9313 && has_precis && intsize != 'q' ) { /* Shortcuts */ 9314 /* See earlier comment about buggy Gconvert when digits, 9315 aka precis is 0 */ 9316 if ( c == 'g' && precis) { 9317 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); 9318 /* May return an empty string for digits==0 */ 9319 if (*PL_efloatbuf) { 9320 elen = strlen(PL_efloatbuf); 9321 goto float_converted; 9322 } 9323 } else if ( c == 'f' && !precis) { 9324 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) 9325 break; 9326 } 9327 } 9328 { 9329 char *ptr = ebuf + sizeof ebuf; 9330 *--ptr = '\0'; 9331 *--ptr = c; 9332 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ 9333 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) 9334 if (intsize == 'q') { 9335 /* Copy the one or more characters in a long double 9336 * format before the 'base' ([efgEFG]) character to 9337 * the format string. */ 9338 static char const prifldbl[] = PERL_PRIfldbl; 9339 char const *p = prifldbl + sizeof(prifldbl) - 3; 9340 while (p >= prifldbl) { *--ptr = *p--; } 9341 } 9342 #endif 9343 if (has_precis) { 9344 base = precis; 9345 do { *--ptr = '0' + (base % 10); } while (base /= 10); 9346 *--ptr = '.'; 9347 } 9348 if (width) { 9349 base = width; 9350 do { *--ptr = '0' + (base % 10); } while (base /= 10); 9351 } 9352 if (fill == '0') 9353 *--ptr = fill; 9354 if (left) 9355 *--ptr = '-'; 9356 if (plus) 9357 *--ptr = plus; 9358 if (alt) 9359 *--ptr = '#'; 9360 *--ptr = '%'; 9361 9362 /* No taint. Otherwise we are in the strange situation 9363 * where printf() taints but print($float) doesn't. 9364 * --jhi */ 9365 #if defined(HAS_LONG_DOUBLE) 9366 elen = ((intsize == 'q') 9367 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) 9368 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); 9369 #else 9370 elen = my_sprintf(PL_efloatbuf, ptr, nv); 9371 #endif 9372 } 9373 float_converted: 9374 eptr = PL_efloatbuf; 9375 break; 9376 9377 /* SPECIAL */ 9378 9379 case 'n': 9380 if (vectorize) 9381 goto unknown; 9382 i = SvCUR(sv) - origlen; 9383 if (args) { 9384 switch (intsize) { 9385 case 'h': *(va_arg(*args, short*)) = i; break; 9386 default: *(va_arg(*args, int*)) = i; break; 9387 case 'l': *(va_arg(*args, long*)) = i; break; 9388 case 'V': *(va_arg(*args, IV*)) = i; break; 9389 #ifdef HAS_QUAD 9390 case 'q': *(va_arg(*args, Quad_t*)) = i; break; 9391 #endif 9392 } 9393 } 9394 else 9395 sv_setuv_mg(argsv, (UV)i); 9396 continue; /* not "break" */ 9397 9398 /* UNKNOWN */ 9399 9400 default: 9401 unknown: 9402 if (!args 9403 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) 9404 && ckWARN(WARN_PRINTF)) 9405 { 9406 SV * const msg = sv_newmortal(); 9407 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", 9408 (PL_op->op_type == OP_PRTF) ? "" : "s"); 9409 if (c) { 9410 if (isPRINT(c)) 9411 Perl_sv_catpvf(aTHX_ msg, 9412 "\"%%%c\"", c & 0xFF); 9413 else 9414 Perl_sv_catpvf(aTHX_ msg, 9415 "\"%%\\%03"UVof"\"", 9416 (UV)c & 0xFF); 9417 } else 9418 sv_catpvs(msg, "end of string"); 9419 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ 9420 } 9421 9422 /* output mangled stuff ... */ 9423 if (c == '\0') 9424 --q; 9425 eptr = p; 9426 elen = q - p; 9427 9428 /* ... right here, because formatting flags should not apply */ 9429 SvGROW(sv, SvCUR(sv) + elen + 1); 9430 p = SvEND(sv); 9431 Copy(eptr, p, elen, char); 9432 p += elen; 9433 *p = '\0'; 9434 SvCUR_set(sv, p - SvPVX_const(sv)); 9435 svix = osvix; 9436 continue; /* not "break" */ 9437 } 9438 9439 if (is_utf8 != has_utf8) { 9440 if (is_utf8) { 9441 if (SvCUR(sv)) 9442 sv_utf8_upgrade(sv); 9443 } 9444 else { 9445 const STRLEN old_elen = elen; 9446 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); 9447 sv_utf8_upgrade(nsv); 9448 eptr = SvPVX_const(nsv); 9449 elen = SvCUR(nsv); 9450 9451 if (width) { /* fudge width (can't fudge elen) */ 9452 width += elen - old_elen; 9453 } 9454 is_utf8 = TRUE; 9455 } 9456 } 9457 9458 have = esignlen + zeros + elen; 9459 if (have < zeros) 9460 Perl_croak_nocontext(PL_memory_wrap); 9461 9462 need = (have > width ? have : width); 9463 gap = need - have; 9464 9465 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) 9466 Perl_croak_nocontext(PL_memory_wrap); 9467 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); 9468 p = SvEND(sv); 9469 if (esignlen && fill == '0') { 9470 int i; 9471 for (i = 0; i < (int)esignlen; i++) 9472 *p++ = esignbuf[i]; 9473 } 9474 if (gap && !left) { 9475 memset(p, fill, gap); 9476 p += gap; 9477 } 9478 if (esignlen && fill != '0') { 9479 int i; 9480 for (i = 0; i < (int)esignlen; i++) 9481 *p++ = esignbuf[i]; 9482 } 9483 if (zeros) { 9484 int i; 9485 for (i = zeros; i; i--) 9486 *p++ = '0'; 9487 } 9488 if (elen) { 9489 Copy(eptr, p, elen, char); 9490 p += elen; 9491 } 9492 if (gap && left) { 9493 memset(p, ' ', gap); 9494 p += gap; 9495 } 9496 if (vectorize) { 9497 if (veclen) { 9498 Copy(dotstr, p, dotstrlen, char); 9499 p += dotstrlen; 9500 } 9501 else 9502 vectorize = FALSE; /* done iterating over vecstr */ 9503 } 9504 if (is_utf8) 9505 has_utf8 = TRUE; 9506 if (has_utf8) 9507 SvUTF8_on(sv); 9508 *p = '\0'; 9509 SvCUR_set(sv, p - SvPVX_const(sv)); 9510 if (vectorize) { 9511 esignlen = 0; 9512 goto vector; 9513 } 9514 } 9515 } 9516 9517 /* ========================================================================= 9518 9519 =head1 Cloning an interpreter 9520 9521 All the macros and functions in this section are for the private use of 9522 the main function, perl_clone(). 9523 9524 The foo_dup() functions make an exact copy of an existing foo thingy. 9525 During the course of a cloning, a hash table is used to map old addresses 9526 to new addresses. The table is created and manipulated with the 9527 ptr_table_* functions. 9528 9529 =cut 9530 9531 ============================================================================*/ 9532 9533 9534 #if defined(USE_ITHREADS) 9535 9536 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */ 9537 #ifndef GpREFCNT_inc 9538 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) 9539 #endif 9540 9541 9542 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact 9543 that currently av_dup, gv_dup and hv_dup are the same as sv_dup. 9544 If this changes, please unmerge ss_dup. */ 9545 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) 9546 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) 9547 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t) 9548 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t)) 9549 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t) 9550 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t)) 9551 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t) 9552 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t)) 9553 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t) 9554 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t)) 9555 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t) 9556 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t)) 9557 #define SAVEPV(p) ((p) ? savepv(p) : NULL) 9558 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) 9559 9560 /* clone a parser */ 9561 9562 yy_parser * 9563 Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) 9564 { 9565 yy_parser *parser; 9566 9567 if (!proto) 9568 return NULL; 9569 9570 /* look for it in the table first */ 9571 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); 9572 if (parser) 9573 return parser; 9574 9575 /* create anew and remember what it is */ 9576 Newxz(parser, 1, yy_parser); 9577 ptr_table_store(PL_ptr_table, proto, parser); 9578 9579 parser->yyerrstatus = 0; 9580 parser->yychar = YYEMPTY; /* Cause a token to be read. */ 9581 9582 /* XXX these not yet duped */ 9583 parser->old_parser = NULL; 9584 parser->stack = NULL; 9585 parser->ps = NULL; 9586 parser->stack_size = 0; 9587 /* XXX parser->stack->state = 0; */ 9588 9589 /* XXX eventually, just Copy() most of the parser struct ? */ 9590 9591 parser->lex_brackets = proto->lex_brackets; 9592 parser->lex_casemods = proto->lex_casemods; 9593 parser->lex_brackstack = savepvn(proto->lex_brackstack, 9594 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); 9595 parser->lex_casestack = savepvn(proto->lex_casestack, 9596 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); 9597 parser->lex_defer = proto->lex_defer; 9598 parser->lex_dojoin = proto->lex_dojoin; 9599 parser->lex_expect = proto->lex_expect; 9600 parser->lex_formbrack = proto->lex_formbrack; 9601 parser->lex_inpat = proto->lex_inpat; 9602 parser->lex_inwhat = proto->lex_inwhat; 9603 parser->lex_op = proto->lex_op; 9604 parser->lex_repl = sv_dup_inc(proto->lex_repl, param); 9605 parser->lex_starts = proto->lex_starts; 9606 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param); 9607 parser->multi_close = proto->multi_close; 9608 parser->multi_open = proto->multi_open; 9609 parser->multi_start = proto->multi_start; 9610 parser->multi_end = proto->multi_end; 9611 parser->pending_ident = proto->pending_ident; 9612 parser->preambled = proto->preambled; 9613 parser->sublex_info = proto->sublex_info; /* XXX not quite right */ 9614 parser->linestr = sv_dup_inc(proto->linestr, param); 9615 parser->expect = proto->expect; 9616 parser->copline = proto->copline; 9617 parser->last_lop_op = proto->last_lop_op; 9618 parser->lex_state = proto->lex_state; 9619 parser->rsfp = fp_dup(proto->rsfp, '<', param); 9620 /* rsfp_filters entries have fake IoDIRP() */ 9621 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); 9622 parser->in_my = proto->in_my; 9623 parser->in_my_stash = hv_dup(proto->in_my_stash, param); 9624 parser->error_count = proto->error_count; 9625 9626 9627 parser->linestr = sv_dup_inc(proto->linestr, param); 9628 9629 { 9630 char * const ols = SvPVX(proto->linestr); 9631 char * const ls = SvPVX(parser->linestr); 9632 9633 parser->bufptr = ls + (proto->bufptr >= ols ? 9634 proto->bufptr - ols : 0); 9635 parser->oldbufptr = ls + (proto->oldbufptr >= ols ? 9636 proto->oldbufptr - ols : 0); 9637 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? 9638 proto->oldoldbufptr - ols : 0); 9639 parser->linestart = ls + (proto->linestart >= ols ? 9640 proto->linestart - ols : 0); 9641 parser->last_uni = ls + (proto->last_uni >= ols ? 9642 proto->last_uni - ols : 0); 9643 parser->last_lop = ls + (proto->last_lop >= ols ? 9644 proto->last_lop - ols : 0); 9645 9646 parser->bufend = ls + SvCUR(parser->linestr); 9647 } 9648 9649 Copy(proto->tokenbuf, parser->tokenbuf, 256, char); 9650 9651 9652 #ifdef PERL_MAD 9653 parser->endwhite = proto->endwhite; 9654 parser->faketokens = proto->faketokens; 9655 parser->lasttoke = proto->lasttoke; 9656 parser->nextwhite = proto->nextwhite; 9657 parser->realtokenstart = proto->realtokenstart; 9658 parser->skipwhite = proto->skipwhite; 9659 parser->thisclose = proto->thisclose; 9660 parser->thismad = proto->thismad; 9661 parser->thisopen = proto->thisopen; 9662 parser->thisstuff = proto->thisstuff; 9663 parser->thistoken = proto->thistoken; 9664 parser->thiswhite = proto->thiswhite; 9665 9666 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE); 9667 parser->curforce = proto->curforce; 9668 #else 9669 Copy(proto->nextval, parser->nextval, 5, YYSTYPE); 9670 Copy(proto->nexttype, parser->nexttype, 5, I32); 9671 parser->nexttoke = proto->nexttoke; 9672 #endif 9673 return parser; 9674 } 9675 9676 9677 /* duplicate a file handle */ 9678 9679 PerlIO * 9680 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) 9681 { 9682 PerlIO *ret; 9683 9684 PERL_UNUSED_ARG(type); 9685 9686 if (!fp) 9687 return (PerlIO*)NULL; 9688 9689 /* look for it in the table first */ 9690 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); 9691 if (ret) 9692 return ret; 9693 9694 /* create anew and remember what it is */ 9695 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); 9696 ptr_table_store(PL_ptr_table, fp, ret); 9697 return ret; 9698 } 9699 9700 /* duplicate a directory handle */ 9701 9702 DIR * 9703 Perl_dirp_dup(pTHX_ DIR *dp) 9704 { 9705 PERL_UNUSED_CONTEXT; 9706 if (!dp) 9707 return (DIR*)NULL; 9708 /* XXX TODO */ 9709 return dp; 9710 } 9711 9712 /* duplicate a typeglob */ 9713 9714 GP * 9715 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) 9716 { 9717 GP *ret; 9718 9719 if (!gp) 9720 return (GP*)NULL; 9721 /* look for it in the table first */ 9722 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); 9723 if (ret) 9724 return ret; 9725 9726 /* create anew and remember what it is */ 9727 Newxz(ret, 1, GP); 9728 ptr_table_store(PL_ptr_table, gp, ret); 9729 9730 /* clone */ 9731 ret->gp_refcnt = 0; /* must be before any other dups! */ 9732 ret->gp_sv = sv_dup_inc(gp->gp_sv, param); 9733 ret->gp_io = io_dup_inc(gp->gp_io, param); 9734 ret->gp_form = cv_dup_inc(gp->gp_form, param); 9735 ret->gp_av = av_dup_inc(gp->gp_av, param); 9736 ret->gp_hv = hv_dup_inc(gp->gp_hv, param); 9737 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ 9738 ret->gp_cv = cv_dup_inc(gp->gp_cv, param); 9739 ret->gp_cvgen = gp->gp_cvgen; 9740 ret->gp_line = gp->gp_line; 9741 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param); 9742 return ret; 9743 } 9744 9745 /* duplicate a chain of magic */ 9746 9747 MAGIC * 9748 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) 9749 { 9750 MAGIC *mgprev = (MAGIC*)NULL; 9751 MAGIC *mgret; 9752 if (!mg) 9753 return (MAGIC*)NULL; 9754 /* look for it in the table first */ 9755 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg); 9756 if (mgret) 9757 return mgret; 9758 9759 for (; mg; mg = mg->mg_moremagic) { 9760 MAGIC *nmg; 9761 Newxz(nmg, 1, MAGIC); 9762 if (mgprev) 9763 mgprev->mg_moremagic = nmg; 9764 else 9765 mgret = nmg; 9766 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ 9767 nmg->mg_private = mg->mg_private; 9768 nmg->mg_type = mg->mg_type; 9769 nmg->mg_flags = mg->mg_flags; 9770 if (mg->mg_type == PERL_MAGIC_qr) { 9771 nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); 9772 } 9773 else if(mg->mg_type == PERL_MAGIC_backref) { 9774 /* The backref AV has its reference count deliberately bumped by 9775 1. */ 9776 nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param)); 9777 } 9778 else { 9779 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) 9780 ? sv_dup_inc(mg->mg_obj, param) 9781 : sv_dup(mg->mg_obj, param); 9782 } 9783 nmg->mg_len = mg->mg_len; 9784 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ 9785 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 9786 if (mg->mg_len > 0) { 9787 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); 9788 if (mg->mg_type == PERL_MAGIC_overload_table && 9789 AMT_AMAGIC((AMT*)mg->mg_ptr)) 9790 { 9791 const AMT * const amtp = (AMT*)mg->mg_ptr; 9792 AMT * const namtp = (AMT*)nmg->mg_ptr; 9793 I32 i; 9794 for (i = 1; i < NofAMmeth; i++) { 9795 namtp->table[i] = cv_dup_inc(amtp->table[i], param); 9796 } 9797 } 9798 } 9799 else if (mg->mg_len == HEf_SVKEY) 9800 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param); 9801 } 9802 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) { 9803 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param); 9804 } 9805 mgprev = nmg; 9806 } 9807 return mgret; 9808 } 9809 9810 #endif /* USE_ITHREADS */ 9811 9812 /* create a new pointer-mapping table */ 9813 9814 PTR_TBL_t * 9815 Perl_ptr_table_new(pTHX) 9816 { 9817 PTR_TBL_t *tbl; 9818 PERL_UNUSED_CONTEXT; 9819 9820 Newxz(tbl, 1, PTR_TBL_t); 9821 tbl->tbl_max = 511; 9822 tbl->tbl_items = 0; 9823 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); 9824 return tbl; 9825 } 9826 9827 #define PTR_TABLE_HASH(ptr) \ 9828 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) 9829 9830 /* 9831 we use the PTE_SVSLOT 'reservation' made above, both here (in the 9832 following define) and at call to new_body_inline made below in 9833 Perl_ptr_table_store() 9834 */ 9835 9836 #define del_pte(p) del_body_type(p, PTE_SVSLOT) 9837 9838 /* map an existing pointer using a table */ 9839 9840 STATIC PTR_TBL_ENT_t * 9841 S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) { 9842 PTR_TBL_ENT_t *tblent; 9843 const UV hash = PTR_TABLE_HASH(sv); 9844 assert(tbl); 9845 tblent = tbl->tbl_ary[hash & tbl->tbl_max]; 9846 for (; tblent; tblent = tblent->next) { 9847 if (tblent->oldval == sv) 9848 return tblent; 9849 } 9850 return NULL; 9851 } 9852 9853 void * 9854 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) 9855 { 9856 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv); 9857 PERL_UNUSED_CONTEXT; 9858 return tblent ? tblent->newval : NULL; 9859 } 9860 9861 /* add a new entry to a pointer-mapping table */ 9862 9863 void 9864 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) 9865 { 9866 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); 9867 PERL_UNUSED_CONTEXT; 9868 9869 if (tblent) { 9870 tblent->newval = newsv; 9871 } else { 9872 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; 9873 9874 new_body_inline(tblent, PTE_SVSLOT); 9875 9876 tblent->oldval = oldsv; 9877 tblent->newval = newsv; 9878 tblent->next = tbl->tbl_ary[entry]; 9879 tbl->tbl_ary[entry] = tblent; 9880 tbl->tbl_items++; 9881 if (tblent->next && tbl->tbl_items > tbl->tbl_max) 9882 ptr_table_split(tbl); 9883 } 9884 } 9885 9886 /* double the hash bucket size of an existing ptr table */ 9887 9888 void 9889 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) 9890 { 9891 PTR_TBL_ENT_t **ary = tbl->tbl_ary; 9892 const UV oldsize = tbl->tbl_max + 1; 9893 UV newsize = oldsize * 2; 9894 UV i; 9895 PERL_UNUSED_CONTEXT; 9896 9897 Renew(ary, newsize, PTR_TBL_ENT_t*); 9898 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); 9899 tbl->tbl_max = --newsize; 9900 tbl->tbl_ary = ary; 9901 for (i=0; i < oldsize; i++, ary++) { 9902 PTR_TBL_ENT_t **curentp, **entp, *ent; 9903 if (!*ary) 9904 continue; 9905 curentp = ary + oldsize; 9906 for (entp = ary, ent = *ary; ent; ent = *entp) { 9907 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { 9908 *entp = ent->next; 9909 ent->next = *curentp; 9910 *curentp = ent; 9911 continue; 9912 } 9913 else 9914 entp = &ent->next; 9915 } 9916 } 9917 } 9918 9919 /* remove all the entries from a ptr table */ 9920 9921 void 9922 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) 9923 { 9924 if (tbl && tbl->tbl_items) { 9925 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; 9926 UV riter = tbl->tbl_max; 9927 9928 do { 9929 PTR_TBL_ENT_t *entry = array[riter]; 9930 9931 while (entry) { 9932 PTR_TBL_ENT_t * const oentry = entry; 9933 entry = entry->next; 9934 del_pte(oentry); 9935 } 9936 } while (riter--); 9937 9938 tbl->tbl_items = 0; 9939 } 9940 } 9941 9942 /* clear and free a ptr table */ 9943 9944 void 9945 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) 9946 { 9947 if (!tbl) { 9948 return; 9949 } 9950 ptr_table_clear(tbl); 9951 Safefree(tbl->tbl_ary); 9952 Safefree(tbl); 9953 } 9954 9955 #if defined(USE_ITHREADS) 9956 9957 void 9958 Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) 9959 { 9960 if (SvROK(sstr)) { 9961 SvRV_set(dstr, SvWEAKREF(sstr) 9962 ? sv_dup(SvRV(sstr), param) 9963 : sv_dup_inc(SvRV(sstr), param)); 9964 9965 } 9966 else if (SvPVX_const(sstr)) { 9967 /* Has something there */ 9968 if (SvLEN(sstr)) { 9969 /* Normal PV - clone whole allocated space */ 9970 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1)); 9971 if (SvREADONLY(sstr) && SvFAKE(sstr)) { 9972 /* Not that normal - actually sstr is copy on write. 9973 But we are a true, independant SV, so: */ 9974 SvREADONLY_off(dstr); 9975 SvFAKE_off(dstr); 9976 } 9977 } 9978 else { 9979 /* Special case - not normally malloced for some reason */ 9980 if (isGV_with_GP(sstr)) { 9981 /* Don't need to do anything here. */ 9982 } 9983 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) { 9984 /* A "shared" PV - clone it as "shared" PV */ 9985 SvPV_set(dstr, 9986 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), 9987 param))); 9988 } 9989 else { 9990 /* Some other special case - random pointer */ 9991 SvPV_set(dstr, SvPVX(sstr)); 9992 } 9993 } 9994 } 9995 else { 9996 /* Copy the NULL */ 9997 if (SvTYPE(dstr) == SVt_RV) 9998 SvRV_set(dstr, NULL); 9999 else 10000 SvPV_set(dstr, NULL); 10001 } 10002 } 10003 10004 /* duplicate an SV of any type (including AV, HV etc) */ 10005 10006 SV * 10007 Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) 10008 { 10009 dVAR; 10010 SV *dstr; 10011 10012 if (!sstr || SvTYPE(sstr) == SVTYPEMASK) 10013 return NULL; 10014 /* look for it in the table first */ 10015 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); 10016 if (dstr) 10017 return dstr; 10018 10019 if(param->flags & CLONEf_JOIN_IN) { 10020 /** We are joining here so we don't want do clone 10021 something that is bad **/ 10022 if (SvTYPE(sstr) == SVt_PVHV) { 10023 const HEK * const hvname = HvNAME_HEK(sstr); 10024 if (hvname) 10025 /** don't clone stashes if they already exist **/ 10026 return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0); 10027 } 10028 } 10029 10030 /* create anew and remember what it is */ 10031 new_SV(dstr); 10032 10033 #ifdef DEBUG_LEAKING_SCALARS 10034 dstr->sv_debug_optype = sstr->sv_debug_optype; 10035 dstr->sv_debug_line = sstr->sv_debug_line; 10036 dstr->sv_debug_inpad = sstr->sv_debug_inpad; 10037 dstr->sv_debug_cloned = 1; 10038 dstr->sv_debug_file = savepv(sstr->sv_debug_file); 10039 #endif 10040 10041 ptr_table_store(PL_ptr_table, sstr, dstr); 10042 10043 /* clone */ 10044 SvFLAGS(dstr) = SvFLAGS(sstr); 10045 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ 10046 SvREFCNT(dstr) = 0; /* must be before any other dups! */ 10047 10048 #ifdef DEBUGGING 10049 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) 10050 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", 10051 (void*)PL_watch_pvx, SvPVX_const(sstr)); 10052 #endif 10053 10054 /* don't clone objects whose class has asked us not to */ 10055 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { 10056 SvFLAGS(dstr) = 0; 10057 return dstr; 10058 } 10059 10060 switch (SvTYPE(sstr)) { 10061 case SVt_NULL: 10062 SvANY(dstr) = NULL; 10063 break; 10064 case SVt_IV: 10065 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 10066 SvIV_set(dstr, SvIVX(sstr)); 10067 break; 10068 case SVt_NV: 10069 SvANY(dstr) = new_XNV(); 10070 SvNV_set(dstr, SvNVX(sstr)); 10071 break; 10072 case SVt_RV: 10073 SvANY(dstr) = &(dstr->sv_u.svu_rv); 10074 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 10075 break; 10076 /* case SVt_BIND: */ 10077 default: 10078 { 10079 /* These are all the types that need complex bodies allocating. */ 10080 void *new_body; 10081 const svtype sv_type = SvTYPE(sstr); 10082 const struct body_details *const sv_type_details 10083 = bodies_by_type + sv_type; 10084 10085 switch (sv_type) { 10086 default: 10087 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); 10088 break; 10089 10090 case SVt_PVGV: 10091 if (GvUNIQUE((GV*)sstr)) { 10092 NOOP; /* Do sharing here, and fall through */ 10093 } 10094 case SVt_PVIO: 10095 case SVt_PVFM: 10096 case SVt_PVHV: 10097 case SVt_PVAV: 10098 case SVt_PVCV: 10099 case SVt_PVLV: 10100 case SVt_PVMG: 10101 case SVt_PVNV: 10102 case SVt_PVIV: 10103 case SVt_PV: 10104 assert(sv_type_details->body_size); 10105 if (sv_type_details->arena) { 10106 new_body_inline(new_body, sv_type); 10107 new_body 10108 = (void*)((char*)new_body - sv_type_details->offset); 10109 } else { 10110 new_body = new_NOARENA(sv_type_details); 10111 } 10112 } 10113 assert(new_body); 10114 SvANY(dstr) = new_body; 10115 10116 #ifndef PURIFY 10117 Copy(((char*)SvANY(sstr)) + sv_type_details->offset, 10118 ((char*)SvANY(dstr)) + sv_type_details->offset, 10119 sv_type_details->copy, char); 10120 #else 10121 Copy(((char*)SvANY(sstr)), 10122 ((char*)SvANY(dstr)), 10123 sv_type_details->body_size + sv_type_details->offset, char); 10124 #endif 10125 10126 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV 10127 && !isGV_with_GP(dstr)) 10128 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 10129 10130 /* The Copy above means that all the source (unduplicated) pointers 10131 are now in the destination. We can check the flags and the 10132 pointers in either, but it's possible that there's less cache 10133 missing by always going for the destination. 10134 FIXME - instrument and check that assumption */ 10135 if (sv_type >= SVt_PVMG) { 10136 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { 10137 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); 10138 } else if (SvMAGIC(dstr)) 10139 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); 10140 if (SvSTASH(dstr)) 10141 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); 10142 } 10143 10144 /* The cast silences a GCC warning about unhandled types. */ 10145 switch ((int)sv_type) { 10146 case SVt_PV: 10147 break; 10148 case SVt_PVIV: 10149 break; 10150 case SVt_PVNV: 10151 break; 10152 case SVt_PVMG: 10153 break; 10154 case SVt_PVLV: 10155 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ 10156 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ 10157 LvTARG(dstr) = dstr; 10158 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ 10159 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); 10160 else 10161 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); 10162 case SVt_PVGV: 10163 if(isGV_with_GP(sstr)) { 10164 if (GvNAME_HEK(dstr)) 10165 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); 10166 /* Don't call sv_add_backref here as it's going to be 10167 created as part of the magic cloning of the symbol 10168 table. */ 10169 /* Danger Will Robinson - GvGP(dstr) isn't initialised 10170 at the point of this comment. */ 10171 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); 10172 GvGP(dstr) = gp_dup(GvGP(sstr), param); 10173 (void)GpREFCNT_inc(GvGP(dstr)); 10174 } else 10175 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 10176 break; 10177 case SVt_PVIO: 10178 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param); 10179 if (IoOFP(dstr) == IoIFP(sstr)) 10180 IoOFP(dstr) = IoIFP(dstr); 10181 else 10182 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); 10183 /* PL_parser->rsfp_filters entries have fake IoDIRP() */ 10184 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { 10185 /* I have no idea why fake dirp (rsfps) 10186 should be treated differently but otherwise 10187 we end up with leaks -- sky*/ 10188 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param); 10189 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param); 10190 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param); 10191 } else { 10192 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param); 10193 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param); 10194 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param); 10195 if (IoDIRP(dstr)) { 10196 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); 10197 } else { 10198 NOOP; 10199 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ 10200 } 10201 } 10202 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr)); 10203 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr)); 10204 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); 10205 break; 10206 case SVt_PVAV: 10207 if (AvARRAY((AV*)sstr)) { 10208 SV **dst_ary, **src_ary; 10209 SSize_t items = AvFILLp((AV*)sstr) + 1; 10210 10211 src_ary = AvARRAY((AV*)sstr); 10212 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); 10213 ptr_table_store(PL_ptr_table, src_ary, dst_ary); 10214 AvARRAY((AV*)dstr) = dst_ary; 10215 AvALLOC((AV*)dstr) = dst_ary; 10216 if (AvREAL((AV*)sstr)) { 10217 while (items-- > 0) 10218 *dst_ary++ = sv_dup_inc(*src_ary++, param); 10219 } 10220 else { 10221 while (items-- > 0) 10222 *dst_ary++ = sv_dup(*src_ary++, param); 10223 } 10224 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); 10225 while (items-- > 0) { 10226 *dst_ary++ = &PL_sv_undef; 10227 } 10228 } 10229 else { 10230 AvARRAY((AV*)dstr) = NULL; 10231 AvALLOC((AV*)dstr) = (SV**)NULL; 10232 } 10233 break; 10234 case SVt_PVHV: 10235 if (HvARRAY((HV*)sstr)) { 10236 STRLEN i = 0; 10237 const bool sharekeys = !!HvSHAREKEYS(sstr); 10238 XPVHV * const dxhv = (XPVHV*)SvANY(dstr); 10239 XPVHV * const sxhv = (XPVHV*)SvANY(sstr); 10240 char *darray; 10241 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) 10242 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), 10243 char); 10244 HvARRAY(dstr) = (HE**)darray; 10245 while (i <= sxhv->xhv_max) { 10246 const HE * const source = HvARRAY(sstr)[i]; 10247 HvARRAY(dstr)[i] = source 10248 ? he_dup(source, sharekeys, param) : 0; 10249 ++i; 10250 } 10251 if (SvOOK(sstr)) { 10252 HEK *hvname; 10253 const struct xpvhv_aux * const saux = HvAUX(sstr); 10254 struct xpvhv_aux * const daux = HvAUX(dstr); 10255 /* This flag isn't copied. */ 10256 /* SvOOK_on(hv) attacks the IV flags. */ 10257 SvFLAGS(dstr) |= SVf_OOK; 10258 10259 hvname = saux->xhv_name; 10260 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname; 10261 10262 daux->xhv_riter = saux->xhv_riter; 10263 daux->xhv_eiter = saux->xhv_eiter 10264 ? he_dup(saux->xhv_eiter, 10265 (bool)!!HvSHAREKEYS(sstr), param) : 0; 10266 daux->xhv_backreferences = 10267 saux->xhv_backreferences 10268 ? (AV*) SvREFCNT_inc( 10269 sv_dup((SV*)saux->xhv_backreferences, param)) 10270 : 0; 10271 10272 daux->xhv_mro_meta = saux->xhv_mro_meta 10273 ? mro_meta_dup(saux->xhv_mro_meta, param) 10274 : 0; 10275 10276 /* Record stashes for possible cloning in Perl_clone(). */ 10277 if (hvname) 10278 av_push(param->stashes, dstr); 10279 } 10280 } 10281 else 10282 HvARRAY((HV*)dstr) = NULL; 10283 break; 10284 case SVt_PVCV: 10285 if (!(param->flags & CLONEf_COPY_STACKS)) { 10286 CvDEPTH(dstr) = 0; 10287 } 10288 case SVt_PVFM: 10289 /* NOTE: not refcounted */ 10290 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param); 10291 OP_REFCNT_LOCK; 10292 if (!CvISXSUB(dstr)) 10293 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); 10294 OP_REFCNT_UNLOCK; 10295 if (CvCONST(dstr) && CvISXSUB(dstr)) { 10296 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ? 10297 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) : 10298 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param); 10299 } 10300 /* don't dup if copying back - CvGV isn't refcounted, so the 10301 * duped GV may never be freed. A bit of a hack! DAPM */ 10302 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? 10303 NULL : gv_dup(CvGV(dstr), param) ; 10304 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); 10305 CvOUTSIDE(dstr) = 10306 CvWEAKOUTSIDE(sstr) 10307 ? cv_dup( CvOUTSIDE(dstr), param) 10308 : cv_dup_inc(CvOUTSIDE(dstr), param); 10309 if (!CvISXSUB(dstr)) 10310 CvFILE(dstr) = SAVEPV(CvFILE(dstr)); 10311 break; 10312 } 10313 } 10314 } 10315 10316 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) 10317 ++PL_sv_objcount; 10318 10319 return dstr; 10320 } 10321 10322 /* duplicate a context */ 10323 10324 PERL_CONTEXT * 10325 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 10326 { 10327 PERL_CONTEXT *ncxs; 10328 10329 if (!cxs) 10330 return (PERL_CONTEXT*)NULL; 10331 10332 /* look for it in the table first */ 10333 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); 10334 if (ncxs) 10335 return ncxs; 10336 10337 /* create anew and remember what it is */ 10338 Newxz(ncxs, max + 1, PERL_CONTEXT); 10339 ptr_table_store(PL_ptr_table, cxs, ncxs); 10340 10341 while (ix >= 0) { 10342 PERL_CONTEXT * const cx = &cxs[ix]; 10343 PERL_CONTEXT * const ncx = &ncxs[ix]; 10344 ncx->cx_type = cx->cx_type; 10345 if (CxTYPE(cx) == CXt_SUBST) { 10346 Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); 10347 } 10348 else { 10349 ncx->blk_oldsp = cx->blk_oldsp; 10350 ncx->blk_oldcop = cx->blk_oldcop; 10351 ncx->blk_oldmarksp = cx->blk_oldmarksp; 10352 ncx->blk_oldscopesp = cx->blk_oldscopesp; 10353 ncx->blk_oldpm = cx->blk_oldpm; 10354 ncx->blk_gimme = cx->blk_gimme; 10355 switch (CxTYPE(cx)) { 10356 case CXt_SUB: 10357 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 10358 ? cv_dup_inc(cx->blk_sub.cv, param) 10359 : cv_dup(cx->blk_sub.cv,param)); 10360 ncx->blk_sub.argarray = (cx->blk_sub.hasargs 10361 ? av_dup_inc(cx->blk_sub.argarray, param) 10362 : NULL); 10363 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); 10364 ncx->blk_sub.olddepth = cx->blk_sub.olddepth; 10365 ncx->blk_sub.hasargs = cx->blk_sub.hasargs; 10366 ncx->blk_sub.lval = cx->blk_sub.lval; 10367 ncx->blk_sub.retop = cx->blk_sub.retop; 10368 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, 10369 cx->blk_sub.oldcomppad); 10370 break; 10371 case CXt_EVAL: 10372 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; 10373 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; 10374 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param); 10375 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; 10376 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); 10377 ncx->blk_eval.retop = cx->blk_eval.retop; 10378 break; 10379 case CXt_LOOP: 10380 ncx->blk_loop.label = cx->blk_loop.label; 10381 ncx->blk_loop.resetsp = cx->blk_loop.resetsp; 10382 ncx->blk_loop.my_op = cx->blk_loop.my_op; 10383 ncx->blk_loop.iterdata = (CxPADLOOP(cx) 10384 ? cx->blk_loop.iterdata 10385 : gv_dup((GV*)cx->blk_loop.iterdata, param)); 10386 ncx->blk_loop.oldcomppad 10387 = (PAD*)ptr_table_fetch(PL_ptr_table, 10388 cx->blk_loop.oldcomppad); 10389 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); 10390 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); 10391 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); 10392 ncx->blk_loop.iterix = cx->blk_loop.iterix; 10393 ncx->blk_loop.itermax = cx->blk_loop.itermax; 10394 break; 10395 case CXt_FORMAT: 10396 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param); 10397 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param); 10398 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param); 10399 ncx->blk_sub.hasargs = cx->blk_sub.hasargs; 10400 ncx->blk_sub.retop = cx->blk_sub.retop; 10401 break; 10402 case CXt_BLOCK: 10403 case CXt_NULL: 10404 break; 10405 } 10406 } 10407 --ix; 10408 } 10409 return ncxs; 10410 } 10411 10412 /* duplicate a stack info structure */ 10413 10414 PERL_SI * 10415 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) 10416 { 10417 PERL_SI *nsi; 10418 10419 if (!si) 10420 return (PERL_SI*)NULL; 10421 10422 /* look for it in the table first */ 10423 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); 10424 if (nsi) 10425 return nsi; 10426 10427 /* create anew and remember what it is */ 10428 Newxz(nsi, 1, PERL_SI); 10429 ptr_table_store(PL_ptr_table, si, nsi); 10430 10431 nsi->si_stack = av_dup_inc(si->si_stack, param); 10432 nsi->si_cxix = si->si_cxix; 10433 nsi->si_cxmax = si->si_cxmax; 10434 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); 10435 nsi->si_type = si->si_type; 10436 nsi->si_prev = si_dup(si->si_prev, param); 10437 nsi->si_next = si_dup(si->si_next, param); 10438 nsi->si_markoff = si->si_markoff; 10439 10440 return nsi; 10441 } 10442 10443 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32) 10444 #define TOPINT(ss,ix) ((ss)[ix].any_i32) 10445 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long) 10446 #define TOPLONG(ss,ix) ((ss)[ix].any_long) 10447 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) 10448 #define TOPIV(ss,ix) ((ss)[ix].any_iv) 10449 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) 10450 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool) 10451 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) 10452 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr) 10453 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) 10454 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) 10455 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) 10456 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) 10457 10458 /* XXXXX todo */ 10459 #define pv_dup_inc(p) SAVEPV(p) 10460 #define pv_dup(p) SAVEPV(p) 10461 #define svp_dup_inc(p,pp) any_dup(p,pp) 10462 10463 /* map any object to the new equivent - either something in the 10464 * ptr table, or something in the interpreter structure 10465 */ 10466 10467 void * 10468 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) 10469 { 10470 void *ret; 10471 10472 if (!v) 10473 return (void*)NULL; 10474 10475 /* look for it in the table first */ 10476 ret = ptr_table_fetch(PL_ptr_table, v); 10477 if (ret) 10478 return ret; 10479 10480 /* see if it is part of the interpreter structure */ 10481 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) 10482 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); 10483 else { 10484 ret = v; 10485 } 10486 10487 return ret; 10488 } 10489 10490 /* duplicate the save stack */ 10491 10492 ANY * 10493 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 10494 { 10495 dVAR; 10496 ANY * const ss = proto_perl->Isavestack; 10497 const I32 max = proto_perl->Isavestack_max; 10498 I32 ix = proto_perl->Isavestack_ix; 10499 ANY *nss; 10500 SV *sv; 10501 GV *gv; 10502 AV *av; 10503 HV *hv; 10504 void* ptr; 10505 int intval; 10506 long longval; 10507 GP *gp; 10508 IV iv; 10509 I32 i; 10510 char *c = NULL; 10511 void (*dptr) (void*); 10512 void (*dxptr) (pTHX_ void*); 10513 10514 Newxz(nss, max, ANY); 10515 10516 while (ix > 0) { 10517 const I32 type = POPINT(ss,ix); 10518 TOPINT(nss,ix) = type; 10519 switch (type) { 10520 case SAVEt_HELEM: /* hash element */ 10521 sv = (SV*)POPPTR(ss,ix); 10522 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 10523 /* fall through */ 10524 case SAVEt_ITEM: /* normal string */ 10525 case SAVEt_SV: /* scalar reference */ 10526 sv = (SV*)POPPTR(ss,ix); 10527 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 10528 /* fall through */ 10529 case SAVEt_FREESV: 10530 case SAVEt_MORTALIZESV: 10531 sv = (SV*)POPPTR(ss,ix); 10532 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 10533 break; 10534 case SAVEt_SHARED_PVREF: /* char* in shared space */ 10535 c = (char*)POPPTR(ss,ix); 10536 TOPPTR(nss,ix) = savesharedpv(c); 10537 ptr = POPPTR(ss,ix); 10538 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10539 break; 10540 case SAVEt_GENERIC_SVREF: /* generic sv */ 10541 case SAVEt_SVREF: /* scalar reference */ 10542 sv = (SV*)POPPTR(ss,ix); 10543 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 10544 ptr = POPPTR(ss,ix); 10545 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ 10546 break; 10547 case SAVEt_HV: /* hash reference */ 10548 case SAVEt_AV: /* array reference */ 10549 sv = (SV*) POPPTR(ss,ix); 10550 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 10551 /* fall through */ 10552 case SAVEt_COMPPAD: 10553 case SAVEt_NSTAB: 10554 sv = (SV*) POPPTR(ss,ix); 10555 TOPPTR(nss,ix) = sv_dup(sv, param); 10556 break; 10557 case SAVEt_INT: /* int reference */ 10558 ptr = POPPTR(ss,ix); 10559 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10560 intval = (int)POPINT(ss,ix); 10561 TOPINT(nss,ix) = intval; 10562 break; 10563 case SAVEt_LONG: /* long reference */ 10564 ptr = POPPTR(ss,ix); 10565 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10566 /* fall through */ 10567 case SAVEt_CLEARSV: 10568 longval = (long)POPLONG(ss,ix); 10569 TOPLONG(nss,ix) = longval; 10570 break; 10571 case SAVEt_I32: /* I32 reference */ 10572 case SAVEt_I16: /* I16 reference */ 10573 case SAVEt_I8: /* I8 reference */ 10574 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ 10575 ptr = POPPTR(ss,ix); 10576 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10577 i = POPINT(ss,ix); 10578 TOPINT(nss,ix) = i; 10579 break; 10580 case SAVEt_IV: /* IV reference */ 10581 ptr = POPPTR(ss,ix); 10582 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10583 iv = POPIV(ss,ix); 10584 TOPIV(nss,ix) = iv; 10585 break; 10586 case SAVEt_HPTR: /* HV* reference */ 10587 case SAVEt_APTR: /* AV* reference */ 10588 case SAVEt_SPTR: /* SV* reference */ 10589 ptr = POPPTR(ss,ix); 10590 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10591 sv = (SV*)POPPTR(ss,ix); 10592 TOPPTR(nss,ix) = sv_dup(sv, param); 10593 break; 10594 case SAVEt_VPTR: /* random* reference */ 10595 ptr = POPPTR(ss,ix); 10596 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10597 ptr = POPPTR(ss,ix); 10598 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10599 break; 10600 case SAVEt_GENERIC_PVREF: /* generic char* */ 10601 case SAVEt_PPTR: /* char* reference */ 10602 ptr = POPPTR(ss,ix); 10603 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10604 c = (char*)POPPTR(ss,ix); 10605 TOPPTR(nss,ix) = pv_dup(c); 10606 break; 10607 case SAVEt_GP: /* scalar reference */ 10608 gp = (GP*)POPPTR(ss,ix); 10609 TOPPTR(nss,ix) = gp = gp_dup(gp, param); 10610 (void)GpREFCNT_inc(gp); 10611 gv = (GV*)POPPTR(ss,ix); 10612 TOPPTR(nss,ix) = gv_dup_inc(gv, param); 10613 break; 10614 case SAVEt_FREEOP: 10615 ptr = POPPTR(ss,ix); 10616 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { 10617 /* these are assumed to be refcounted properly */ 10618 OP *o; 10619 switch (((OP*)ptr)->op_type) { 10620 case OP_LEAVESUB: 10621 case OP_LEAVESUBLV: 10622 case OP_LEAVEEVAL: 10623 case OP_LEAVE: 10624 case OP_SCOPE: 10625 case OP_LEAVEWRITE: 10626 TOPPTR(nss,ix) = ptr; 10627 o = (OP*)ptr; 10628 OP_REFCNT_LOCK; 10629 (void) OpREFCNT_inc(o); 10630 OP_REFCNT_UNLOCK; 10631 break; 10632 default: 10633 TOPPTR(nss,ix) = NULL; 10634 break; 10635 } 10636 } 10637 else 10638 TOPPTR(nss,ix) = NULL; 10639 break; 10640 case SAVEt_FREEPV: 10641 c = (char*)POPPTR(ss,ix); 10642 TOPPTR(nss,ix) = pv_dup_inc(c); 10643 break; 10644 case SAVEt_DELETE: 10645 hv = (HV*)POPPTR(ss,ix); 10646 TOPPTR(nss,ix) = hv_dup_inc(hv, param); 10647 c = (char*)POPPTR(ss,ix); 10648 TOPPTR(nss,ix) = pv_dup_inc(c); 10649 /* fall through */ 10650 case SAVEt_STACK_POS: /* Position on Perl stack */ 10651 i = POPINT(ss,ix); 10652 TOPINT(nss,ix) = i; 10653 break; 10654 case SAVEt_DESTRUCTOR: 10655 ptr = POPPTR(ss,ix); 10656 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ 10657 dptr = POPDPTR(ss,ix); 10658 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), 10659 any_dup(FPTR2DPTR(void *, dptr), 10660 proto_perl)); 10661 break; 10662 case SAVEt_DESTRUCTOR_X: 10663 ptr = POPPTR(ss,ix); 10664 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ 10665 dxptr = POPDXPTR(ss,ix); 10666 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), 10667 any_dup(FPTR2DPTR(void *, dxptr), 10668 proto_perl)); 10669 break; 10670 case SAVEt_REGCONTEXT: 10671 case SAVEt_ALLOC: 10672 i = POPINT(ss,ix); 10673 TOPINT(nss,ix) = i; 10674 ix -= i; 10675 break; 10676 case SAVEt_AELEM: /* array element */ 10677 sv = (SV*)POPPTR(ss,ix); 10678 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 10679 i = POPINT(ss,ix); 10680 TOPINT(nss,ix) = i; 10681 av = (AV*)POPPTR(ss,ix); 10682 TOPPTR(nss,ix) = av_dup_inc(av, param); 10683 break; 10684 case SAVEt_OP: 10685 ptr = POPPTR(ss,ix); 10686 TOPPTR(nss,ix) = ptr; 10687 break; 10688 case SAVEt_HINTS: 10689 i = POPINT(ss,ix); 10690 TOPINT(nss,ix) = i; 10691 ptr = POPPTR(ss,ix); 10692 if (ptr) { 10693 HINTS_REFCNT_LOCK; 10694 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++; 10695 HINTS_REFCNT_UNLOCK; 10696 } 10697 TOPPTR(nss,ix) = ptr; 10698 if (i & HINT_LOCALIZE_HH) { 10699 hv = (HV*)POPPTR(ss,ix); 10700 TOPPTR(nss,ix) = hv_dup_inc(hv, param); 10701 } 10702 break; 10703 case SAVEt_PADSV: 10704 longval = (long)POPLONG(ss,ix); 10705 TOPLONG(nss,ix) = longval; 10706 ptr = POPPTR(ss,ix); 10707 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10708 sv = (SV*)POPPTR(ss,ix); 10709 TOPPTR(nss,ix) = sv_dup(sv, param); 10710 break; 10711 case SAVEt_BOOL: 10712 ptr = POPPTR(ss,ix); 10713 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 10714 longval = (long)POPBOOL(ss,ix); 10715 TOPBOOL(nss,ix) = (bool)longval; 10716 break; 10717 case SAVEt_SET_SVFLAGS: 10718 i = POPINT(ss,ix); 10719 TOPINT(nss,ix) = i; 10720 i = POPINT(ss,ix); 10721 TOPINT(nss,ix) = i; 10722 sv = (SV*)POPPTR(ss,ix); 10723 TOPPTR(nss,ix) = sv_dup(sv, param); 10724 break; 10725 case SAVEt_RE_STATE: 10726 { 10727 const struct re_save_state *const old_state 10728 = (struct re_save_state *) 10729 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); 10730 struct re_save_state *const new_state 10731 = (struct re_save_state *) 10732 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); 10733 10734 Copy(old_state, new_state, 1, struct re_save_state); 10735 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; 10736 10737 new_state->re_state_bostr 10738 = pv_dup(old_state->re_state_bostr); 10739 new_state->re_state_reginput 10740 = pv_dup(old_state->re_state_reginput); 10741 new_state->re_state_regeol 10742 = pv_dup(old_state->re_state_regeol); 10743 new_state->re_state_regoffs 10744 = (regexp_paren_pair*) 10745 any_dup(old_state->re_state_regoffs, proto_perl); 10746 new_state->re_state_reglastparen 10747 = (U32*) any_dup(old_state->re_state_reglastparen, 10748 proto_perl); 10749 new_state->re_state_reglastcloseparen 10750 = (U32*)any_dup(old_state->re_state_reglastcloseparen, 10751 proto_perl); 10752 /* XXX This just has to be broken. The old save_re_context 10753 code did SAVEGENERICPV(PL_reg_start_tmp); 10754 PL_reg_start_tmp is char **. 10755 Look above to what the dup code does for 10756 SAVEt_GENERIC_PVREF 10757 It can never have worked. 10758 So this is merely a faithful copy of the exiting bug: */ 10759 new_state->re_state_reg_start_tmp 10760 = (char **) pv_dup((char *) 10761 old_state->re_state_reg_start_tmp); 10762 /* I assume that it only ever "worked" because no-one called 10763 (pseudo)fork while the regexp engine had re-entered itself. 10764 */ 10765 #ifdef PERL_OLD_COPY_ON_WRITE 10766 new_state->re_state_nrs 10767 = sv_dup(old_state->re_state_nrs, param); 10768 #endif 10769 new_state->re_state_reg_magic 10770 = (MAGIC*) any_dup(old_state->re_state_reg_magic, 10771 proto_perl); 10772 new_state->re_state_reg_oldcurpm 10773 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm, 10774 proto_perl); 10775 new_state->re_state_reg_curpm 10776 = (PMOP*) any_dup(old_state->re_state_reg_curpm, 10777 proto_perl); 10778 new_state->re_state_reg_oldsaved 10779 = pv_dup(old_state->re_state_reg_oldsaved); 10780 new_state->re_state_reg_poscache 10781 = pv_dup(old_state->re_state_reg_poscache); 10782 new_state->re_state_reg_starttry 10783 = pv_dup(old_state->re_state_reg_starttry); 10784 break; 10785 } 10786 case SAVEt_COMPILE_WARNINGS: 10787 ptr = POPPTR(ss,ix); 10788 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); 10789 break; 10790 case SAVEt_PARSER: 10791 ptr = POPPTR(ss,ix); 10792 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); 10793 break; 10794 default: 10795 Perl_croak(aTHX_ 10796 "panic: ss_dup inconsistency (%"IVdf")", (IV) type); 10797 } 10798 } 10799 10800 return nss; 10801 } 10802 10803 10804 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE 10805 * flag to the result. This is done for each stash before cloning starts, 10806 * so we know which stashes want their objects cloned */ 10807 10808 static void 10809 do_mark_cloneable_stash(pTHX_ SV *sv) 10810 { 10811 const HEK * const hvname = HvNAME_HEK((HV*)sv); 10812 if (hvname) { 10813 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); 10814 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ 10815 if (cloner && GvCV(cloner)) { 10816 dSP; 10817 UV status; 10818 10819 ENTER; 10820 SAVETMPS; 10821 PUSHMARK(SP); 10822 XPUSHs(sv_2mortal(newSVhek(hvname))); 10823 PUTBACK; 10824 call_sv((SV*)GvCV(cloner), G_SCALAR); 10825 SPAGAIN; 10826 status = POPu; 10827 PUTBACK; 10828 FREETMPS; 10829 LEAVE; 10830 if (status) 10831 SvFLAGS(sv) &= ~SVphv_CLONEABLE; 10832 } 10833 } 10834 } 10835 10836 10837 10838 /* 10839 =for apidoc perl_clone 10840 10841 Create and return a new interpreter by cloning the current one. 10842 10843 perl_clone takes these flags as parameters: 10844 10845 CLONEf_COPY_STACKS - is used to, well, copy the stacks also, 10846 without it we only clone the data and zero the stacks, 10847 with it we copy the stacks and the new perl interpreter is 10848 ready to run at the exact same point as the previous one. 10849 The pseudo-fork code uses COPY_STACKS while the 10850 threads->create doesn't. 10851 10852 CLONEf_KEEP_PTR_TABLE 10853 perl_clone keeps a ptr_table with the pointer of the old 10854 variable as a key and the new variable as a value, 10855 this allows it to check if something has been cloned and not 10856 clone it again but rather just use the value and increase the 10857 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill 10858 the ptr_table using the function 10859 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>, 10860 reason to keep it around is if you want to dup some of your own 10861 variable who are outside the graph perl scans, example of this 10862 code is in threads.xs create 10863 10864 CLONEf_CLONE_HOST 10865 This is a win32 thing, it is ignored on unix, it tells perls 10866 win32host code (which is c++) to clone itself, this is needed on 10867 win32 if you want to run two threads at the same time, 10868 if you just want to do some stuff in a separate perl interpreter 10869 and then throw it away and return to the original one, 10870 you don't need to do anything. 10871 10872 =cut 10873 */ 10874 10875 /* XXX the above needs expanding by someone who actually understands it ! */ 10876 EXTERN_C PerlInterpreter * 10877 perl_clone_host(PerlInterpreter* proto_perl, UV flags); 10878 10879 PerlInterpreter * 10880 perl_clone(PerlInterpreter *proto_perl, UV flags) 10881 { 10882 dVAR; 10883 #ifdef PERL_IMPLICIT_SYS 10884 10885 /* perlhost.h so we need to call into it 10886 to clone the host, CPerlHost should have a c interface, sky */ 10887 10888 if (flags & CLONEf_CLONE_HOST) { 10889 return perl_clone_host(proto_perl,flags); 10890 } 10891 return perl_clone_using(proto_perl, flags, 10892 proto_perl->IMem, 10893 proto_perl->IMemShared, 10894 proto_perl->IMemParse, 10895 proto_perl->IEnv, 10896 proto_perl->IStdIO, 10897 proto_perl->ILIO, 10898 proto_perl->IDir, 10899 proto_perl->ISock, 10900 proto_perl->IProc); 10901 } 10902 10903 PerlInterpreter * 10904 perl_clone_using(PerlInterpreter *proto_perl, UV flags, 10905 struct IPerlMem* ipM, struct IPerlMem* ipMS, 10906 struct IPerlMem* ipMP, struct IPerlEnv* ipE, 10907 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, 10908 struct IPerlDir* ipD, struct IPerlSock* ipS, 10909 struct IPerlProc* ipP) 10910 { 10911 /* XXX many of the string copies here can be optimized if they're 10912 * constants; they need to be allocated as common memory and just 10913 * their pointers copied. */ 10914 10915 IV i; 10916 CLONE_PARAMS clone_params; 10917 CLONE_PARAMS* const param = &clone_params; 10918 10919 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); 10920 /* for each stash, determine whether its objects should be cloned */ 10921 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); 10922 PERL_SET_THX(my_perl); 10923 10924 # ifdef DEBUGGING 10925 PoisonNew(my_perl, 1, PerlInterpreter); 10926 PL_op = NULL; 10927 PL_curcop = NULL; 10928 PL_markstack = 0; 10929 PL_scopestack = 0; 10930 PL_savestack = 0; 10931 PL_savestack_ix = 0; 10932 PL_savestack_max = -1; 10933 PL_sig_pending = 0; 10934 PL_parser = NULL; 10935 Zero(&PL_debug_pad, 1, struct perl_debug_pad); 10936 # else /* !DEBUGGING */ 10937 Zero(my_perl, 1, PerlInterpreter); 10938 # endif /* DEBUGGING */ 10939 10940 /* host pointers */ 10941 PL_Mem = ipM; 10942 PL_MemShared = ipMS; 10943 PL_MemParse = ipMP; 10944 PL_Env = ipE; 10945 PL_StdIO = ipStd; 10946 PL_LIO = ipLIO; 10947 PL_Dir = ipD; 10948 PL_Sock = ipS; 10949 PL_Proc = ipP; 10950 #else /* !PERL_IMPLICIT_SYS */ 10951 IV i; 10952 CLONE_PARAMS clone_params; 10953 CLONE_PARAMS* param = &clone_params; 10954 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); 10955 /* for each stash, determine whether its objects should be cloned */ 10956 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); 10957 PERL_SET_THX(my_perl); 10958 10959 # ifdef DEBUGGING 10960 PoisonNew(my_perl, 1, PerlInterpreter); 10961 PL_op = NULL; 10962 PL_curcop = NULL; 10963 PL_markstack = 0; 10964 PL_scopestack = 0; 10965 PL_savestack = 0; 10966 PL_savestack_ix = 0; 10967 PL_savestack_max = -1; 10968 PL_sig_pending = 0; 10969 PL_parser = NULL; 10970 Zero(&PL_debug_pad, 1, struct perl_debug_pad); 10971 # else /* !DEBUGGING */ 10972 Zero(my_perl, 1, PerlInterpreter); 10973 # endif /* DEBUGGING */ 10974 #endif /* PERL_IMPLICIT_SYS */ 10975 param->flags = flags; 10976 param->proto_perl = proto_perl; 10977 10978 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); 10979 10980 PL_body_arenas = NULL; 10981 Zero(&PL_body_roots, 1, PL_body_roots); 10982 10983 PL_nice_chunk = NULL; 10984 PL_nice_chunk_size = 0; 10985 PL_sv_count = 0; 10986 PL_sv_objcount = 0; 10987 PL_sv_root = NULL; 10988 PL_sv_arenaroot = NULL; 10989 10990 PL_debug = proto_perl->Idebug; 10991 10992 PL_hash_seed = proto_perl->Ihash_seed; 10993 PL_rehash_seed = proto_perl->Irehash_seed; 10994 10995 #ifdef USE_REENTRANT_API 10996 /* XXX: things like -Dm will segfault here in perlio, but doing 10997 * PERL_SET_CONTEXT(proto_perl); 10998 * breaks too many other things 10999 */ 11000 Perl_reentrant_init(aTHX); 11001 #endif 11002 11003 /* create SV map for pointer relocation */ 11004 PL_ptr_table = ptr_table_new(); 11005 11006 /* initialize these special pointers as early as possible */ 11007 SvANY(&PL_sv_undef) = NULL; 11008 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; 11009 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; 11010 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); 11011 11012 SvANY(&PL_sv_no) = new_XPVNV(); 11013 SvREFCNT(&PL_sv_no) = (~(U32)0)/2; 11014 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK 11015 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; 11016 SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); 11017 SvCUR_set(&PL_sv_no, 0); 11018 SvLEN_set(&PL_sv_no, 1); 11019 SvIV_set(&PL_sv_no, 0); 11020 SvNV_set(&PL_sv_no, 0); 11021 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); 11022 11023 SvANY(&PL_sv_yes) = new_XPVNV(); 11024 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; 11025 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK 11026 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; 11027 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); 11028 SvCUR_set(&PL_sv_yes, 1); 11029 SvLEN_set(&PL_sv_yes, 2); 11030 SvIV_set(&PL_sv_yes, 1); 11031 SvNV_set(&PL_sv_yes, 1); 11032 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); 11033 11034 /* create (a non-shared!) shared string table */ 11035 PL_strtab = newHV(); 11036 HvSHAREKEYS_off(PL_strtab); 11037 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); 11038 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); 11039 11040 PL_compiling = proto_perl->Icompiling; 11041 11042 /* These two PVs will be free'd special way so must set them same way op.c does */ 11043 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); 11044 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); 11045 11046 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); 11047 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); 11048 11049 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); 11050 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 11051 if (PL_compiling.cop_hints_hash) { 11052 HINTS_REFCNT_LOCK; 11053 PL_compiling.cop_hints_hash->refcounted_he_refcnt++; 11054 HINTS_REFCNT_UNLOCK; 11055 } 11056 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); 11057 #ifdef PERL_DEBUG_READONLY_OPS 11058 PL_slabs = NULL; 11059 PL_slab_count = 0; 11060 #endif 11061 11062 /* pseudo environmental stuff */ 11063 PL_origargc = proto_perl->Iorigargc; 11064 PL_origargv = proto_perl->Iorigargv; 11065 11066 param->stashes = newAV(); /* Setup array of objects to call clone on */ 11067 11068 /* Set tainting stuff before PerlIO_debug can possibly get called */ 11069 PL_tainting = proto_perl->Itainting; 11070 PL_taint_warn = proto_perl->Itaint_warn; 11071 11072 #ifdef PERLIO_LAYERS 11073 /* Clone PerlIO tables as soon as we can handle general xx_dup() */ 11074 PerlIO_clone(aTHX_ proto_perl, param); 11075 #endif 11076 11077 PL_envgv = gv_dup(proto_perl->Ienvgv, param); 11078 PL_incgv = gv_dup(proto_perl->Iincgv, param); 11079 PL_hintgv = gv_dup(proto_perl->Ihintgv, param); 11080 PL_origfilename = SAVEPV(proto_perl->Iorigfilename); 11081 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); 11082 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); 11083 11084 /* switches */ 11085 PL_minus_c = proto_perl->Iminus_c; 11086 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); 11087 PL_localpatches = proto_perl->Ilocalpatches; 11088 PL_splitstr = proto_perl->Isplitstr; 11089 PL_preprocess = proto_perl->Ipreprocess; 11090 PL_minus_n = proto_perl->Iminus_n; 11091 PL_minus_p = proto_perl->Iminus_p; 11092 PL_minus_l = proto_perl->Iminus_l; 11093 PL_minus_a = proto_perl->Iminus_a; 11094 PL_minus_E = proto_perl->Iminus_E; 11095 PL_minus_F = proto_perl->Iminus_F; 11096 PL_doswitches = proto_perl->Idoswitches; 11097 PL_dowarn = proto_perl->Idowarn; 11098 PL_doextract = proto_perl->Idoextract; 11099 PL_sawampersand = proto_perl->Isawampersand; 11100 PL_unsafe = proto_perl->Iunsafe; 11101 PL_inplace = SAVEPV(proto_perl->Iinplace); 11102 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); 11103 PL_perldb = proto_perl->Iperldb; 11104 PL_perl_destruct_level = proto_perl->Iperl_destruct_level; 11105 PL_exit_flags = proto_perl->Iexit_flags; 11106 11107 /* magical thingies */ 11108 /* XXX time(&PL_basetime) when asked for? */ 11109 PL_basetime = proto_perl->Ibasetime; 11110 PL_formfeed = sv_dup(proto_perl->Iformfeed, param); 11111 11112 PL_maxsysfd = proto_perl->Imaxsysfd; 11113 PL_statusvalue = proto_perl->Istatusvalue; 11114 #ifdef VMS 11115 PL_statusvalue_vms = proto_perl->Istatusvalue_vms; 11116 #else 11117 PL_statusvalue_posix = proto_perl->Istatusvalue_posix; 11118 #endif 11119 PL_encoding = sv_dup(proto_perl->Iencoding, param); 11120 11121 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ 11122 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ 11123 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ 11124 11125 11126 /* RE engine related */ 11127 Zero(&PL_reg_state, 1, struct re_save_state); 11128 PL_reginterp_cnt = 0; 11129 PL_regmatch_slab = NULL; 11130 11131 /* Clone the regex array */ 11132 PL_regex_padav = newAV(); 11133 { 11134 const I32 len = av_len((AV*)proto_perl->Iregex_padav); 11135 SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); 11136 IV i; 11137 av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param)); 11138 for(i = 1; i <= len; i++) { 11139 const SV * const regex = regexen[i]; 11140 SV * const sv = 11141 SvREPADTMP(regex) 11142 ? sv_dup_inc(regex, param) 11143 : SvREFCNT_inc( 11144 newSViv(PTR2IV(CALLREGDUPE( 11145 INT2PTR(REGEXP *, SvIVX(regex)), param)))) 11146 ; 11147 if (SvFLAGS(regex) & SVf_BREAK) 11148 SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */ 11149 av_push(PL_regex_padav, sv); 11150 } 11151 } 11152 PL_regex_pad = AvARRAY(PL_regex_padav); 11153 11154 /* shortcuts to various I/O objects */ 11155 PL_stdingv = gv_dup(proto_perl->Istdingv, param); 11156 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); 11157 PL_defgv = gv_dup(proto_perl->Idefgv, param); 11158 PL_argvgv = gv_dup(proto_perl->Iargvgv, param); 11159 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); 11160 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); 11161 11162 /* shortcuts to regexp stuff */ 11163 PL_replgv = gv_dup(proto_perl->Ireplgv, param); 11164 11165 /* shortcuts to misc objects */ 11166 PL_errgv = gv_dup(proto_perl->Ierrgv, param); 11167 11168 /* shortcuts to debugging objects */ 11169 PL_DBgv = gv_dup(proto_perl->IDBgv, param); 11170 PL_DBline = gv_dup(proto_perl->IDBline, param); 11171 PL_DBsub = gv_dup(proto_perl->IDBsub, param); 11172 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); 11173 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); 11174 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); 11175 PL_dbargs = av_dup(proto_perl->Idbargs, param); 11176 11177 /* symbol tables */ 11178 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); 11179 PL_curstash = hv_dup(proto_perl->Icurstash, param); 11180 PL_debstash = hv_dup(proto_perl->Idebstash, param); 11181 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); 11182 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); 11183 11184 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); 11185 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); 11186 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); 11187 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); 11188 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); 11189 PL_endav = av_dup_inc(proto_perl->Iendav, param); 11190 PL_checkav = av_dup_inc(proto_perl->Icheckav, param); 11191 PL_initav = av_dup_inc(proto_perl->Iinitav, param); 11192 11193 PL_sub_generation = proto_perl->Isub_generation; 11194 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); 11195 11196 /* funky return mechanisms */ 11197 PL_forkprocess = proto_perl->Iforkprocess; 11198 11199 /* subprocess state */ 11200 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); 11201 11202 /* internal state */ 11203 PL_maxo = proto_perl->Imaxo; 11204 if (proto_perl->Iop_mask) 11205 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); 11206 else 11207 PL_op_mask = NULL; 11208 /* PL_asserting = proto_perl->Iasserting; */ 11209 11210 /* current interpreter roots */ 11211 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); 11212 OP_REFCNT_LOCK; 11213 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); 11214 OP_REFCNT_UNLOCK; 11215 PL_main_start = proto_perl->Imain_start; 11216 PL_eval_root = proto_perl->Ieval_root; 11217 PL_eval_start = proto_perl->Ieval_start; 11218 11219 /* runtime control stuff */ 11220 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); 11221 11222 PL_filemode = proto_perl->Ifilemode; 11223 PL_lastfd = proto_perl->Ilastfd; 11224 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ 11225 PL_Argv = NULL; 11226 PL_Cmd = NULL; 11227 PL_gensym = proto_perl->Igensym; 11228 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); 11229 PL_laststatval = proto_perl->Ilaststatval; 11230 PL_laststype = proto_perl->Ilaststype; 11231 PL_mess_sv = NULL; 11232 11233 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); 11234 11235 /* interpreter atexit processing */ 11236 PL_exitlistlen = proto_perl->Iexitlistlen; 11237 if (PL_exitlistlen) { 11238 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); 11239 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); 11240 } 11241 else 11242 PL_exitlist = (PerlExitListEntry*)NULL; 11243 11244 PL_my_cxt_size = proto_perl->Imy_cxt_size; 11245 if (PL_my_cxt_size) { 11246 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 11247 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); 11248 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 11249 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 11250 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); 11251 #endif 11252 } 11253 else { 11254 PL_my_cxt_list = (void**)NULL; 11255 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 11256 PL_my_cxt_keys = (const char**)NULL; 11257 #endif 11258 } 11259 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); 11260 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); 11261 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); 11262 11263 PL_profiledata = NULL; 11264 11265 PL_compcv = cv_dup(proto_perl->Icompcv, param); 11266 11267 PAD_CLONE_VARS(proto_perl, param); 11268 11269 #ifdef HAVE_INTERP_INTERN 11270 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); 11271 #endif 11272 11273 /* more statics moved here */ 11274 PL_generation = proto_perl->Igeneration; 11275 PL_DBcv = cv_dup(proto_perl->IDBcv, param); 11276 11277 PL_in_clean_objs = proto_perl->Iin_clean_objs; 11278 PL_in_clean_all = proto_perl->Iin_clean_all; 11279 11280 PL_uid = proto_perl->Iuid; 11281 PL_euid = proto_perl->Ieuid; 11282 PL_gid = proto_perl->Igid; 11283 PL_egid = proto_perl->Iegid; 11284 PL_nomemok = proto_perl->Inomemok; 11285 PL_an = proto_perl->Ian; 11286 PL_evalseq = proto_perl->Ievalseq; 11287 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ 11288 PL_origalen = proto_perl->Iorigalen; 11289 #ifdef PERL_USES_PL_PIDSTATUS 11290 PL_pidstatus = newHV(); /* XXX flag for cloning? */ 11291 #endif 11292 PL_osname = SAVEPV(proto_perl->Iosname); 11293 PL_sighandlerp = proto_perl->Isighandlerp; 11294 11295 PL_runops = proto_perl->Irunops; 11296 11297 PL_parser = parser_dup(proto_perl->Iparser, param); 11298 11299 PL_subline = proto_perl->Isubline; 11300 PL_subname = sv_dup_inc(proto_perl->Isubname, param); 11301 11302 #ifdef FCRYPT 11303 PL_cryptseen = proto_perl->Icryptseen; 11304 #endif 11305 11306 PL_hints = proto_perl->Ihints; 11307 11308 PL_amagic_generation = proto_perl->Iamagic_generation; 11309 11310 #ifdef USE_LOCALE_COLLATE 11311 PL_collation_ix = proto_perl->Icollation_ix; 11312 PL_collation_name = SAVEPV(proto_perl->Icollation_name); 11313 PL_collation_standard = proto_perl->Icollation_standard; 11314 PL_collxfrm_base = proto_perl->Icollxfrm_base; 11315 PL_collxfrm_mult = proto_perl->Icollxfrm_mult; 11316 #endif /* USE_LOCALE_COLLATE */ 11317 11318 #ifdef USE_LOCALE_NUMERIC 11319 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); 11320 PL_numeric_standard = proto_perl->Inumeric_standard; 11321 PL_numeric_local = proto_perl->Inumeric_local; 11322 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); 11323 #endif /* !USE_LOCALE_NUMERIC */ 11324 11325 /* utf8 character classes */ 11326 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); 11327 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param); 11328 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param); 11329 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); 11330 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); 11331 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param); 11332 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); 11333 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); 11334 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param); 11335 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param); 11336 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param); 11337 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); 11338 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); 11339 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); 11340 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); 11341 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); 11342 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); 11343 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); 11344 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); 11345 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); 11346 11347 /* Did the locale setup indicate UTF-8? */ 11348 PL_utf8locale = proto_perl->Iutf8locale; 11349 /* Unicode features (see perlrun/-C) */ 11350 PL_unicode = proto_perl->Iunicode; 11351 11352 /* Pre-5.8 signals control */ 11353 PL_signals = proto_perl->Isignals; 11354 11355 /* times() ticks per second */ 11356 PL_clocktick = proto_perl->Iclocktick; 11357 11358 /* Recursion stopper for PerlIO_find_layer */ 11359 PL_in_load_module = proto_perl->Iin_load_module; 11360 11361 /* sort() routine */ 11362 PL_sort_RealCmp = proto_perl->Isort_RealCmp; 11363 11364 /* Not really needed/useful since the reenrant_retint is "volatile", 11365 * but do it for consistency's sake. */ 11366 PL_reentrant_retint = proto_perl->Ireentrant_retint; 11367 11368 /* Hooks to shared SVs and locks. */ 11369 PL_sharehook = proto_perl->Isharehook; 11370 PL_lockhook = proto_perl->Ilockhook; 11371 PL_unlockhook = proto_perl->Iunlockhook; 11372 PL_threadhook = proto_perl->Ithreadhook; 11373 PL_destroyhook = proto_perl->Idestroyhook; 11374 11375 #ifdef THREADS_HAVE_PIDS 11376 PL_ppid = proto_perl->Ippid; 11377 #endif 11378 11379 /* swatch cache */ 11380 PL_last_swash_hv = NULL; /* reinits on demand */ 11381 PL_last_swash_klen = 0; 11382 PL_last_swash_key[0]= '\0'; 11383 PL_last_swash_tmps = (U8*)NULL; 11384 PL_last_swash_slen = 0; 11385 11386 PL_glob_index = proto_perl->Iglob_index; 11387 PL_srand_called = proto_perl->Isrand_called; 11388 PL_bitcount = NULL; /* reinits on demand */ 11389 11390 if (proto_perl->Ipsig_pend) { 11391 Newxz(PL_psig_pend, SIG_SIZE, int); 11392 } 11393 else { 11394 PL_psig_pend = (int*)NULL; 11395 } 11396 11397 if (proto_perl->Ipsig_ptr) { 11398 Newxz(PL_psig_ptr, SIG_SIZE, SV*); 11399 Newxz(PL_psig_name, SIG_SIZE, SV*); 11400 for (i = 1; i < SIG_SIZE; i++) { 11401 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param); 11402 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param); 11403 } 11404 } 11405 else { 11406 PL_psig_ptr = (SV**)NULL; 11407 PL_psig_name = (SV**)NULL; 11408 } 11409 11410 /* intrpvar.h stuff */ 11411 11412 if (flags & CLONEf_COPY_STACKS) { 11413 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ 11414 PL_tmps_ix = proto_perl->Itmps_ix; 11415 PL_tmps_max = proto_perl->Itmps_max; 11416 PL_tmps_floor = proto_perl->Itmps_floor; 11417 Newxz(PL_tmps_stack, PL_tmps_max, SV*); 11418 i = 0; 11419 while (i <= PL_tmps_ix) { 11420 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param); 11421 ++i; 11422 } 11423 11424 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ 11425 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; 11426 Newxz(PL_markstack, i, I32); 11427 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max 11428 - proto_perl->Imarkstack); 11429 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr 11430 - proto_perl->Imarkstack); 11431 Copy(proto_perl->Imarkstack, PL_markstack, 11432 PL_markstack_ptr - PL_markstack + 1, I32); 11433 11434 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] 11435 * NOTE: unlike the others! */ 11436 PL_scopestack_ix = proto_perl->Iscopestack_ix; 11437 PL_scopestack_max = proto_perl->Iscopestack_max; 11438 Newxz(PL_scopestack, PL_scopestack_max, I32); 11439 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); 11440 11441 /* NOTE: si_dup() looks at PL_markstack */ 11442 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); 11443 11444 /* PL_curstack = PL_curstackinfo->si_stack; */ 11445 PL_curstack = av_dup(proto_perl->Icurstack, param); 11446 PL_mainstack = av_dup(proto_perl->Imainstack, param); 11447 11448 /* next PUSHs() etc. set *(PL_stack_sp+1) */ 11449 PL_stack_base = AvARRAY(PL_curstack); 11450 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp 11451 - proto_perl->Istack_base); 11452 PL_stack_max = PL_stack_base + AvMAX(PL_curstack); 11453 11454 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] 11455 * NOTE: unlike the others! */ 11456 PL_savestack_ix = proto_perl->Isavestack_ix; 11457 PL_savestack_max = proto_perl->Isavestack_max; 11458 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ 11459 PL_savestack = ss_dup(proto_perl, param); 11460 } 11461 else { 11462 init_stacks(); 11463 ENTER; /* perl_destruct() wants to LEAVE; */ 11464 11465 /* although we're not duplicating the tmps stack, we should still 11466 * add entries for any SVs on the tmps stack that got cloned by a 11467 * non-refcount means (eg a temp in @_); otherwise they will be 11468 * orphaned 11469 */ 11470 for (i = 0; i<= proto_perl->Itmps_ix; i++) { 11471 SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table, 11472 proto_perl->Itmps_stack[i]); 11473 if (nsv && !SvREFCNT(nsv)) { 11474 EXTEND_MORTAL(1); 11475 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); 11476 } 11477 } 11478 } 11479 11480 PL_start_env = proto_perl->Istart_env; /* XXXXXX */ 11481 PL_top_env = &PL_start_env; 11482 11483 PL_op = proto_perl->Iop; 11484 11485 PL_Sv = NULL; 11486 PL_Xpv = (XPV*)NULL; 11487 PL_na = proto_perl->Ina; 11488 11489 PL_statbuf = proto_perl->Istatbuf; 11490 PL_statcache = proto_perl->Istatcache; 11491 PL_statgv = gv_dup(proto_perl->Istatgv, param); 11492 PL_statname = sv_dup_inc(proto_perl->Istatname, param); 11493 #ifdef HAS_TIMES 11494 PL_timesbuf = proto_perl->Itimesbuf; 11495 #endif 11496 11497 PL_tainted = proto_perl->Itainted; 11498 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ 11499 PL_rs = sv_dup_inc(proto_perl->Irs, param); 11500 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); 11501 PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param); 11502 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); 11503 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ 11504 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); 11505 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); 11506 PL_formtarget = sv_dup(proto_perl->Iformtarget, param); 11507 11508 PL_restartop = proto_perl->Irestartop; 11509 PL_in_eval = proto_perl->Iin_eval; 11510 PL_delaymagic = proto_perl->Idelaymagic; 11511 PL_dirty = proto_perl->Idirty; 11512 PL_localizing = proto_perl->Ilocalizing; 11513 11514 PL_errors = sv_dup_inc(proto_perl->Ierrors, param); 11515 PL_hv_fetch_ent_mh = NULL; 11516 PL_modcount = proto_perl->Imodcount; 11517 PL_lastgotoprobe = NULL; 11518 PL_dumpindent = proto_perl->Idumpindent; 11519 11520 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); 11521 PL_sortstash = hv_dup(proto_perl->Isortstash, param); 11522 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param); 11523 PL_secondgv = gv_dup(proto_perl->Isecondgv, param); 11524 PL_efloatbuf = NULL; /* reinits on demand */ 11525 PL_efloatsize = 0; /* reinits on demand */ 11526 11527 /* regex stuff */ 11528 11529 PL_screamfirst = NULL; 11530 PL_screamnext = NULL; 11531 PL_maxscream = -1; /* reinits on demand */ 11532 PL_lastscream = NULL; 11533 11534 11535 PL_regdummy = proto_perl->Iregdummy; 11536 PL_colorset = 0; /* reinits PL_colors[] */ 11537 /*PL_colors[6] = {0,0,0,0,0,0};*/ 11538 11539 11540 11541 /* Pluggable optimizer */ 11542 PL_peepp = proto_perl->Ipeepp; 11543 11544 PL_stashcache = newHV(); 11545 11546 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, 11547 proto_perl->Iwatchaddr); 11548 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; 11549 if (PL_debug && PL_watchaddr) { 11550 PerlIO_printf(Perl_debug_log, 11551 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n", 11552 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), 11553 PTR2UV(PL_watchok)); 11554 } 11555 11556 if (!(flags & CLONEf_KEEP_PTR_TABLE)) { 11557 ptr_table_free(PL_ptr_table); 11558 PL_ptr_table = NULL; 11559 } 11560 11561 /* Call the ->CLONE method, if it exists, for each of the stashes 11562 identified by sv_dup() above. 11563 */ 11564 while(av_len(param->stashes) != -1) { 11565 HV* const stash = (HV*) av_shift(param->stashes); 11566 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); 11567 if (cloner && GvCV(cloner)) { 11568 dSP; 11569 ENTER; 11570 SAVETMPS; 11571 PUSHMARK(SP); 11572 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); 11573 PUTBACK; 11574 call_sv((SV*)GvCV(cloner), G_DISCARD); 11575 FREETMPS; 11576 LEAVE; 11577 } 11578 } 11579 11580 SvREFCNT_dec(param->stashes); 11581 11582 /* orphaned? eg threads->new inside BEGIN or use */ 11583 if (PL_compcv && ! SvREFCNT(PL_compcv)) { 11584 SvREFCNT_inc_simple_void(PL_compcv); 11585 SAVEFREESV(PL_compcv); 11586 } 11587 11588 return my_perl; 11589 } 11590 11591 #endif /* USE_ITHREADS */ 11592 11593 /* 11594 =head1 Unicode Support 11595 11596 =for apidoc sv_recode_to_utf8 11597 11598 The encoding is assumed to be an Encode object, on entry the PV 11599 of the sv is assumed to be octets in that encoding, and the sv 11600 will be converted into Unicode (and UTF-8). 11601 11602 If the sv already is UTF-8 (or if it is not POK), or if the encoding 11603 is not a reference, nothing is done to the sv. If the encoding is not 11604 an C<Encode::XS> Encoding object, bad things will happen. 11605 (See F<lib/encoding.pm> and L<Encode>). 11606 11607 The PV of the sv is returned. 11608 11609 =cut */ 11610 11611 char * 11612 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) 11613 { 11614 dVAR; 11615 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { 11616 SV *uni; 11617 STRLEN len; 11618 const char *s; 11619 dSP; 11620 ENTER; 11621 SAVETMPS; 11622 save_re_context(); 11623 PUSHMARK(sp); 11624 EXTEND(SP, 3); 11625 XPUSHs(encoding); 11626 XPUSHs(sv); 11627 /* 11628 NI-S 2002/07/09 11629 Passing sv_yes is wrong - it needs to be or'ed set of constants 11630 for Encode::XS, while UTf-8 decode (currently) assumes a true value means 11631 remove converted chars from source. 11632 11633 Both will default the value - let them. 11634 11635 XPUSHs(&PL_sv_yes); 11636 */ 11637 PUTBACK; 11638 call_method("decode", G_SCALAR); 11639 SPAGAIN; 11640 uni = POPs; 11641 PUTBACK; 11642 s = SvPV_const(uni, len); 11643 if (s != SvPVX_const(sv)) { 11644 SvGROW(sv, len + 1); 11645 Move(s, SvPVX(sv), len + 1, char); 11646 SvCUR_set(sv, len); 11647 } 11648 FREETMPS; 11649 LEAVE; 11650 SvUTF8_on(sv); 11651 return SvPVX(sv); 11652 } 11653 return SvPOKp(sv) ? SvPVX(sv) : NULL; 11654 } 11655 11656 /* 11657 =for apidoc sv_cat_decode 11658 11659 The encoding is assumed to be an Encode object, the PV of the ssv is 11660 assumed to be octets in that encoding and decoding the input starts 11661 from the position which (PV + *offset) pointed to. The dsv will be 11662 concatenated the decoded UTF-8 string from ssv. Decoding will terminate 11663 when the string tstr appears in decoding output or the input ends on 11664 the PV of the ssv. The value which the offset points will be modified 11665 to the last input position on the ssv. 11666 11667 Returns TRUE if the terminator was found, else returns FALSE. 11668 11669 =cut */ 11670 11671 bool 11672 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, 11673 SV *ssv, int *offset, char *tstr, int tlen) 11674 { 11675 dVAR; 11676 bool ret = FALSE; 11677 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { 11678 SV *offsv; 11679 dSP; 11680 ENTER; 11681 SAVETMPS; 11682 save_re_context(); 11683 PUSHMARK(sp); 11684 EXTEND(SP, 6); 11685 XPUSHs(encoding); 11686 XPUSHs(dsv); 11687 XPUSHs(ssv); 11688 XPUSHs(offsv = sv_2mortal(newSViv(*offset))); 11689 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen))); 11690 PUTBACK; 11691 call_method("cat_decode", G_SCALAR); 11692 SPAGAIN; 11693 ret = SvTRUE(TOPs); 11694 *offset = SvIV(offsv); 11695 PUTBACK; 11696 FREETMPS; 11697 LEAVE; 11698 } 11699 else 11700 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); 11701 return ret; 11702 11703 } 11704 11705 /* --------------------------------------------------------------------- 11706 * 11707 * support functions for report_uninit() 11708 */ 11709 11710 /* the maxiumum size of array or hash where we will scan looking 11711 * for the undefined element that triggered the warning */ 11712 11713 #define FUV_MAX_SEARCH_SIZE 1000 11714 11715 /* Look for an entry in the hash whose value has the same SV as val; 11716 * If so, return a mortal copy of the key. */ 11717 11718 STATIC SV* 11719 S_find_hash_subscript(pTHX_ HV *hv, SV* val) 11720 { 11721 dVAR; 11722 register HE **array; 11723 I32 i; 11724 11725 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || 11726 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) 11727 return NULL; 11728 11729 array = HvARRAY(hv); 11730 11731 for (i=HvMAX(hv); i>0; i--) { 11732 register HE *entry; 11733 for (entry = array[i]; entry; entry = HeNEXT(entry)) { 11734 if (HeVAL(entry) != val) 11735 continue; 11736 if ( HeVAL(entry) == &PL_sv_undef || 11737 HeVAL(entry) == &PL_sv_placeholder) 11738 continue; 11739 if (!HeKEY(entry)) 11740 return NULL; 11741 if (HeKLEN(entry) == HEf_SVKEY) 11742 return sv_mortalcopy(HeKEY_sv(entry)); 11743 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); 11744 } 11745 } 11746 return NULL; 11747 } 11748 11749 /* Look for an entry in the array whose value has the same SV as val; 11750 * If so, return the index, otherwise return -1. */ 11751 11752 STATIC I32 11753 S_find_array_subscript(pTHX_ AV *av, SV* val) 11754 { 11755 dVAR; 11756 if (!av || SvMAGICAL(av) || !AvARRAY(av) || 11757 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) 11758 return -1; 11759 11760 if (val != &PL_sv_undef) { 11761 SV ** const svp = AvARRAY(av); 11762 I32 i; 11763 11764 for (i=AvFILLp(av); i>=0; i--) 11765 if (svp[i] == val) 11766 return i; 11767 } 11768 return -1; 11769 } 11770 11771 /* S_varname(): return the name of a variable, optionally with a subscript. 11772 * If gv is non-zero, use the name of that global, along with gvtype (one 11773 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset 11774 * targ. Depending on the value of the subscript_type flag, return: 11775 */ 11776 11777 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ 11778 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ 11779 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ 11780 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ 11781 11782 STATIC SV* 11783 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, 11784 SV* keyname, I32 aindex, int subscript_type) 11785 { 11786 11787 SV * const name = sv_newmortal(); 11788 if (gv) { 11789 char buffer[2]; 11790 buffer[0] = gvtype; 11791 buffer[1] = 0; 11792 11793 /* as gv_fullname4(), but add literal '^' for $^FOO names */ 11794 11795 gv_fullname4(name, gv, buffer, 0); 11796 11797 if ((unsigned int)SvPVX(name)[1] <= 26) { 11798 buffer[0] = '^'; 11799 buffer[1] = SvPVX(name)[1] + 'A' - 1; 11800 11801 /* Swap the 1 unprintable control character for the 2 byte pretty 11802 version - ie substr($name, 1, 1) = $buffer; */ 11803 sv_insert(name, 1, 1, buffer, 2); 11804 } 11805 } 11806 else { 11807 CV * const cv = find_runcv(NULL); 11808 SV *sv; 11809 AV *av; 11810 11811 if (!cv || !CvPADLIST(cv)) 11812 return NULL; 11813 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); 11814 sv = *av_fetch(av, targ, FALSE); 11815 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv)); 11816 } 11817 11818 if (subscript_type == FUV_SUBSCRIPT_HASH) { 11819 SV * const sv = newSV(0); 11820 *SvPVX(name) = '$'; 11821 Perl_sv_catpvf(aTHX_ name, "{%s}", 11822 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); 11823 SvREFCNT_dec(sv); 11824 } 11825 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { 11826 *SvPVX(name) = '$'; 11827 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); 11828 } 11829 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) 11830 Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within ")); 11831 11832 return name; 11833 } 11834 11835 11836 /* 11837 =for apidoc find_uninit_var 11838 11839 Find the name of the undefined variable (if any) that caused the operator o 11840 to issue a "Use of uninitialized value" warning. 11841 If match is true, only return a name if it's value matches uninit_sv. 11842 So roughly speaking, if a unary operator (such as OP_COS) generates a 11843 warning, then following the direct child of the op may yield an 11844 OP_PADSV or OP_GV that gives the name of the undefined variable. On the 11845 other hand, with OP_ADD there are two branches to follow, so we only print 11846 the variable name if we get an exact match. 11847 11848 The name is returned as a mortal SV. 11849 11850 Assumes that PL_op is the op that originally triggered the error, and that 11851 PL_comppad/PL_curpad points to the currently executing pad. 11852 11853 =cut 11854 */ 11855 11856 STATIC SV * 11857 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) 11858 { 11859 dVAR; 11860 SV *sv; 11861 AV *av; 11862 GV *gv; 11863 OP *o, *o2, *kid; 11864 11865 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || 11866 uninit_sv == &PL_sv_placeholder))) 11867 return NULL; 11868 11869 switch (obase->op_type) { 11870 11871 case OP_RV2AV: 11872 case OP_RV2HV: 11873 case OP_PADAV: 11874 case OP_PADHV: 11875 { 11876 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); 11877 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); 11878 I32 index = 0; 11879 SV *keysv = NULL; 11880 int subscript_type = FUV_SUBSCRIPT_WITHIN; 11881 11882 if (pad) { /* @lex, %lex */ 11883 sv = PAD_SVl(obase->op_targ); 11884 gv = NULL; 11885 } 11886 else { 11887 if (cUNOPx(obase)->op_first->op_type == OP_GV) { 11888 /* @global, %global */ 11889 gv = cGVOPx_gv(cUNOPx(obase)->op_first); 11890 if (!gv) 11891 break; 11892 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); 11893 } 11894 else /* @{expr}, %{expr} */ 11895 return find_uninit_var(cUNOPx(obase)->op_first, 11896 uninit_sv, match); 11897 } 11898 11899 /* attempt to find a match within the aggregate */ 11900 if (hash) { 11901 keysv = find_hash_subscript((HV*)sv, uninit_sv); 11902 if (keysv) 11903 subscript_type = FUV_SUBSCRIPT_HASH; 11904 } 11905 else { 11906 index = find_array_subscript((AV*)sv, uninit_sv); 11907 if (index >= 0) 11908 subscript_type = FUV_SUBSCRIPT_ARRAY; 11909 } 11910 11911 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) 11912 break; 11913 11914 return varname(gv, hash ? '%' : '@', obase->op_targ, 11915 keysv, index, subscript_type); 11916 } 11917 11918 case OP_PADSV: 11919 if (match && PAD_SVl(obase->op_targ) != uninit_sv) 11920 break; 11921 return varname(NULL, '$', obase->op_targ, 11922 NULL, 0, FUV_SUBSCRIPT_NONE); 11923 11924 case OP_GVSV: 11925 gv = cGVOPx_gv(obase); 11926 if (!gv || (match && GvSV(gv) != uninit_sv)) 11927 break; 11928 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); 11929 11930 case OP_AELEMFAST: 11931 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ 11932 if (match) { 11933 SV **svp; 11934 av = (AV*)PAD_SV(obase->op_targ); 11935 if (!av || SvRMAGICAL(av)) 11936 break; 11937 svp = av_fetch(av, (I32)obase->op_private, FALSE); 11938 if (!svp || *svp != uninit_sv) 11939 break; 11940 } 11941 return varname(NULL, '$', obase->op_targ, 11942 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); 11943 } 11944 else { 11945 gv = cGVOPx_gv(obase); 11946 if (!gv) 11947 break; 11948 if (match) { 11949 SV **svp; 11950 av = GvAV(gv); 11951 if (!av || SvRMAGICAL(av)) 11952 break; 11953 svp = av_fetch(av, (I32)obase->op_private, FALSE); 11954 if (!svp || *svp != uninit_sv) 11955 break; 11956 } 11957 return varname(gv, '$', 0, 11958 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); 11959 } 11960 break; 11961 11962 case OP_EXISTS: 11963 o = cUNOPx(obase)->op_first; 11964 if (!o || o->op_type != OP_NULL || 11965 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) 11966 break; 11967 return find_uninit_var(cBINOPo->op_last, uninit_sv, match); 11968 11969 case OP_AELEM: 11970 case OP_HELEM: 11971 if (PL_op == obase) 11972 /* $a[uninit_expr] or $h{uninit_expr} */ 11973 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); 11974 11975 gv = NULL; 11976 o = cBINOPx(obase)->op_first; 11977 kid = cBINOPx(obase)->op_last; 11978 11979 /* get the av or hv, and optionally the gv */ 11980 sv = NULL; 11981 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { 11982 sv = PAD_SV(o->op_targ); 11983 } 11984 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) 11985 && cUNOPo->op_first->op_type == OP_GV) 11986 { 11987 gv = cGVOPx_gv(cUNOPo->op_first); 11988 if (!gv) 11989 break; 11990 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); 11991 } 11992 if (!sv) 11993 break; 11994 11995 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { 11996 /* index is constant */ 11997 if (match) { 11998 if (SvMAGICAL(sv)) 11999 break; 12000 if (obase->op_type == OP_HELEM) { 12001 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); 12002 if (!he || HeVAL(he) != uninit_sv) 12003 break; 12004 } 12005 else { 12006 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); 12007 if (!svp || *svp != uninit_sv) 12008 break; 12009 } 12010 } 12011 if (obase->op_type == OP_HELEM) 12012 return varname(gv, '%', o->op_targ, 12013 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); 12014 else 12015 return varname(gv, '@', o->op_targ, NULL, 12016 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); 12017 } 12018 else { 12019 /* index is an expression; 12020 * attempt to find a match within the aggregate */ 12021 if (obase->op_type == OP_HELEM) { 12022 SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv); 12023 if (keysv) 12024 return varname(gv, '%', o->op_targ, 12025 keysv, 0, FUV_SUBSCRIPT_HASH); 12026 } 12027 else { 12028 const I32 index = find_array_subscript((AV*)sv, uninit_sv); 12029 if (index >= 0) 12030 return varname(gv, '@', o->op_targ, 12031 NULL, index, FUV_SUBSCRIPT_ARRAY); 12032 } 12033 if (match) 12034 break; 12035 return varname(gv, 12036 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) 12037 ? '@' : '%', 12038 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); 12039 } 12040 break; 12041 12042 case OP_AASSIGN: 12043 /* only examine RHS */ 12044 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); 12045 12046 case OP_OPEN: 12047 o = cUNOPx(obase)->op_first; 12048 if (o->op_type == OP_PUSHMARK) 12049 o = o->op_sibling; 12050 12051 if (!o->op_sibling) { 12052 /* one-arg version of open is highly magical */ 12053 12054 if (o->op_type == OP_GV) { /* open FOO; */ 12055 gv = cGVOPx_gv(o); 12056 if (match && GvSV(gv) != uninit_sv) 12057 break; 12058 return varname(gv, '$', 0, 12059 NULL, 0, FUV_SUBSCRIPT_NONE); 12060 } 12061 /* other possibilities not handled are: 12062 * open $x; or open my $x; should return '${*$x}' 12063 * open expr; should return '$'.expr ideally 12064 */ 12065 break; 12066 } 12067 goto do_op; 12068 12069 /* ops where $_ may be an implicit arg */ 12070 case OP_TRANS: 12071 case OP_SUBST: 12072 case OP_MATCH: 12073 if ( !(obase->op_flags & OPf_STACKED)) { 12074 if (uninit_sv == ((obase->op_private & OPpTARGET_MY) 12075 ? PAD_SVl(obase->op_targ) 12076 : DEFSV)) 12077 { 12078 sv = sv_newmortal(); 12079 sv_setpvn(sv, "$_", 2); 12080 return sv; 12081 } 12082 } 12083 goto do_op; 12084 12085 case OP_PRTF: 12086 case OP_PRINT: 12087 case OP_SAY: 12088 /* skip filehandle as it can't produce 'undef' warning */ 12089 o = cUNOPx(obase)->op_first; 12090 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) 12091 o = o->op_sibling->op_sibling; 12092 goto do_op2; 12093 12094 12095 case OP_RV2SV: 12096 case OP_CUSTOM: 12097 match = 1; /* XS or custom code could trigger random warnings */ 12098 goto do_op; 12099 12100 case OP_ENTERSUB: 12101 case OP_GOTO: 12102 /* XXX tmp hack: these two may call an XS sub, and currently 12103 XS subs don't have a SUB entry on the context stack, so CV and 12104 pad determination goes wrong, and BAD things happen. So, just 12105 don't try to determine the value under those circumstances. 12106 Need a better fix at dome point. DAPM 11/2007 */ 12107 break; 12108 12109 case OP_POS: 12110 /* def-ness of rval pos() is independent of the def-ness of its arg */ 12111 if ( !(obase->op_flags & OPf_MOD)) 12112 break; 12113 12114 case OP_SCHOMP: 12115 case OP_CHOMP: 12116 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) 12117 return sv_2mortal(newSVpvs("${$/}")); 12118 /*FALLTHROUGH*/ 12119 12120 default: 12121 do_op: 12122 if (!(obase->op_flags & OPf_KIDS)) 12123 break; 12124 o = cUNOPx(obase)->op_first; 12125 12126 do_op2: 12127 if (!o) 12128 break; 12129 12130 /* if all except one arg are constant, or have no side-effects, 12131 * or are optimized away, then it's unambiguous */ 12132 o2 = NULL; 12133 for (kid=o; kid; kid = kid->op_sibling) { 12134 if (kid) { 12135 const OPCODE type = kid->op_type; 12136 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) 12137 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) 12138 || (type == OP_PUSHMARK) 12139 ) 12140 continue; 12141 } 12142 if (o2) { /* more than one found */ 12143 o2 = NULL; 12144 break; 12145 } 12146 o2 = kid; 12147 } 12148 if (o2) 12149 return find_uninit_var(o2, uninit_sv, match); 12150 12151 /* scan all args */ 12152 while (o) { 12153 sv = find_uninit_var(o, uninit_sv, 1); 12154 if (sv) 12155 return sv; 12156 o = o->op_sibling; 12157 } 12158 break; 12159 } 12160 return NULL; 12161 } 12162 12163 12164 /* 12165 =for apidoc report_uninit 12166 12167 Print appropriate "Use of uninitialized variable" warning 12168 12169 =cut 12170 */ 12171 12172 void 12173 Perl_report_uninit(pTHX_ SV* uninit_sv) 12174 { 12175 dVAR; 12176 if (PL_op) { 12177 SV* varname = NULL; 12178 if (uninit_sv) { 12179 varname = find_uninit_var(PL_op, uninit_sv,0); 12180 if (varname) 12181 sv_insert(varname, 0, 0, " ", 1); 12182 } 12183 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, 12184 varname ? SvPV_nolen_const(varname) : "", 12185 " in ", OP_DESC(PL_op)); 12186 } 12187 else 12188 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, 12189 "", "", ""); 12190 } 12191 12192 /* 12193 * Local variables: 12194 * c-indentation-style: bsd 12195 * c-basic-offset: 4 12196 * indent-tabs-mode: t 12197 * End: 12198 * 12199 * ex: set ts=8 sts=4 sw=4 noet: 12200 */ 12201