1 /* sv.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall 5 * and others 6 * 7 * You may distribute under the terms of either the GNU General Public 8 * License or the Artistic License, as specified in the README file. 9 * 10 */ 11 12 /* 13 * 'I wonder what the Entish is for "yes" and "no",' he thought. 14 * --Pippin 15 * 16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"] 17 */ 18 19 /* 20 * 21 * 22 * This file contains the code that creates, manipulates and destroys 23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the 24 * structure of an SV, so their creation and destruction is handled 25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode 26 * level functions (eg. substr, split, join) for each of the types are 27 * in the pp*.c files. 28 */ 29 30 #include "EXTERN.h" 31 #define PERL_IN_SV_C 32 #include "perl.h" 33 #include "regcomp.h" 34 35 #define FCALL *f 36 37 #ifdef __Lynx__ 38 /* Missing proto on LynxOS */ 39 char *gconvert(double, int, int, char *); 40 #endif 41 42 #ifdef PERL_UTF8_CACHE_ASSERT 43 /* if adding more checks watch out for the following tests: 44 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t 45 * lib/utf8.t lib/Unicode/Collate/t/index.t 46 * --jhi 47 */ 48 # define ASSERT_UTF8_CACHE(cache) \ 49 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ 50 assert((cache)[2] <= (cache)[3]); \ 51 assert((cache)[3] <= (cache)[1]);} \ 52 } STMT_END 53 #else 54 # define ASSERT_UTF8_CACHE(cache) NOOP 55 #endif 56 57 #ifdef PERL_OLD_COPY_ON_WRITE 58 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) 59 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) 60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- 61 on-write. */ 62 #endif 63 64 /* ============================================================================ 65 66 =head1 Allocation and deallocation of SVs. 67 68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct 69 sv, av, hv...) contains type and reference count information, and for 70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which 71 contains fields specific to each type. Some types store all they need 72 in the head, so don't have a body. 73 74 In all but the most memory-paranoid configuations (ex: PURIFY), heads 75 and bodies are allocated out of arenas, which by default are 76 approximately 4K chunks of memory parcelled up into N heads or bodies. 77 Sv-bodies are allocated by their sv-type, guaranteeing size 78 consistency needed to allocate safely from arrays. 79 80 For SV-heads, the first slot in each arena is reserved, and holds a 81 link to the next arena, some flags, and a note of the number of slots. 82 Snaked through each arena chain is a linked list of free items; when 83 this becomes empty, an extra arena is allocated and divided up into N 84 items which are threaded into the free list. 85 86 SV-bodies are similar, but they use arena-sets by default, which 87 separate the link and info from the arena itself, and reclaim the 1st 88 slot in the arena. SV-bodies are further described later. 89 90 The following global variables are associated with arenas: 91 92 PL_sv_arenaroot pointer to list of SV arenas 93 PL_sv_root pointer to list of free SV structures 94 95 PL_body_arenas head of linked-list of body arenas 96 PL_body_roots[] array of pointers to list of free bodies of svtype 97 arrays are indexed by the svtype needed 98 99 A few special SV heads are not allocated from an arena, but are 100 instead directly created in the interpreter structure, eg PL_sv_undef. 101 The size of arenas can be changed from the default by setting 102 PERL_ARENA_SIZE appropriately at compile time. 103 104 The SV arena serves the secondary purpose of allowing still-live SVs 105 to be located and destroyed during final cleanup. 106 107 At the lowest level, the macros new_SV() and del_SV() grab and free 108 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() 109 to return the SV to the free list with error checking.) new_SV() calls 110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty. 111 SVs in the free list have their SvTYPE field set to all ones. 112 113 At the time of very final cleanup, sv_free_arenas() is called from 114 perl_destruct() to physically free all the arenas allocated since the 115 start of the interpreter. 116 117 The function visit() scans the SV arenas list, and calls a specified 118 function for each SV it finds which is still live - ie which has an SvTYPE 119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the 120 following functions (specified as [function that calls visit()] / [function 121 called by visit() for each SV]): 122 123 sv_report_used() / do_report_used() 124 dump all remaining SVs (debugging aid) 125 126 sv_clean_objs() / do_clean_objs(),do_clean_named_objs() 127 Attempt to free all objects pointed to by RVs, 128 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined, 129 try to do the same for all objects indirectly 130 referenced by typeglobs too. Called once from 131 perl_destruct(), prior to calling sv_clean_all() 132 below. 133 134 sv_clean_all() / do_clean_all() 135 SvREFCNT_dec(sv) each remaining SV, possibly 136 triggering an sv_free(). It also sets the 137 SVf_BREAK flag on the SV to indicate that the 138 refcnt has been artificially lowered, and thus 139 stopping sv_free() from giving spurious warnings 140 about SVs which unexpectedly have a refcnt 141 of zero. called repeatedly from perl_destruct() 142 until there are no SVs left. 143 144 =head2 Arena allocator API Summary 145 146 Private API to rest of sv.c 147 148 new_SV(), del_SV(), 149 150 new_XIV(), del_XIV(), 151 new_XNV(), del_XNV(), 152 etc 153 154 Public API: 155 156 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() 157 158 =cut 159 160 * ========================================================================= */ 161 162 /* 163 * "A time to plant, and a time to uproot what was planted..." 164 */ 165 166 void 167 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) 168 { 169 dVAR; 170 void *new_chunk; 171 U32 new_chunk_size; 172 173 PERL_ARGS_ASSERT_OFFER_NICE_CHUNK; 174 175 new_chunk = (void *)(chunk); 176 new_chunk_size = (chunk_size); 177 if (new_chunk_size > PL_nice_chunk_size) { 178 Safefree(PL_nice_chunk); 179 PL_nice_chunk = (char *) new_chunk; 180 PL_nice_chunk_size = new_chunk_size; 181 } else { 182 Safefree(chunk); 183 } 184 } 185 186 #ifdef PERL_MEM_LOG 187 # define MEM_LOG_NEW_SV(sv, file, line, func) \ 188 Perl_mem_log_new_sv(sv, file, line, func) 189 # define MEM_LOG_DEL_SV(sv, file, line, func) \ 190 Perl_mem_log_del_sv(sv, file, line, func) 191 #else 192 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP 193 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP 194 #endif 195 196 #ifdef DEBUG_LEAKING_SCALARS 197 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) 198 # define DEBUG_SV_SERIAL(sv) \ 199 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ 200 PTR2UV(sv), (long)(sv)->sv_debug_serial)) 201 #else 202 # define FREE_SV_DEBUG_FILE(sv) 203 # define DEBUG_SV_SERIAL(sv) NOOP 204 #endif 205 206 #ifdef PERL_POISON 207 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) 208 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) 209 /* Whilst I'd love to do this, it seems that things like to check on 210 unreferenced scalars 211 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) 212 */ 213 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ 214 PoisonNew(&SvREFCNT(sv), 1, U32) 215 #else 216 # define SvARENA_CHAIN(sv) SvANY(sv) 217 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) 218 # define POSION_SV_HEAD(sv) 219 #endif 220 221 /* Mark an SV head as unused, and add to free list. 222 * 223 * If SVf_BREAK is set, skip adding it to the free list, as this SV had 224 * its refcount artificially decremented during global destruction, so 225 * there may be dangling pointers to it. The last thing we want in that 226 * case is for it to be reused. */ 227 228 #define plant_SV(p) \ 229 STMT_START { \ 230 const U32 old_flags = SvFLAGS(p); \ 231 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ 232 DEBUG_SV_SERIAL(p); \ 233 FREE_SV_DEBUG_FILE(p); \ 234 POSION_SV_HEAD(p); \ 235 SvFLAGS(p) = SVTYPEMASK; \ 236 if (!(old_flags & SVf_BREAK)) { \ 237 SvARENA_CHAIN_SET(p, PL_sv_root); \ 238 PL_sv_root = (p); \ 239 } \ 240 --PL_sv_count; \ 241 } STMT_END 242 243 #define uproot_SV(p) \ 244 STMT_START { \ 245 (p) = PL_sv_root; \ 246 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ 247 ++PL_sv_count; \ 248 } STMT_END 249 250 251 /* make some more SVs by adding another arena */ 252 253 STATIC SV* 254 S_more_sv(pTHX) 255 { 256 dVAR; 257 SV* sv; 258 259 if (PL_nice_chunk) { 260 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); 261 PL_nice_chunk = NULL; 262 PL_nice_chunk_size = 0; 263 } 264 else { 265 char *chunk; /* must use New here to match call to */ 266 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ 267 sv_add_arena(chunk, PERL_ARENA_SIZE, 0); 268 } 269 uproot_SV(sv); 270 return sv; 271 } 272 273 /* new_SV(): return a new, empty SV head */ 274 275 #ifdef DEBUG_LEAKING_SCALARS 276 /* provide a real function for a debugger to play with */ 277 STATIC SV* 278 S_new_SV(pTHX_ const char *file, int line, const char *func) 279 { 280 SV* sv; 281 282 if (PL_sv_root) 283 uproot_SV(sv); 284 else 285 sv = S_more_sv(aTHX); 286 SvANY(sv) = 0; 287 SvREFCNT(sv) = 1; 288 SvFLAGS(sv) = 0; 289 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; 290 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE 291 ? PL_parser->copline 292 : PL_curcop 293 ? CopLINE(PL_curcop) 294 : 0 295 ); 296 sv->sv_debug_inpad = 0; 297 sv->sv_debug_cloned = 0; 298 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; 299 300 sv->sv_debug_serial = PL_sv_serial++; 301 302 MEM_LOG_NEW_SV(sv, file, line, func); 303 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", 304 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); 305 306 return sv; 307 } 308 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) 309 310 #else 311 # define new_SV(p) \ 312 STMT_START { \ 313 if (PL_sv_root) \ 314 uproot_SV(p); \ 315 else \ 316 (p) = S_more_sv(aTHX); \ 317 SvANY(p) = 0; \ 318 SvREFCNT(p) = 1; \ 319 SvFLAGS(p) = 0; \ 320 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ 321 } STMT_END 322 #endif 323 324 325 /* del_SV(): return an empty SV head to the free list */ 326 327 #ifdef DEBUGGING 328 329 #define del_SV(p) \ 330 STMT_START { \ 331 if (DEBUG_D_TEST) \ 332 del_sv(p); \ 333 else \ 334 plant_SV(p); \ 335 } STMT_END 336 337 STATIC void 338 S_del_sv(pTHX_ SV *p) 339 { 340 dVAR; 341 342 PERL_ARGS_ASSERT_DEL_SV; 343 344 if (DEBUG_D_TEST) { 345 SV* sva; 346 bool ok = 0; 347 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { 348 const SV * const sv = sva + 1; 349 const SV * const svend = &sva[SvREFCNT(sva)]; 350 if (p >= sv && p < svend) { 351 ok = 1; 352 break; 353 } 354 } 355 if (!ok) { 356 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 357 "Attempt to free non-arena SV: 0x%"UVxf 358 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); 359 return; 360 } 361 } 362 plant_SV(p); 363 } 364 365 #else /* ! DEBUGGING */ 366 367 #define del_SV(p) plant_SV(p) 368 369 #endif /* DEBUGGING */ 370 371 372 /* 373 =head1 SV Manipulation Functions 374 375 =for apidoc sv_add_arena 376 377 Given a chunk of memory, link it to the head of the list of arenas, 378 and split it into a list of free SVs. 379 380 =cut 381 */ 382 383 static void 384 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) 385 { 386 dVAR; 387 SV *const sva = MUTABLE_SV(ptr); 388 register SV* sv; 389 register SV* svend; 390 391 PERL_ARGS_ASSERT_SV_ADD_ARENA; 392 393 /* The first SV in an arena isn't an SV. */ 394 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ 395 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ 396 SvFLAGS(sva) = flags; /* FAKE if not to be freed */ 397 398 PL_sv_arenaroot = sva; 399 PL_sv_root = sva + 1; 400 401 svend = &sva[SvREFCNT(sva) - 1]; 402 sv = sva + 1; 403 while (sv < svend) { 404 SvARENA_CHAIN_SET(sv, (sv + 1)); 405 #ifdef DEBUGGING 406 SvREFCNT(sv) = 0; 407 #endif 408 /* Must always set typemask because it's always checked in on cleanup 409 when the arenas are walked looking for objects. */ 410 SvFLAGS(sv) = SVTYPEMASK; 411 sv++; 412 } 413 SvARENA_CHAIN_SET(sv, 0); 414 #ifdef DEBUGGING 415 SvREFCNT(sv) = 0; 416 #endif 417 SvFLAGS(sv) = SVTYPEMASK; 418 } 419 420 /* visit(): call the named function for each non-free SV in the arenas 421 * whose flags field matches the flags/mask args. */ 422 423 STATIC I32 424 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) 425 { 426 dVAR; 427 SV* sva; 428 I32 visited = 0; 429 430 PERL_ARGS_ASSERT_VISIT; 431 432 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { 433 register const SV * const svend = &sva[SvREFCNT(sva)]; 434 register SV* sv; 435 for (sv = sva + 1; sv < svend; ++sv) { 436 if (SvTYPE(sv) != SVTYPEMASK 437 && (sv->sv_flags & mask) == flags 438 && SvREFCNT(sv)) 439 { 440 (FCALL)(aTHX_ sv); 441 ++visited; 442 } 443 } 444 } 445 return visited; 446 } 447 448 #ifdef DEBUGGING 449 450 /* called by sv_report_used() for each live SV */ 451 452 static void 453 do_report_used(pTHX_ SV *const sv) 454 { 455 if (SvTYPE(sv) != SVTYPEMASK) { 456 PerlIO_printf(Perl_debug_log, "****\n"); 457 sv_dump(sv); 458 } 459 } 460 #endif 461 462 /* 463 =for apidoc sv_report_used 464 465 Dump the contents of all SVs not yet freed. (Debugging aid). 466 467 =cut 468 */ 469 470 void 471 Perl_sv_report_used(pTHX) 472 { 473 #ifdef DEBUGGING 474 visit(do_report_used, 0, 0); 475 #else 476 PERL_UNUSED_CONTEXT; 477 #endif 478 } 479 480 /* called by sv_clean_objs() for each live SV */ 481 482 static void 483 do_clean_objs(pTHX_ SV *const ref) 484 { 485 dVAR; 486 assert (SvROK(ref)); 487 { 488 SV * const target = SvRV(ref); 489 if (SvOBJECT(target)) { 490 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); 491 if (SvWEAKREF(ref)) { 492 sv_del_backref(target, ref); 493 SvWEAKREF_off(ref); 494 SvRV_set(ref, NULL); 495 } else { 496 SvROK_off(ref); 497 SvRV_set(ref, NULL); 498 SvREFCNT_dec(target); 499 } 500 } 501 } 502 503 /* XXX Might want to check arrays, etc. */ 504 } 505 506 /* called by sv_clean_objs() for each live SV */ 507 508 #ifndef DISABLE_DESTRUCTOR_KLUDGE 509 static void 510 do_clean_named_objs(pTHX_ SV *const sv) 511 { 512 dVAR; 513 assert(SvTYPE(sv) == SVt_PVGV); 514 assert(isGV_with_GP(sv)); 515 if (GvGP(sv)) { 516 if (( 517 #ifdef PERL_DONT_CREATE_GVSV 518 GvSV(sv) && 519 #endif 520 SvOBJECT(GvSV(sv))) || 521 (GvAV(sv) && SvOBJECT(GvAV(sv))) || 522 (GvHV(sv) && SvOBJECT(GvHV(sv))) || 523 /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */ 524 (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) || 525 (GvCV(sv) && SvOBJECT(GvCV(sv))) ) 526 { 527 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); 528 SvFLAGS(sv) |= SVf_BREAK; 529 SvREFCNT_dec(sv); 530 } 531 } 532 } 533 #endif 534 535 /* 536 =for apidoc sv_clean_objs 537 538 Attempt to destroy all objects not yet freed 539 540 =cut 541 */ 542 543 void 544 Perl_sv_clean_objs(pTHX) 545 { 546 dVAR; 547 PL_in_clean_objs = TRUE; 548 visit(do_clean_objs, SVf_ROK, SVf_ROK); 549 #ifndef DISABLE_DESTRUCTOR_KLUDGE 550 /* some barnacles may yet remain, clinging to typeglobs */ 551 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); 552 #endif 553 PL_in_clean_objs = FALSE; 554 } 555 556 /* called by sv_clean_all() for each live SV */ 557 558 static void 559 do_clean_all(pTHX_ SV *const sv) 560 { 561 dVAR; 562 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { 563 /* don't clean pid table and strtab */ 564 return; 565 } 566 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); 567 SvFLAGS(sv) |= SVf_BREAK; 568 SvREFCNT_dec(sv); 569 } 570 571 /* 572 =for apidoc sv_clean_all 573 574 Decrement the refcnt of each remaining SV, possibly triggering a 575 cleanup. This function may have to be called multiple times to free 576 SVs which are in complex self-referential hierarchies. 577 578 =cut 579 */ 580 581 I32 582 Perl_sv_clean_all(pTHX) 583 { 584 dVAR; 585 I32 cleaned; 586 PL_in_clean_all = TRUE; 587 cleaned = visit(do_clean_all, 0,0); 588 PL_in_clean_all = FALSE; 589 return cleaned; 590 } 591 592 /* 593 ARENASETS: a meta-arena implementation which separates arena-info 594 into struct arena_set, which contains an array of struct 595 arena_descs, each holding info for a single arena. By separating 596 the meta-info from the arena, we recover the 1st slot, formerly 597 borrowed for list management. The arena_set is about the size of an 598 arena, avoiding the needless malloc overhead of a naive linked-list. 599 600 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused 601 memory in the last arena-set (1/2 on average). In trade, we get 602 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for 603 smaller types). The recovery of the wasted space allows use of 604 small arenas for large, rare body types, by changing array* fields 605 in body_details_by_type[] below. 606 */ 607 struct arena_desc { 608 char *arena; /* the raw storage, allocated aligned */ 609 size_t size; /* its size ~4k typ */ 610 svtype utype; /* bodytype stored in arena */ 611 }; 612 613 struct arena_set; 614 615 /* Get the maximum number of elements in set[] such that struct arena_set 616 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and 617 therefore likely to be 1 aligned memory page. */ 618 619 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ 620 - 2 * sizeof(int)) / sizeof (struct arena_desc)) 621 622 struct arena_set { 623 struct arena_set* next; 624 unsigned int set_size; /* ie ARENAS_PER_SET */ 625 unsigned int curr; /* index of next available arena-desc */ 626 struct arena_desc set[ARENAS_PER_SET]; 627 }; 628 629 /* 630 =for apidoc sv_free_arenas 631 632 Deallocate the memory used by all arenas. Note that all the individual SV 633 heads and bodies within the arenas must already have been freed. 634 635 =cut 636 */ 637 void 638 Perl_sv_free_arenas(pTHX) 639 { 640 dVAR; 641 SV* sva; 642 SV* svanext; 643 unsigned int i; 644 645 /* Free arenas here, but be careful about fake ones. (We assume 646 contiguity of the fake ones with the corresponding real ones.) */ 647 648 for (sva = PL_sv_arenaroot; sva; sva = svanext) { 649 svanext = MUTABLE_SV(SvANY(sva)); 650 while (svanext && SvFAKE(svanext)) 651 svanext = MUTABLE_SV(SvANY(svanext)); 652 653 if (!SvFAKE(sva)) 654 Safefree(sva); 655 } 656 657 { 658 struct arena_set *aroot = (struct arena_set*) PL_body_arenas; 659 660 while (aroot) { 661 struct arena_set *current = aroot; 662 i = aroot->curr; 663 while (i--) { 664 assert(aroot->set[i].arena); 665 Safefree(aroot->set[i].arena); 666 } 667 aroot = aroot->next; 668 Safefree(current); 669 } 670 } 671 PL_body_arenas = 0; 672 673 i = PERL_ARENA_ROOTS_SIZE; 674 while (i--) 675 PL_body_roots[i] = 0; 676 677 Safefree(PL_nice_chunk); 678 PL_nice_chunk = NULL; 679 PL_nice_chunk_size = 0; 680 PL_sv_arenaroot = 0; 681 PL_sv_root = 0; 682 } 683 684 /* 685 Here are mid-level routines that manage the allocation of bodies out 686 of the various arenas. There are 5 kinds of arenas: 687 688 1. SV-head arenas, which are discussed and handled above 689 2. regular body arenas 690 3. arenas for reduced-size bodies 691 4. Hash-Entry arenas 692 5. pte arenas (thread related) 693 694 Arena types 2 & 3 are chained by body-type off an array of 695 arena-root pointers, which is indexed by svtype. Some of the 696 larger/less used body types are malloced singly, since a large 697 unused block of them is wasteful. Also, several svtypes dont have 698 bodies; the data fits into the sv-head itself. The arena-root 699 pointer thus has a few unused root-pointers (which may be hijacked 700 later for arena types 4,5) 701 702 3 differs from 2 as an optimization; some body types have several 703 unused fields in the front of the structure (which are kept in-place 704 for consistency). These bodies can be allocated in smaller chunks, 705 because the leading fields arent accessed. Pointers to such bodies 706 are decremented to point at the unused 'ghost' memory, knowing that 707 the pointers are used with offsets to the real memory. 708 709 HE, HEK arenas are managed separately, with separate code, but may 710 be merge-able later.. 711 712 PTE arenas are not sv-bodies, but they share these mid-level 713 mechanics, so are considered here. The new mid-level mechanics rely 714 on the sv_type of the body being allocated, so we just reserve one 715 of the unused body-slots for PTEs, then use it in those (2) PTE 716 contexts below (line ~10k) 717 */ 718 719 /* get_arena(size): this creates custom-sized arenas 720 TBD: export properly for hv.c: S_more_he(). 721 */ 722 void* 723 Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype) 724 { 725 dVAR; 726 struct arena_desc* adesc; 727 struct arena_set *aroot = (struct arena_set*) PL_body_arenas; 728 unsigned int curr; 729 730 /* shouldnt need this 731 if (!arena_size) arena_size = PERL_ARENA_SIZE; 732 */ 733 734 /* may need new arena-set to hold new arena */ 735 if (!aroot || aroot->curr >= aroot->set_size) { 736 struct arena_set *newroot; 737 Newxz(newroot, 1, struct arena_set); 738 newroot->set_size = ARENAS_PER_SET; 739 newroot->next = aroot; 740 aroot = newroot; 741 PL_body_arenas = (void *) newroot; 742 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); 743 } 744 745 /* ok, now have arena-set with at least 1 empty/available arena-desc */ 746 curr = aroot->curr++; 747 adesc = &(aroot->set[curr]); 748 assert(!adesc->arena); 749 750 Newx(adesc->arena, arena_size, char); 751 adesc->size = arena_size; 752 adesc->utype = bodytype; 753 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 754 curr, (void*)adesc->arena, (UV)arena_size)); 755 756 return adesc->arena; 757 } 758 759 760 /* return a thing to the free list */ 761 762 #define del_body(thing, root) \ 763 STMT_START { \ 764 void ** const thing_copy = (void **)thing;\ 765 *thing_copy = *root; \ 766 *root = (void*)thing_copy; \ 767 } STMT_END 768 769 /* 770 771 =head1 SV-Body Allocation 772 773 Allocation of SV-bodies is similar to SV-heads, differing as follows; 774 the allocation mechanism is used for many body types, so is somewhat 775 more complicated, it uses arena-sets, and has no need for still-live 776 SV detection. 777 778 At the outermost level, (new|del)_X*V macros return bodies of the 779 appropriate type. These macros call either (new|del)_body_type or 780 (new|del)_body_allocated macro pairs, depending on specifics of the 781 type. Most body types use the former pair, the latter pair is used to 782 allocate body types with "ghost fields". 783 784 "ghost fields" are fields that are unused in certain types, and 785 consequently don't need to actually exist. They are declared because 786 they're part of a "base type", which allows use of functions as 787 methods. The simplest examples are AVs and HVs, 2 aggregate types 788 which don't use the fields which support SCALAR semantics. 789 790 For these types, the arenas are carved up into appropriately sized 791 chunks, we thus avoid wasted memory for those unaccessed members. 792 When bodies are allocated, we adjust the pointer back in memory by the 793 size of the part not allocated, so it's as if we allocated the full 794 structure. (But things will all go boom if you write to the part that 795 is "not there", because you'll be overwriting the last members of the 796 preceding structure in memory.) 797 798 We calculate the correction using the STRUCT_OFFSET macro on the first 799 member present. If the allocated structure is smaller (no initial NV 800 actually allocated) then the net effect is to subtract the size of the NV 801 from the pointer, to return a new pointer as if an initial NV were actually 802 allocated. (We were using structures named *_allocated for this, but 803 this turned out to be a subtle bug, because a structure without an NV 804 could have a lower alignment constraint, but the compiler is allowed to 805 optimised accesses based on the alignment constraint of the actual pointer 806 to the full structure, for example, using a single 64 bit load instruction 807 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.) 808 809 This is the same trick as was used for NV and IV bodies. Ironically it 810 doesn't need to be used for NV bodies any more, because NV is now at 811 the start of the structure. IV bodies don't need it either, because 812 they are no longer allocated. 813 814 In turn, the new_body_* allocators call S_new_body(), which invokes 815 new_body_inline macro, which takes a lock, and takes a body off the 816 linked list at PL_body_roots[sv_type], calling S_more_bodies() if 817 necessary to refresh an empty list. Then the lock is released, and 818 the body is returned. 819 820 S_more_bodies calls get_arena(), and carves it up into an array of N 821 bodies, which it strings into a linked list. It looks up arena-size 822 and body-size from the body_details table described below, thus 823 supporting the multiple body-types. 824 825 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and 826 the (new|del)_X*V macros are mapped directly to malloc/free. 827 828 */ 829 830 /* 831 832 For each sv-type, struct body_details bodies_by_type[] carries 833 parameters which control these aspects of SV handling: 834 835 Arena_size determines whether arenas are used for this body type, and if 836 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to 837 zero, forcing individual mallocs and frees. 838 839 Body_size determines how big a body is, and therefore how many fit into 840 each arena. Offset carries the body-pointer adjustment needed for 841 "ghost fields", and is used in *_allocated macros. 842 843 But its main purpose is to parameterize info needed in 844 Perl_sv_upgrade(). The info here dramatically simplifies the function 845 vs the implementation in 5.8.8, making it table-driven. All fields 846 are used for this, except for arena_size. 847 848 For the sv-types that have no bodies, arenas are not used, so those 849 PL_body_roots[sv_type] are unused, and can be overloaded. In 850 something of a special case, SVt_NULL is borrowed for HE arenas; 851 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the 852 bodies_by_type[SVt_NULL] slot is not used, as the table is not 853 available in hv.c. 854 855 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless, 856 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can 857 just use the same allocation semantics. At first, PTEs were also 858 overloaded to a non-body sv-type, but this yielded hard-to-find malloc 859 bugs, so was simplified by claiming a new slot. This choice has no 860 consequence at this time. 861 862 */ 863 864 struct body_details { 865 U8 body_size; /* Size to allocate */ 866 U8 copy; /* Size of structure to copy (may be shorter) */ 867 U8 offset; 868 unsigned int type : 4; /* We have space for a sanity check. */ 869 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */ 870 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */ 871 unsigned int arena : 1; /* Allocated from an arena */ 872 size_t arena_size; /* Size of arena to allocate */ 873 }; 874 875 #define HADNV FALSE 876 #define NONV TRUE 877 878 879 #ifdef PURIFY 880 /* With -DPURFIY we allocate everything directly, and don't use arenas. 881 This seems a rather elegant way to simplify some of the code below. */ 882 #define HASARENA FALSE 883 #else 884 #define HASARENA TRUE 885 #endif 886 #define NOARENA FALSE 887 888 /* Size the arenas to exactly fit a given number of bodies. A count 889 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, 890 simplifying the default. If count > 0, the arena is sized to fit 891 only that many bodies, allowing arenas to be used for large, rare 892 bodies (XPVFM, XPVIO) without undue waste. The arena size is 893 limited by PERL_ARENA_SIZE, so we can safely oversize the 894 declarations. 895 */ 896 #define FIT_ARENA0(body_size) \ 897 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) 898 #define FIT_ARENAn(count,body_size) \ 899 ( count * body_size <= PERL_ARENA_SIZE) \ 900 ? count * body_size \ 901 : FIT_ARENA0 (body_size) 902 #define FIT_ARENA(count,body_size) \ 903 count \ 904 ? FIT_ARENAn (count, body_size) \ 905 : FIT_ARENA0 (body_size) 906 907 /* Calculate the length to copy. Specifically work out the length less any 908 final padding the compiler needed to add. See the comment in sv_upgrade 909 for why copying the padding proved to be a bug. */ 910 911 #define copy_length(type, last_member) \ 912 STRUCT_OFFSET(type, last_member) \ 913 + sizeof (((type*)SvANY((const SV *)0))->last_member) 914 915 static const struct body_details bodies_by_type[] = { 916 { sizeof(HE), 0, 0, SVt_NULL, 917 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) }, 918 919 /* The bind placeholder pretends to be an RV for now. 920 Also it's marked as "can't upgrade" to stop anyone using it before it's 921 implemented. */ 922 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, 923 924 /* IVs are in the head, so the allocation size is 0. 925 However, the slot is overloaded for PTEs. */ 926 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */ 927 sizeof(IV), /* This is used to copy out the IV body. */ 928 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, 929 NOARENA /* IVS don't need an arena */, 930 /* But PTEs need to know the size of their arena */ 931 FIT_ARENA(0, sizeof(struct ptr_tbl_ent)) 932 }, 933 934 /* 8 bytes on most ILP32 with IEEE doubles */ 935 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA, 936 FIT_ARENA(0, sizeof(NV)) }, 937 938 /* 8 bytes on most ILP32 with IEEE doubles */ 939 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), 940 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), 941 + STRUCT_OFFSET(XPV, xpv_cur), 942 SVt_PV, FALSE, NONV, HASARENA, 943 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 944 945 /* 12 */ 946 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), 947 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), 948 + STRUCT_OFFSET(XPVIV, xpv_cur), 949 SVt_PVIV, FALSE, NONV, HASARENA, 950 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, 951 952 /* 20 */ 953 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV, 954 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) }, 955 956 /* 28 */ 957 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, 958 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, 959 960 /* something big */ 961 { sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur), 962 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur), 963 + STRUCT_OFFSET(regexp, xpv_cur), 964 SVt_REGEXP, FALSE, NONV, HASARENA, 965 FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)) 966 }, 967 968 /* 48 */ 969 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, 970 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, 971 972 /* 64 */ 973 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, 974 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, 975 976 { sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill), 977 copy_length(XPVAV, xmg_stash) - STRUCT_OFFSET(XPVAV, xav_fill), 978 + STRUCT_OFFSET(XPVAV, xav_fill), 979 SVt_PVAV, TRUE, NONV, HASARENA, 980 FIT_ARENA(0, sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill)) }, 981 982 { sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill), 983 copy_length(XPVHV, xmg_stash) - STRUCT_OFFSET(XPVHV, xhv_fill), 984 + STRUCT_OFFSET(XPVHV, xhv_fill), 985 SVt_PVHV, TRUE, NONV, HASARENA, 986 FIT_ARENA(0, sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill)) }, 987 988 /* 56 */ 989 { sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur), 990 sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur), 991 + STRUCT_OFFSET(XPVCV, xpv_cur), 992 SVt_PVCV, TRUE, NONV, HASARENA, 993 FIT_ARENA(0, sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur)) }, 994 995 { sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur), 996 sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur), 997 + STRUCT_OFFSET(XPVFM, xpv_cur), 998 SVt_PVFM, TRUE, NONV, NOARENA, 999 FIT_ARENA(20, sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur)) }, 1000 1001 /* XPVIO is 84 bytes, fits 48x */ 1002 { sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur), 1003 sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur), 1004 + STRUCT_OFFSET(XPVIO, xpv_cur), 1005 SVt_PVIO, TRUE, NONV, HASARENA, 1006 FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) }, 1007 }; 1008 1009 #define new_body_type(sv_type) \ 1010 (void *)((char *)S_new_body(aTHX_ sv_type)) 1011 1012 #define del_body_type(p, sv_type) \ 1013 del_body(p, &PL_body_roots[sv_type]) 1014 1015 1016 #define new_body_allocated(sv_type) \ 1017 (void *)((char *)S_new_body(aTHX_ sv_type) \ 1018 - bodies_by_type[sv_type].offset) 1019 1020 #define del_body_allocated(p, sv_type) \ 1021 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) 1022 1023 1024 #define my_safemalloc(s) (void*)safemalloc(s) 1025 #define my_safecalloc(s) (void*)safecalloc(s, 1) 1026 #define my_safefree(p) safefree((char*)p) 1027 1028 #ifdef PURIFY 1029 1030 #define new_XNV() my_safemalloc(sizeof(XPVNV)) 1031 #define del_XNV(p) my_safefree(p) 1032 1033 #define new_XPVNV() my_safemalloc(sizeof(XPVNV)) 1034 #define del_XPVNV(p) my_safefree(p) 1035 1036 #define new_XPVAV() my_safemalloc(sizeof(XPVAV)) 1037 #define del_XPVAV(p) my_safefree(p) 1038 1039 #define new_XPVHV() my_safemalloc(sizeof(XPVHV)) 1040 #define del_XPVHV(p) my_safefree(p) 1041 1042 #define new_XPVMG() my_safemalloc(sizeof(XPVMG)) 1043 #define del_XPVMG(p) my_safefree(p) 1044 1045 #define new_XPVGV() my_safemalloc(sizeof(XPVGV)) 1046 #define del_XPVGV(p) my_safefree(p) 1047 1048 #else /* !PURIFY */ 1049 1050 #define new_XNV() new_body_type(SVt_NV) 1051 #define del_XNV(p) del_body_type(p, SVt_NV) 1052 1053 #define new_XPVNV() new_body_type(SVt_PVNV) 1054 #define del_XPVNV(p) del_body_type(p, SVt_PVNV) 1055 1056 #define new_XPVAV() new_body_allocated(SVt_PVAV) 1057 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) 1058 1059 #define new_XPVHV() new_body_allocated(SVt_PVHV) 1060 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) 1061 1062 #define new_XPVMG() new_body_type(SVt_PVMG) 1063 #define del_XPVMG(p) del_body_type(p, SVt_PVMG) 1064 1065 #define new_XPVGV() new_body_type(SVt_PVGV) 1066 #define del_XPVGV(p) del_body_type(p, SVt_PVGV) 1067 1068 #endif /* PURIFY */ 1069 1070 /* no arena for you! */ 1071 1072 #define new_NOARENA(details) \ 1073 my_safemalloc((details)->body_size + (details)->offset) 1074 #define new_NOARENAZ(details) \ 1075 my_safecalloc((details)->body_size + (details)->offset) 1076 1077 STATIC void * 1078 S_more_bodies (pTHX_ const svtype sv_type) 1079 { 1080 dVAR; 1081 void ** const root = &PL_body_roots[sv_type]; 1082 const struct body_details * const bdp = &bodies_by_type[sv_type]; 1083 const size_t body_size = bdp->body_size; 1084 char *start; 1085 const char *end; 1086 const size_t arena_size = Perl_malloc_good_size(bdp->arena_size); 1087 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 1088 static bool done_sanity_check; 1089 1090 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global 1091 * variables like done_sanity_check. */ 1092 if (!done_sanity_check) { 1093 unsigned int i = SVt_LAST; 1094 1095 done_sanity_check = TRUE; 1096 1097 while (i--) 1098 assert (bodies_by_type[i].type == i); 1099 } 1100 #endif 1101 1102 assert(bdp->arena_size); 1103 1104 start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type); 1105 1106 end = start + arena_size - 2 * body_size; 1107 1108 /* computed count doesnt reflect the 1st slot reservation */ 1109 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) 1110 DEBUG_m(PerlIO_printf(Perl_debug_log, 1111 "arena %p end %p arena-size %d (from %d) type %d " 1112 "size %d ct %d\n", 1113 (void*)start, (void*)end, (int)arena_size, 1114 (int)bdp->arena_size, sv_type, (int)body_size, 1115 (int)arena_size / (int)body_size)); 1116 #else 1117 DEBUG_m(PerlIO_printf(Perl_debug_log, 1118 "arena %p end %p arena-size %d type %d size %d ct %d\n", 1119 (void*)start, (void*)end, 1120 (int)bdp->arena_size, sv_type, (int)body_size, 1121 (int)bdp->arena_size / (int)body_size)); 1122 #endif 1123 *root = (void *)start; 1124 1125 while (start <= end) { 1126 char * const next = start + body_size; 1127 *(void**) start = (void *)next; 1128 start = next; 1129 } 1130 *(void **)start = 0; 1131 1132 return *root; 1133 } 1134 1135 /* grab a new thing from the free list, allocating more if necessary. 1136 The inline version is used for speed in hot routines, and the 1137 function using it serves the rest (unless PURIFY). 1138 */ 1139 #define new_body_inline(xpv, sv_type) \ 1140 STMT_START { \ 1141 void ** const r3wt = &PL_body_roots[sv_type]; \ 1142 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ 1143 ? *((void **)(r3wt)) : more_bodies(sv_type)); \ 1144 *(r3wt) = *(void**)(xpv); \ 1145 } STMT_END 1146 1147 #ifndef PURIFY 1148 1149 STATIC void * 1150 S_new_body(pTHX_ const svtype sv_type) 1151 { 1152 dVAR; 1153 void *xpv; 1154 new_body_inline(xpv, sv_type); 1155 return xpv; 1156 } 1157 1158 #endif 1159 1160 static const struct body_details fake_rv = 1161 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; 1162 1163 /* 1164 =for apidoc sv_upgrade 1165 1166 Upgrade an SV to a more complex form. Generally adds a new body type to the 1167 SV, then copies across as much information as possible from the old body. 1168 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>. 1169 1170 =cut 1171 */ 1172 1173 void 1174 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) 1175 { 1176 dVAR; 1177 void* old_body; 1178 void* new_body; 1179 const svtype old_type = SvTYPE(sv); 1180 const struct body_details *new_type_details; 1181 const struct body_details *old_type_details 1182 = bodies_by_type + old_type; 1183 SV *referant = NULL; 1184 1185 PERL_ARGS_ASSERT_SV_UPGRADE; 1186 1187 if (old_type == new_type) 1188 return; 1189 1190 /* This clause was purposefully added ahead of the early return above to 1191 the shared string hackery for (sort {$a <=> $b} keys %hash), with the 1192 inference by Nick I-S that it would fix other troublesome cases. See 1193 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent) 1194 1195 Given that shared hash key scalars are no longer PVIV, but PV, there is 1196 no longer need to unshare so as to free up the IVX slot for its proper 1197 purpose. So it's safe to move the early return earlier. */ 1198 1199 if (new_type != SVt_PV && SvIsCOW(sv)) { 1200 sv_force_normal_flags(sv, 0); 1201 } 1202 1203 old_body = SvANY(sv); 1204 1205 /* Copying structures onto other structures that have been neatly zeroed 1206 has a subtle gotcha. Consider XPVMG 1207 1208 +------+------+------+------+------+-------+-------+ 1209 | NV | CUR | LEN | IV | MAGIC | STASH | 1210 +------+------+------+------+------+-------+-------+ 1211 0 4 8 12 16 20 24 28 1212 1213 where NVs are aligned to 8 bytes, so that sizeof that structure is 1214 actually 32 bytes long, with 4 bytes of padding at the end: 1215 1216 +------+------+------+------+------+-------+-------+------+ 1217 | NV | CUR | LEN | IV | MAGIC | STASH | ??? | 1218 +------+------+------+------+------+-------+-------+------+ 1219 0 4 8 12 16 20 24 28 32 1220 1221 so what happens if you allocate memory for this structure: 1222 1223 +------+------+------+------+------+-------+-------+------+------+... 1224 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | 1225 +------+------+------+------+------+-------+-------+------+------+... 1226 0 4 8 12 16 20 24 28 32 36 1227 1228 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you 1229 expect, because you copy the area marked ??? onto GP. Now, ??? may have 1230 started out as zero once, but it's quite possible that it isn't. So now, 1231 rather than a nicely zeroed GP, you have it pointing somewhere random. 1232 Bugs ensue. 1233 1234 (In fact, GP ends up pointing at a previous GP structure, because the 1235 principle cause of the padding in XPVMG getting garbage is a copy of 1236 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now 1237 this happens to be moot because XPVGV has been re-ordered, with GP 1238 no longer after STASH) 1239 1240 So we are careful and work out the size of used parts of all the 1241 structures. */ 1242 1243 switch (old_type) { 1244 case SVt_NULL: 1245 break; 1246 case SVt_IV: 1247 if (SvROK(sv)) { 1248 referant = SvRV(sv); 1249 old_type_details = &fake_rv; 1250 if (new_type == SVt_NV) 1251 new_type = SVt_PVNV; 1252 } else { 1253 if (new_type < SVt_PVIV) { 1254 new_type = (new_type == SVt_NV) 1255 ? SVt_PVNV : SVt_PVIV; 1256 } 1257 } 1258 break; 1259 case SVt_NV: 1260 if (new_type < SVt_PVNV) { 1261 new_type = SVt_PVNV; 1262 } 1263 break; 1264 case SVt_PV: 1265 assert(new_type > SVt_PV); 1266 assert(SVt_IV < SVt_PV); 1267 assert(SVt_NV < SVt_PV); 1268 break; 1269 case SVt_PVIV: 1270 break; 1271 case SVt_PVNV: 1272 break; 1273 case SVt_PVMG: 1274 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, 1275 there's no way that it can be safely upgraded, because perl.c 1276 expects to Safefree(SvANY(PL_mess_sv)) */ 1277 assert(sv != PL_mess_sv); 1278 /* This flag bit is used to mean other things in other scalar types. 1279 Given that it only has meaning inside the pad, it shouldn't be set 1280 on anything that can get upgraded. */ 1281 assert(!SvPAD_TYPED(sv)); 1282 break; 1283 default: 1284 if (old_type_details->cant_upgrade) 1285 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, 1286 sv_reftype(sv, 0), (UV) old_type, (UV) new_type); 1287 } 1288 1289 if (old_type > new_type) 1290 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", 1291 (int)old_type, (int)new_type); 1292 1293 new_type_details = bodies_by_type + new_type; 1294 1295 SvFLAGS(sv) &= ~SVTYPEMASK; 1296 SvFLAGS(sv) |= new_type; 1297 1298 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of 1299 the return statements above will have triggered. */ 1300 assert (new_type != SVt_NULL); 1301 switch (new_type) { 1302 case SVt_IV: 1303 assert(old_type == SVt_NULL); 1304 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 1305 SvIV_set(sv, 0); 1306 return; 1307 case SVt_NV: 1308 assert(old_type == SVt_NULL); 1309 SvANY(sv) = new_XNV(); 1310 SvNV_set(sv, 0); 1311 return; 1312 case SVt_PVHV: 1313 case SVt_PVAV: 1314 assert(new_type_details->body_size); 1315 1316 #ifndef PURIFY 1317 assert(new_type_details->arena); 1318 assert(new_type_details->arena_size); 1319 /* This points to the start of the allocated area. */ 1320 new_body_inline(new_body, new_type); 1321 Zero(new_body, new_type_details->body_size, char); 1322 new_body = ((char *)new_body) - new_type_details->offset; 1323 #else 1324 /* We always allocated the full length item with PURIFY. To do this 1325 we fake things so that arena is false for all 16 types.. */ 1326 new_body = new_NOARENAZ(new_type_details); 1327 #endif 1328 SvANY(sv) = new_body; 1329 if (new_type == SVt_PVAV) { 1330 AvMAX(sv) = -1; 1331 AvFILLp(sv) = -1; 1332 AvREAL_only(sv); 1333 if (old_type_details->body_size) { 1334 AvALLOC(sv) = 0; 1335 } else { 1336 /* It will have been zeroed when the new body was allocated. 1337 Lets not write to it, in case it confuses a write-back 1338 cache. */ 1339 } 1340 } else { 1341 assert(!SvOK(sv)); 1342 SvOK_off(sv); 1343 #ifndef NODEFAULT_SHAREKEYS 1344 HvSHAREKEYS_on(sv); /* key-sharing on by default */ 1345 #endif 1346 HvMAX(sv) = 7; /* (start with 8 buckets) */ 1347 if (old_type_details->body_size) { 1348 HvFILL(sv) = 0; 1349 } else { 1350 /* It will have been zeroed when the new body was allocated. 1351 Lets not write to it, in case it confuses a write-back 1352 cache. */ 1353 } 1354 } 1355 1356 /* SVt_NULL isn't the only thing upgraded to AV or HV. 1357 The target created by newSVrv also is, and it can have magic. 1358 However, it never has SvPVX set. 1359 */ 1360 if (old_type == SVt_IV) { 1361 assert(!SvROK(sv)); 1362 } else if (old_type >= SVt_PV) { 1363 assert(SvPVX_const(sv) == 0); 1364 } 1365 1366 if (old_type >= SVt_PVMG) { 1367 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); 1368 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); 1369 } else { 1370 sv->sv_u.svu_array = NULL; /* or svu_hash */ 1371 } 1372 break; 1373 1374 1375 case SVt_REGEXP: 1376 /* This ensures that SvTHINKFIRST(sv) is true, and hence that 1377 sv_force_normal_flags(sv) is called. */ 1378 SvFAKE_on(sv); 1379 case SVt_PVIV: 1380 /* XXX Is this still needed? Was it ever needed? Surely as there is 1381 no route from NV to PVIV, NOK can never be true */ 1382 assert(!SvNOKp(sv)); 1383 assert(!SvNOK(sv)); 1384 case SVt_PVIO: 1385 case SVt_PVFM: 1386 case SVt_PVGV: 1387 case SVt_PVCV: 1388 case SVt_PVLV: 1389 case SVt_PVMG: 1390 case SVt_PVNV: 1391 case SVt_PV: 1392 1393 assert(new_type_details->body_size); 1394 /* We always allocated the full length item with PURIFY. To do this 1395 we fake things so that arena is false for all 16 types.. */ 1396 if(new_type_details->arena) { 1397 /* This points to the start of the allocated area. */ 1398 new_body_inline(new_body, new_type); 1399 Zero(new_body, new_type_details->body_size, char); 1400 new_body = ((char *)new_body) - new_type_details->offset; 1401 } else { 1402 new_body = new_NOARENAZ(new_type_details); 1403 } 1404 SvANY(sv) = new_body; 1405 1406 if (old_type_details->copy) { 1407 /* There is now the potential for an upgrade from something without 1408 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ 1409 int offset = old_type_details->offset; 1410 int length = old_type_details->copy; 1411 1412 if (new_type_details->offset > old_type_details->offset) { 1413 const int difference 1414 = new_type_details->offset - old_type_details->offset; 1415 offset += difference; 1416 length -= difference; 1417 } 1418 assert (length >= 0); 1419 1420 Copy((char *)old_body + offset, (char *)new_body + offset, length, 1421 char); 1422 } 1423 1424 #ifndef NV_ZERO_IS_ALLBITS_ZERO 1425 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a 1426 * correct 0.0 for us. Otherwise, if the old body didn't have an 1427 * NV slot, but the new one does, then we need to initialise the 1428 * freshly created NV slot with whatever the correct bit pattern is 1429 * for 0.0 */ 1430 if (old_type_details->zero_nv && !new_type_details->zero_nv 1431 && !isGV_with_GP(sv)) 1432 SvNV_set(sv, 0); 1433 #endif 1434 1435 if (new_type == SVt_PVIO) { 1436 IO * const io = MUTABLE_IO(sv); 1437 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); 1438 1439 SvOBJECT_on(io); 1440 /* Clear the stashcache because a new IO could overrule a package 1441 name */ 1442 hv_clear(PL_stashcache); 1443 1444 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); 1445 IoPAGE_LEN(sv) = 60; 1446 } 1447 if (old_type < SVt_PV) { 1448 /* referant will be NULL unless the old type was SVt_IV emulating 1449 SVt_RV */ 1450 sv->sv_u.svu_rv = referant; 1451 } 1452 break; 1453 default: 1454 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", 1455 (unsigned long)new_type); 1456 } 1457 1458 if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */ 1459 #ifdef PURIFY 1460 my_safefree(old_body); 1461 #else 1462 /* Note that there is an assumption that all bodies of types that 1463 can be upgraded came from arenas. Only the more complex non- 1464 upgradable types are allowed to be directly malloc()ed. */ 1465 assert(old_type_details->arena); 1466 del_body((void*)((char*)old_body + old_type_details->offset), 1467 &PL_body_roots[old_type]); 1468 #endif 1469 } 1470 } 1471 1472 /* 1473 =for apidoc sv_backoff 1474 1475 Remove any string offset. You should normally use the C<SvOOK_off> macro 1476 wrapper instead. 1477 1478 =cut 1479 */ 1480 1481 int 1482 Perl_sv_backoff(pTHX_ register SV *const sv) 1483 { 1484 STRLEN delta; 1485 const char * const s = SvPVX_const(sv); 1486 1487 PERL_ARGS_ASSERT_SV_BACKOFF; 1488 PERL_UNUSED_CONTEXT; 1489 1490 assert(SvOOK(sv)); 1491 assert(SvTYPE(sv) != SVt_PVHV); 1492 assert(SvTYPE(sv) != SVt_PVAV); 1493 1494 SvOOK_offset(sv, delta); 1495 1496 SvLEN_set(sv, SvLEN(sv) + delta); 1497 SvPV_set(sv, SvPVX(sv) - delta); 1498 Move(s, SvPVX(sv), SvCUR(sv)+1, char); 1499 SvFLAGS(sv) &= ~SVf_OOK; 1500 return 0; 1501 } 1502 1503 /* 1504 =for apidoc sv_grow 1505 1506 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and 1507 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. 1508 Use the C<SvGROW> wrapper instead. 1509 1510 =cut 1511 */ 1512 1513 char * 1514 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) 1515 { 1516 register char *s; 1517 1518 PERL_ARGS_ASSERT_SV_GROW; 1519 1520 if (PL_madskills && newlen >= 0x100000) { 1521 PerlIO_printf(Perl_debug_log, 1522 "Allocation too large: %"UVxf"\n", (UV)newlen); 1523 } 1524 #ifdef HAS_64K_LIMIT 1525 if (newlen >= 0x10000) { 1526 PerlIO_printf(Perl_debug_log, 1527 "Allocation too large: %"UVxf"\n", (UV)newlen); 1528 my_exit(1); 1529 } 1530 #endif /* HAS_64K_LIMIT */ 1531 if (SvROK(sv)) 1532 sv_unref(sv); 1533 if (SvTYPE(sv) < SVt_PV) { 1534 sv_upgrade(sv, SVt_PV); 1535 s = SvPVX_mutable(sv); 1536 } 1537 else if (SvOOK(sv)) { /* pv is offset? */ 1538 sv_backoff(sv); 1539 s = SvPVX_mutable(sv); 1540 if (newlen > SvLEN(sv)) 1541 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ 1542 #ifdef HAS_64K_LIMIT 1543 if (newlen >= 0x10000) 1544 newlen = 0xFFFF; 1545 #endif 1546 } 1547 else 1548 s = SvPVX_mutable(sv); 1549 1550 if (newlen > SvLEN(sv)) { /* need more room? */ 1551 #ifndef Perl_safesysmalloc_size 1552 newlen = PERL_STRLEN_ROUNDUP(newlen); 1553 #endif 1554 if (SvLEN(sv) && s) { 1555 s = (char*)saferealloc(s, newlen); 1556 } 1557 else { 1558 s = (char*)safemalloc(newlen); 1559 if (SvPVX_const(sv) && SvCUR(sv)) { 1560 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); 1561 } 1562 } 1563 SvPV_set(sv, s); 1564 #ifdef Perl_safesysmalloc_size 1565 /* Do this here, do it once, do it right, and then we will never get 1566 called back into sv_grow() unless there really is some growing 1567 needed. */ 1568 SvLEN_set(sv, Perl_safesysmalloc_size(s)); 1569 #else 1570 SvLEN_set(sv, newlen); 1571 #endif 1572 } 1573 return s; 1574 } 1575 1576 /* 1577 =for apidoc sv_setiv 1578 1579 Copies an integer into the given SV, upgrading first if necessary. 1580 Does not handle 'set' magic. See also C<sv_setiv_mg>. 1581 1582 =cut 1583 */ 1584 1585 void 1586 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i) 1587 { 1588 dVAR; 1589 1590 PERL_ARGS_ASSERT_SV_SETIV; 1591 1592 SV_CHECK_THINKFIRST_COW_DROP(sv); 1593 switch (SvTYPE(sv)) { 1594 case SVt_NULL: 1595 case SVt_NV: 1596 sv_upgrade(sv, SVt_IV); 1597 break; 1598 case SVt_PV: 1599 sv_upgrade(sv, SVt_PVIV); 1600 break; 1601 1602 case SVt_PVGV: 1603 if (!isGV_with_GP(sv)) 1604 break; 1605 case SVt_PVAV: 1606 case SVt_PVHV: 1607 case SVt_PVCV: 1608 case SVt_PVFM: 1609 case SVt_PVIO: 1610 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), 1611 OP_DESC(PL_op)); 1612 default: NOOP; 1613 } 1614 (void)SvIOK_only(sv); /* validate number */ 1615 SvIV_set(sv, i); 1616 SvTAINT(sv); 1617 } 1618 1619 /* 1620 =for apidoc sv_setiv_mg 1621 1622 Like C<sv_setiv>, but also handles 'set' magic. 1623 1624 =cut 1625 */ 1626 1627 void 1628 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i) 1629 { 1630 PERL_ARGS_ASSERT_SV_SETIV_MG; 1631 1632 sv_setiv(sv,i); 1633 SvSETMAGIC(sv); 1634 } 1635 1636 /* 1637 =for apidoc sv_setuv 1638 1639 Copies an unsigned integer into the given SV, upgrading first if necessary. 1640 Does not handle 'set' magic. See also C<sv_setuv_mg>. 1641 1642 =cut 1643 */ 1644 1645 void 1646 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u) 1647 { 1648 PERL_ARGS_ASSERT_SV_SETUV; 1649 1650 /* With these two if statements: 1651 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 1652 1653 without 1654 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 1655 1656 If you wish to remove them, please benchmark to see what the effect is 1657 */ 1658 if (u <= (UV)IV_MAX) { 1659 sv_setiv(sv, (IV)u); 1660 return; 1661 } 1662 sv_setiv(sv, 0); 1663 SvIsUV_on(sv); 1664 SvUV_set(sv, u); 1665 } 1666 1667 /* 1668 =for apidoc sv_setuv_mg 1669 1670 Like C<sv_setuv>, but also handles 'set' magic. 1671 1672 =cut 1673 */ 1674 1675 void 1676 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u) 1677 { 1678 PERL_ARGS_ASSERT_SV_SETUV_MG; 1679 1680 sv_setuv(sv,u); 1681 SvSETMAGIC(sv); 1682 } 1683 1684 /* 1685 =for apidoc sv_setnv 1686 1687 Copies a double into the given SV, upgrading first if necessary. 1688 Does not handle 'set' magic. See also C<sv_setnv_mg>. 1689 1690 =cut 1691 */ 1692 1693 void 1694 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) 1695 { 1696 dVAR; 1697 1698 PERL_ARGS_ASSERT_SV_SETNV; 1699 1700 SV_CHECK_THINKFIRST_COW_DROP(sv); 1701 switch (SvTYPE(sv)) { 1702 case SVt_NULL: 1703 case SVt_IV: 1704 sv_upgrade(sv, SVt_NV); 1705 break; 1706 case SVt_PV: 1707 case SVt_PVIV: 1708 sv_upgrade(sv, SVt_PVNV); 1709 break; 1710 1711 case SVt_PVGV: 1712 if (!isGV_with_GP(sv)) 1713 break; 1714 case SVt_PVAV: 1715 case SVt_PVHV: 1716 case SVt_PVCV: 1717 case SVt_PVFM: 1718 case SVt_PVIO: 1719 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), 1720 OP_NAME(PL_op)); 1721 default: NOOP; 1722 } 1723 SvNV_set(sv, num); 1724 (void)SvNOK_only(sv); /* validate number */ 1725 SvTAINT(sv); 1726 } 1727 1728 /* 1729 =for apidoc sv_setnv_mg 1730 1731 Like C<sv_setnv>, but also handles 'set' magic. 1732 1733 =cut 1734 */ 1735 1736 void 1737 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num) 1738 { 1739 PERL_ARGS_ASSERT_SV_SETNV_MG; 1740 1741 sv_setnv(sv,num); 1742 SvSETMAGIC(sv); 1743 } 1744 1745 /* Print an "isn't numeric" warning, using a cleaned-up, 1746 * printable version of the offending string 1747 */ 1748 1749 STATIC void 1750 S_not_a_number(pTHX_ SV *const sv) 1751 { 1752 dVAR; 1753 SV *dsv; 1754 char tmpbuf[64]; 1755 const char *pv; 1756 1757 PERL_ARGS_ASSERT_NOT_A_NUMBER; 1758 1759 if (DO_UTF8(sv)) { 1760 dsv = newSVpvs_flags("", SVs_TEMP); 1761 pv = sv_uni_display(dsv, sv, 10, 0); 1762 } else { 1763 char *d = tmpbuf; 1764 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; 1765 /* each *s can expand to 4 chars + "...\0", 1766 i.e. need room for 8 chars */ 1767 1768 const char *s = SvPVX_const(sv); 1769 const char * const end = s + SvCUR(sv); 1770 for ( ; s < end && d < limit; s++ ) { 1771 int ch = *s & 0xFF; 1772 if (ch & 128 && !isPRINT_LC(ch)) { 1773 *d++ = 'M'; 1774 *d++ = '-'; 1775 ch &= 127; 1776 } 1777 if (ch == '\n') { 1778 *d++ = '\\'; 1779 *d++ = 'n'; 1780 } 1781 else if (ch == '\r') { 1782 *d++ = '\\'; 1783 *d++ = 'r'; 1784 } 1785 else if (ch == '\f') { 1786 *d++ = '\\'; 1787 *d++ = 'f'; 1788 } 1789 else if (ch == '\\') { 1790 *d++ = '\\'; 1791 *d++ = '\\'; 1792 } 1793 else if (ch == '\0') { 1794 *d++ = '\\'; 1795 *d++ = '0'; 1796 } 1797 else if (isPRINT_LC(ch)) 1798 *d++ = ch; 1799 else { 1800 *d++ = '^'; 1801 *d++ = toCTRL(ch); 1802 } 1803 } 1804 if (s < end) { 1805 *d++ = '.'; 1806 *d++ = '.'; 1807 *d++ = '.'; 1808 } 1809 *d = '\0'; 1810 pv = tmpbuf; 1811 } 1812 1813 if (PL_op) 1814 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), 1815 "Argument \"%s\" isn't numeric in %s", pv, 1816 OP_DESC(PL_op)); 1817 else 1818 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), 1819 "Argument \"%s\" isn't numeric", pv); 1820 } 1821 1822 /* 1823 =for apidoc looks_like_number 1824 1825 Test if the content of an SV looks like a number (or is a number). 1826 C<Inf> and C<Infinity> are treated as numbers (so will not issue a 1827 non-numeric warning), even if your atof() doesn't grok them. 1828 1829 =cut 1830 */ 1831 1832 I32 1833 Perl_looks_like_number(pTHX_ SV *const sv) 1834 { 1835 register const char *sbegin; 1836 STRLEN len; 1837 1838 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; 1839 1840 if (SvPOK(sv)) { 1841 sbegin = SvPVX_const(sv); 1842 len = SvCUR(sv); 1843 } 1844 else if (SvPOKp(sv)) 1845 sbegin = SvPV_const(sv, len); 1846 else 1847 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); 1848 return grok_number(sbegin, len, NULL); 1849 } 1850 1851 STATIC bool 1852 S_glob_2number(pTHX_ GV * const gv) 1853 { 1854 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; 1855 SV *const buffer = sv_newmortal(); 1856 1857 PERL_ARGS_ASSERT_GLOB_2NUMBER; 1858 1859 /* FAKE globs can get coerced, so need to turn this off temporarily if it 1860 is on. */ 1861 SvFAKE_off(gv); 1862 gv_efullname3(buffer, gv, "*"); 1863 SvFLAGS(gv) |= wasfake; 1864 1865 /* We know that all GVs stringify to something that is not-a-number, 1866 so no need to test that. */ 1867 if (ckWARN(WARN_NUMERIC)) 1868 not_a_number(buffer); 1869 /* We just want something true to return, so that S_sv_2iuv_common 1870 can tail call us and return true. */ 1871 return TRUE; 1872 } 1873 1874 /* Actually, ISO C leaves conversion of UV to IV undefined, but 1875 until proven guilty, assume that things are not that bad... */ 1876 1877 /* 1878 NV_PRESERVES_UV: 1879 1880 As 64 bit platforms often have an NV that doesn't preserve all bits of 1881 an IV (an assumption perl has been based on to date) it becomes necessary 1882 to remove the assumption that the NV always carries enough precision to 1883 recreate the IV whenever needed, and that the NV is the canonical form. 1884 Instead, IV/UV and NV need to be given equal rights. So as to not lose 1885 precision as a side effect of conversion (which would lead to insanity 1886 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is 1887 1) to distinguish between IV/UV/NV slots that have cached a valid 1888 conversion where precision was lost and IV/UV/NV slots that have a 1889 valid conversion which has lost no precision 1890 2) to ensure that if a numeric conversion to one form is requested that 1891 would lose precision, the precise conversion (or differently 1892 imprecise conversion) is also performed and cached, to prevent 1893 requests for different numeric formats on the same SV causing 1894 lossy conversion chains. (lossless conversion chains are perfectly 1895 acceptable (still)) 1896 1897 1898 flags are used: 1899 SvIOKp is true if the IV slot contains a valid value 1900 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) 1901 SvNOKp is true if the NV slot contains a valid value 1902 SvNOK is true only if the NV value is accurate 1903 1904 so 1905 while converting from PV to NV, check to see if converting that NV to an 1906 IV(or UV) would lose accuracy over a direct conversion from PV to 1907 IV(or UV). If it would, cache both conversions, return NV, but mark 1908 SV as IOK NOKp (ie not NOK). 1909 1910 While converting from PV to IV, check to see if converting that IV to an 1911 NV would lose accuracy over a direct conversion from PV to NV. If it 1912 would, cache both conversions, flag similarly. 1913 1914 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite 1915 correctly because if IV & NV were set NV *always* overruled. 1916 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning 1917 changes - now IV and NV together means that the two are interchangeable: 1918 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; 1919 1920 The benefit of this is that operations such as pp_add know that if 1921 SvIOK is true for both left and right operands, then integer addition 1922 can be used instead of floating point (for cases where the result won't 1923 overflow). Before, floating point was always used, which could lead to 1924 loss of precision compared with integer addition. 1925 1926 * making IV and NV equal status should make maths accurate on 64 bit 1927 platforms 1928 * may speed up maths somewhat if pp_add and friends start to use 1929 integers when possible instead of fp. (Hopefully the overhead in 1930 looking for SvIOK and checking for overflow will not outweigh the 1931 fp to integer speedup) 1932 * will slow down integer operations (callers of SvIV) on "inaccurate" 1933 values, as the change from SvIOK to SvIOKp will cause a call into 1934 sv_2iv each time rather than a macro access direct to the IV slot 1935 * should speed up number->string conversion on integers as IV is 1936 favoured when IV and NV are equally accurate 1937 1938 #################################################################### 1939 You had better be using SvIOK_notUV if you want an IV for arithmetic: 1940 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. 1941 On the other hand, SvUOK is true iff UV. 1942 #################################################################### 1943 1944 Your mileage will vary depending your CPU's relative fp to integer 1945 performance ratio. 1946 */ 1947 1948 #ifndef NV_PRESERVES_UV 1949 # define IS_NUMBER_UNDERFLOW_IV 1 1950 # define IS_NUMBER_UNDERFLOW_UV 2 1951 # define IS_NUMBER_IV_AND_UV 2 1952 # define IS_NUMBER_OVERFLOW_IV 4 1953 # define IS_NUMBER_OVERFLOW_UV 5 1954 1955 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ 1956 1957 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ 1958 STATIC int 1959 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv 1960 # ifdef DEBUGGING 1961 , I32 numtype 1962 # endif 1963 ) 1964 { 1965 dVAR; 1966 1967 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; 1968 1969 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)); 1970 if (SvNVX(sv) < (NV)IV_MIN) { 1971 (void)SvIOKp_on(sv); 1972 (void)SvNOK_on(sv); 1973 SvIV_set(sv, IV_MIN); 1974 return IS_NUMBER_UNDERFLOW_IV; 1975 } 1976 if (SvNVX(sv) > (NV)UV_MAX) { 1977 (void)SvIOKp_on(sv); 1978 (void)SvNOK_on(sv); 1979 SvIsUV_on(sv); 1980 SvUV_set(sv, UV_MAX); 1981 return IS_NUMBER_OVERFLOW_UV; 1982 } 1983 (void)SvIOKp_on(sv); 1984 (void)SvNOK_on(sv); 1985 /* Can't use strtol etc to convert this string. (See truth table in 1986 sv_2iv */ 1987 if (SvNVX(sv) <= (UV)IV_MAX) { 1988 SvIV_set(sv, I_V(SvNVX(sv))); 1989 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 1990 SvIOK_on(sv); /* Integer is precise. NOK, IOK */ 1991 } else { 1992 /* Integer is imprecise. NOK, IOKp */ 1993 } 1994 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; 1995 } 1996 SvIsUV_on(sv); 1997 SvUV_set(sv, U_V(SvNVX(sv))); 1998 if ((NV)(SvUVX(sv)) == SvNVX(sv)) { 1999 if (SvUVX(sv) == UV_MAX) { 2000 /* As we know that NVs don't preserve UVs, UV_MAX cannot 2001 possibly be preserved by NV. Hence, it must be overflow. 2002 NOK, IOKp */ 2003 return IS_NUMBER_OVERFLOW_UV; 2004 } 2005 SvIOK_on(sv); /* Integer is precise. NOK, UOK */ 2006 } else { 2007 /* Integer is imprecise. NOK, IOKp */ 2008 } 2009 return IS_NUMBER_OVERFLOW_IV; 2010 } 2011 #endif /* !NV_PRESERVES_UV*/ 2012 2013 STATIC bool 2014 S_sv_2iuv_common(pTHX_ SV *const sv) 2015 { 2016 dVAR; 2017 2018 PERL_ARGS_ASSERT_SV_2IUV_COMMON; 2019 2020 if (SvNOKp(sv)) { 2021 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv 2022 * without also getting a cached IV/UV from it at the same time 2023 * (ie PV->NV conversion should detect loss of accuracy and cache 2024 * IV or UV at same time to avoid this. */ 2025 /* IV-over-UV optimisation - choose to cache IV if possible */ 2026 2027 if (SvTYPE(sv) == SVt_NV) 2028 sv_upgrade(sv, SVt_PVNV); 2029 2030 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ 2031 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost 2032 certainly cast into the IV range at IV_MAX, whereas the correct 2033 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary 2034 cases go to UV */ 2035 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2036 if (Perl_isnan(SvNVX(sv))) { 2037 SvUV_set(sv, 0); 2038 SvIsUV_on(sv); 2039 return FALSE; 2040 } 2041 #endif 2042 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2043 SvIV_set(sv, I_V(SvNVX(sv))); 2044 if (SvNVX(sv) == (NV) SvIVX(sv) 2045 #ifndef NV_PRESERVES_UV 2046 && (((UV)1 << NV_PRESERVES_UV_BITS) > 2047 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) 2048 /* Don't flag it as "accurately an integer" if the number 2049 came from a (by definition imprecise) NV operation, and 2050 we're outside the range of NV integer precision */ 2051 #endif 2052 ) { 2053 if (SvNOK(sv)) 2054 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ 2055 else { 2056 /* scalar has trailing garbage, eg "42a" */ 2057 } 2058 DEBUG_c(PerlIO_printf(Perl_debug_log, 2059 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", 2060 PTR2UV(sv), 2061 SvNVX(sv), 2062 SvIVX(sv))); 2063 2064 } else { 2065 /* IV not precise. No need to convert from PV, as NV 2066 conversion would already have cached IV if it detected 2067 that PV->IV would be better than PV->NV->IV 2068 flags already correct - don't set public IOK. */ 2069 DEBUG_c(PerlIO_printf(Perl_debug_log, 2070 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", 2071 PTR2UV(sv), 2072 SvNVX(sv), 2073 SvIVX(sv))); 2074 } 2075 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, 2076 but the cast (NV)IV_MIN rounds to a the value less (more 2077 negative) than IV_MIN which happens to be equal to SvNVX ?? 2078 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and 2079 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and 2080 (NV)UVX == NVX are both true, but the values differ. :-( 2081 Hopefully for 2s complement IV_MIN is something like 2082 0x8000000000000000 which will be exact. NWC */ 2083 } 2084 else { 2085 SvUV_set(sv, U_V(SvNVX(sv))); 2086 if ( 2087 (SvNVX(sv) == (NV) SvUVX(sv)) 2088 #ifndef NV_PRESERVES_UV 2089 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ 2090 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ 2091 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) 2092 /* Don't flag it as "accurately an integer" if the number 2093 came from a (by definition imprecise) NV operation, and 2094 we're outside the range of NV integer precision */ 2095 #endif 2096 && SvNOK(sv) 2097 ) 2098 SvIOK_on(sv); 2099 SvIsUV_on(sv); 2100 DEBUG_c(PerlIO_printf(Perl_debug_log, 2101 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", 2102 PTR2UV(sv), 2103 SvUVX(sv), 2104 SvUVX(sv))); 2105 } 2106 } 2107 else if (SvPOKp(sv) && SvLEN(sv)) { 2108 UV value; 2109 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2110 /* We want to avoid a possible problem when we cache an IV/ a UV which 2111 may be later translated to an NV, and the resulting NV is not 2112 the same as the direct translation of the initial string 2113 (eg 123.456 can shortcut to the IV 123 with atol(), but we must 2114 be careful to ensure that the value with the .456 is around if the 2115 NV value is requested in the future). 2116 2117 This means that if we cache such an IV/a UV, we need to cache the 2118 NV as well. Moreover, we trade speed for space, and do not 2119 cache the NV if we are sure it's not needed. 2120 */ 2121 2122 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ 2123 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2124 == IS_NUMBER_IN_UV) { 2125 /* It's definitely an integer, only upgrade to PVIV */ 2126 if (SvTYPE(sv) < SVt_PVIV) 2127 sv_upgrade(sv, SVt_PVIV); 2128 (void)SvIOK_on(sv); 2129 } else if (SvTYPE(sv) < SVt_PVNV) 2130 sv_upgrade(sv, SVt_PVNV); 2131 2132 /* If NVs preserve UVs then we only use the UV value if we know that 2133 we aren't going to call atof() below. If NVs don't preserve UVs 2134 then the value returned may have more precision than atof() will 2135 return, even though value isn't perfectly accurate. */ 2136 if ((numtype & (IS_NUMBER_IN_UV 2137 #ifdef NV_PRESERVES_UV 2138 | IS_NUMBER_NOT_INT 2139 #endif 2140 )) == IS_NUMBER_IN_UV) { 2141 /* This won't turn off the public IOK flag if it was set above */ 2142 (void)SvIOKp_on(sv); 2143 2144 if (!(numtype & IS_NUMBER_NEG)) { 2145 /* positive */; 2146 if (value <= (UV)IV_MAX) { 2147 SvIV_set(sv, (IV)value); 2148 } else { 2149 /* it didn't overflow, and it was positive. */ 2150 SvUV_set(sv, value); 2151 SvIsUV_on(sv); 2152 } 2153 } else { 2154 /* 2s complement assumption */ 2155 if (value <= (UV)IV_MIN) { 2156 SvIV_set(sv, -(IV)value); 2157 } else { 2158 /* Too negative for an IV. This is a double upgrade, but 2159 I'm assuming it will be rare. */ 2160 if (SvTYPE(sv) < SVt_PVNV) 2161 sv_upgrade(sv, SVt_PVNV); 2162 SvNOK_on(sv); 2163 SvIOK_off(sv); 2164 SvIOKp_on(sv); 2165 SvNV_set(sv, -(NV)value); 2166 SvIV_set(sv, IV_MIN); 2167 } 2168 } 2169 } 2170 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we 2171 will be in the previous block to set the IV slot, and the next 2172 block to set the NV slot. So no else here. */ 2173 2174 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2175 != IS_NUMBER_IN_UV) { 2176 /* It wasn't an (integer that doesn't overflow the UV). */ 2177 SvNV_set(sv, Atof(SvPVX_const(sv))); 2178 2179 if (! numtype && ckWARN(WARN_NUMERIC)) 2180 not_a_number(sv); 2181 2182 #if defined(USE_LONG_DOUBLE) 2183 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", 2184 PTR2UV(sv), SvNVX(sv))); 2185 #else 2186 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", 2187 PTR2UV(sv), SvNVX(sv))); 2188 #endif 2189 2190 #ifdef NV_PRESERVES_UV 2191 (void)SvIOKp_on(sv); 2192 (void)SvNOK_on(sv); 2193 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2194 SvIV_set(sv, I_V(SvNVX(sv))); 2195 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 2196 SvIOK_on(sv); 2197 } else { 2198 NOOP; /* Integer is imprecise. NOK, IOKp */ 2199 } 2200 /* UV will not work better than IV */ 2201 } else { 2202 if (SvNVX(sv) > (NV)UV_MAX) { 2203 SvIsUV_on(sv); 2204 /* Integer is inaccurate. NOK, IOKp, is UV */ 2205 SvUV_set(sv, UV_MAX); 2206 } else { 2207 SvUV_set(sv, U_V(SvNVX(sv))); 2208 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs 2209 NV preservse UV so can do correct comparison. */ 2210 if ((NV)(SvUVX(sv)) == SvNVX(sv)) { 2211 SvIOK_on(sv); 2212 } else { 2213 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ 2214 } 2215 } 2216 SvIsUV_on(sv); 2217 } 2218 #else /* NV_PRESERVES_UV */ 2219 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2220 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { 2221 /* The IV/UV slot will have been set from value returned by 2222 grok_number above. The NV slot has just been set using 2223 Atof. */ 2224 SvNOK_on(sv); 2225 assert (SvIOKp(sv)); 2226 } else { 2227 if (((UV)1 << NV_PRESERVES_UV_BITS) > 2228 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { 2229 /* Small enough to preserve all bits. */ 2230 (void)SvIOKp_on(sv); 2231 SvNOK_on(sv); 2232 SvIV_set(sv, I_V(SvNVX(sv))); 2233 if ((NV)(SvIVX(sv)) == SvNVX(sv)) 2234 SvIOK_on(sv); 2235 /* Assumption: first non-preserved integer is < IV_MAX, 2236 this NV is in the preserved range, therefore: */ 2237 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) 2238 < (UV)IV_MAX)) { 2239 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); 2240 } 2241 } else { 2242 /* IN_UV NOT_INT 2243 0 0 already failed to read UV. 2244 0 1 already failed to read UV. 2245 1 0 you won't get here in this case. IV/UV 2246 slot set, public IOK, Atof() unneeded. 2247 1 1 already read UV. 2248 so there's no point in sv_2iuv_non_preserve() attempting 2249 to use atol, strtol, strtoul etc. */ 2250 # ifdef DEBUGGING 2251 sv_2iuv_non_preserve (sv, numtype); 2252 # else 2253 sv_2iuv_non_preserve (sv); 2254 # endif 2255 } 2256 } 2257 #endif /* NV_PRESERVES_UV */ 2258 /* It might be more code efficient to go through the entire logic above 2259 and conditionally set with SvIOKp_on() rather than SvIOK(), but it 2260 gets complex and potentially buggy, so more programmer efficient 2261 to do it this way, by turning off the public flags: */ 2262 if (!numtype) 2263 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); 2264 } 2265 } 2266 else { 2267 if (isGV_with_GP(sv)) 2268 return glob_2number(MUTABLE_GV(sv)); 2269 2270 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 2271 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) 2272 report_uninit(sv); 2273 } 2274 if (SvTYPE(sv) < SVt_IV) 2275 /* Typically the caller expects that sv_any is not NULL now. */ 2276 sv_upgrade(sv, SVt_IV); 2277 /* Return 0 from the caller. */ 2278 return TRUE; 2279 } 2280 return FALSE; 2281 } 2282 2283 /* 2284 =for apidoc sv_2iv_flags 2285 2286 Return the integer value of an SV, doing any necessary string 2287 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2288 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. 2289 2290 =cut 2291 */ 2292 2293 IV 2294 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) 2295 { 2296 dVAR; 2297 if (!sv) 2298 return 0; 2299 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { 2300 /* FBMs use the same flag bit as SVf_IVisUV, so must let them 2301 cache IVs just in case. In practice it seems that they never 2302 actually anywhere accessible by user Perl code, let alone get used 2303 in anything other than a string context. */ 2304 if (flags & SV_GMAGIC) 2305 mg_get(sv); 2306 if (SvIOKp(sv)) 2307 return SvIVX(sv); 2308 if (SvNOKp(sv)) { 2309 return I_V(SvNVX(sv)); 2310 } 2311 if (SvPOKp(sv) && SvLEN(sv)) { 2312 UV value; 2313 const int numtype 2314 = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2315 2316 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2317 == IS_NUMBER_IN_UV) { 2318 /* It's definitely an integer */ 2319 if (numtype & IS_NUMBER_NEG) { 2320 if (value < (UV)IV_MIN) 2321 return -(IV)value; 2322 } else { 2323 if (value < (UV)IV_MAX) 2324 return (IV)value; 2325 } 2326 } 2327 if (!numtype) { 2328 if (ckWARN(WARN_NUMERIC)) 2329 not_a_number(sv); 2330 } 2331 return I_V(Atof(SvPVX_const(sv))); 2332 } 2333 if (SvROK(sv)) { 2334 goto return_rok; 2335 } 2336 assert(SvTYPE(sv) >= SVt_PVMG); 2337 /* This falls through to the report_uninit inside S_sv_2iuv_common. */ 2338 } else if (SvTHINKFIRST(sv)) { 2339 if (SvROK(sv)) { 2340 return_rok: 2341 if (SvAMAGIC(sv)) { 2342 SV * const tmpstr=AMG_CALLun(sv,numer); 2343 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2344 return SvIV(tmpstr); 2345 } 2346 } 2347 return PTR2IV(SvRV(sv)); 2348 } 2349 if (SvIsCOW(sv)) { 2350 sv_force_normal_flags(sv, 0); 2351 } 2352 if (SvREADONLY(sv) && !SvOK(sv)) { 2353 if (ckWARN(WARN_UNINITIALIZED)) 2354 report_uninit(sv); 2355 return 0; 2356 } 2357 } 2358 if (!SvIOKp(sv)) { 2359 if (S_sv_2iuv_common(aTHX_ sv)) 2360 return 0; 2361 } 2362 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", 2363 PTR2UV(sv),SvIVX(sv))); 2364 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); 2365 } 2366 2367 /* 2368 =for apidoc sv_2uv_flags 2369 2370 Return the unsigned integer value of an SV, doing any necessary string 2371 conversion. If flags includes SV_GMAGIC, does an mg_get() first. 2372 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros. 2373 2374 =cut 2375 */ 2376 2377 UV 2378 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) 2379 { 2380 dVAR; 2381 if (!sv) 2382 return 0; 2383 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { 2384 /* FBMs use the same flag bit as SVf_IVisUV, so must let them 2385 cache IVs just in case. */ 2386 if (flags & SV_GMAGIC) 2387 mg_get(sv); 2388 if (SvIOKp(sv)) 2389 return SvUVX(sv); 2390 if (SvNOKp(sv)) 2391 return U_V(SvNVX(sv)); 2392 if (SvPOKp(sv) && SvLEN(sv)) { 2393 UV value; 2394 const int numtype 2395 = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2396 2397 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2398 == IS_NUMBER_IN_UV) { 2399 /* It's definitely an integer */ 2400 if (!(numtype & IS_NUMBER_NEG)) 2401 return value; 2402 } 2403 if (!numtype) { 2404 if (ckWARN(WARN_NUMERIC)) 2405 not_a_number(sv); 2406 } 2407 return U_V(Atof(SvPVX_const(sv))); 2408 } 2409 if (SvROK(sv)) { 2410 goto return_rok; 2411 } 2412 assert(SvTYPE(sv) >= SVt_PVMG); 2413 /* This falls through to the report_uninit inside S_sv_2iuv_common. */ 2414 } else if (SvTHINKFIRST(sv)) { 2415 if (SvROK(sv)) { 2416 return_rok: 2417 if (SvAMAGIC(sv)) { 2418 SV *const tmpstr = AMG_CALLun(sv,numer); 2419 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2420 return SvUV(tmpstr); 2421 } 2422 } 2423 return PTR2UV(SvRV(sv)); 2424 } 2425 if (SvIsCOW(sv)) { 2426 sv_force_normal_flags(sv, 0); 2427 } 2428 if (SvREADONLY(sv) && !SvOK(sv)) { 2429 if (ckWARN(WARN_UNINITIALIZED)) 2430 report_uninit(sv); 2431 return 0; 2432 } 2433 } 2434 if (!SvIOKp(sv)) { 2435 if (S_sv_2iuv_common(aTHX_ sv)) 2436 return 0; 2437 } 2438 2439 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", 2440 PTR2UV(sv),SvUVX(sv))); 2441 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); 2442 } 2443 2444 /* 2445 =for apidoc sv_2nv 2446 2447 Return the num value of an SV, doing any necessary string or integer 2448 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> 2449 macros. 2450 2451 =cut 2452 */ 2453 2454 NV 2455 Perl_sv_2nv(pTHX_ register SV *const sv) 2456 { 2457 dVAR; 2458 if (!sv) 2459 return 0.0; 2460 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { 2461 /* FBMs use the same flag bit as SVf_IVisUV, so must let them 2462 cache IVs just in case. */ 2463 mg_get(sv); 2464 if (SvNOKp(sv)) 2465 return SvNVX(sv); 2466 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) { 2467 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && 2468 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) 2469 not_a_number(sv); 2470 return Atof(SvPVX_const(sv)); 2471 } 2472 if (SvIOKp(sv)) { 2473 if (SvIsUV(sv)) 2474 return (NV)SvUVX(sv); 2475 else 2476 return (NV)SvIVX(sv); 2477 } 2478 if (SvROK(sv)) { 2479 goto return_rok; 2480 } 2481 assert(SvTYPE(sv) >= SVt_PVMG); 2482 /* This falls through to the report_uninit near the end of the 2483 function. */ 2484 } else if (SvTHINKFIRST(sv)) { 2485 if (SvROK(sv)) { 2486 return_rok: 2487 if (SvAMAGIC(sv)) { 2488 SV *const tmpstr = AMG_CALLun(sv,numer); 2489 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2490 return SvNV(tmpstr); 2491 } 2492 } 2493 return PTR2NV(SvRV(sv)); 2494 } 2495 if (SvIsCOW(sv)) { 2496 sv_force_normal_flags(sv, 0); 2497 } 2498 if (SvREADONLY(sv) && !SvOK(sv)) { 2499 if (ckWARN(WARN_UNINITIALIZED)) 2500 report_uninit(sv); 2501 return 0.0; 2502 } 2503 } 2504 if (SvTYPE(sv) < SVt_NV) { 2505 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ 2506 sv_upgrade(sv, SVt_NV); 2507 #ifdef USE_LONG_DOUBLE 2508 DEBUG_c({ 2509 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2510 PerlIO_printf(Perl_debug_log, 2511 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", 2512 PTR2UV(sv), SvNVX(sv)); 2513 RESTORE_NUMERIC_LOCAL(); 2514 }); 2515 #else 2516 DEBUG_c({ 2517 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2518 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", 2519 PTR2UV(sv), SvNVX(sv)); 2520 RESTORE_NUMERIC_LOCAL(); 2521 }); 2522 #endif 2523 } 2524 else if (SvTYPE(sv) < SVt_PVNV) 2525 sv_upgrade(sv, SVt_PVNV); 2526 if (SvNOKp(sv)) { 2527 return SvNVX(sv); 2528 } 2529 if (SvIOKp(sv)) { 2530 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); 2531 #ifdef NV_PRESERVES_UV 2532 if (SvIOK(sv)) 2533 SvNOK_on(sv); 2534 else 2535 SvNOKp_on(sv); 2536 #else 2537 /* Only set the public NV OK flag if this NV preserves the IV */ 2538 /* Check it's not 0xFFFFFFFFFFFFFFFF */ 2539 if (SvIOK(sv) && 2540 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) 2541 : (SvIVX(sv) == I_V(SvNVX(sv)))) 2542 SvNOK_on(sv); 2543 else 2544 SvNOKp_on(sv); 2545 #endif 2546 } 2547 else if (SvPOKp(sv) && SvLEN(sv)) { 2548 UV value; 2549 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 2550 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) 2551 not_a_number(sv); 2552 #ifdef NV_PRESERVES_UV 2553 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) 2554 == IS_NUMBER_IN_UV) { 2555 /* It's definitely an integer */ 2556 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); 2557 } else 2558 SvNV_set(sv, Atof(SvPVX_const(sv))); 2559 if (numtype) 2560 SvNOK_on(sv); 2561 else 2562 SvNOKp_on(sv); 2563 #else 2564 SvNV_set(sv, Atof(SvPVX_const(sv))); 2565 /* Only set the public NV OK flag if this NV preserves the value in 2566 the PV at least as well as an IV/UV would. 2567 Not sure how to do this 100% reliably. */ 2568 /* if that shift count is out of range then Configure's test is 2569 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == 2570 UV_BITS */ 2571 if (((UV)1 << NV_PRESERVES_UV_BITS) > 2572 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { 2573 SvNOK_on(sv); /* Definitely small enough to preserve all bits */ 2574 } else if (!(numtype & IS_NUMBER_IN_UV)) { 2575 /* Can't use strtol etc to convert this string, so don't try. 2576 sv_2iv and sv_2uv will use the NV to convert, not the PV. */ 2577 SvNOK_on(sv); 2578 } else { 2579 /* value has been set. It may not be precise. */ 2580 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { 2581 /* 2s complement assumption for (UV)IV_MIN */ 2582 SvNOK_on(sv); /* Integer is too negative. */ 2583 } else { 2584 SvNOKp_on(sv); 2585 SvIOKp_on(sv); 2586 2587 if (numtype & IS_NUMBER_NEG) { 2588 SvIV_set(sv, -(IV)value); 2589 } else if (value <= (UV)IV_MAX) { 2590 SvIV_set(sv, (IV)value); 2591 } else { 2592 SvUV_set(sv, value); 2593 SvIsUV_on(sv); 2594 } 2595 2596 if (numtype & IS_NUMBER_NOT_INT) { 2597 /* I believe that even if the original PV had decimals, 2598 they are lost beyond the limit of the FP precision. 2599 However, neither is canonical, so both only get p 2600 flags. NWC, 2000/11/25 */ 2601 /* Both already have p flags, so do nothing */ 2602 } else { 2603 const NV nv = SvNVX(sv); 2604 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2605 if (SvIVX(sv) == I_V(nv)) { 2606 SvNOK_on(sv); 2607 } else { 2608 /* It had no "." so it must be integer. */ 2609 } 2610 SvIOK_on(sv); 2611 } else { 2612 /* between IV_MAX and NV(UV_MAX). 2613 Could be slightly > UV_MAX */ 2614 2615 if (numtype & IS_NUMBER_NOT_INT) { 2616 /* UV and NV both imprecise. */ 2617 } else { 2618 const UV nv_as_uv = U_V(nv); 2619 2620 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { 2621 SvNOK_on(sv); 2622 } 2623 SvIOK_on(sv); 2624 } 2625 } 2626 } 2627 } 2628 } 2629 /* It might be more code efficient to go through the entire logic above 2630 and conditionally set with SvNOKp_on() rather than SvNOK(), but it 2631 gets complex and potentially buggy, so more programmer efficient 2632 to do it this way, by turning off the public flags: */ 2633 if (!numtype) 2634 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); 2635 #endif /* NV_PRESERVES_UV */ 2636 } 2637 else { 2638 if (isGV_with_GP(sv)) { 2639 glob_2number(MUTABLE_GV(sv)); 2640 return 0.0; 2641 } 2642 2643 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) 2644 report_uninit(sv); 2645 assert (SvTYPE(sv) >= SVt_NV); 2646 /* Typically the caller expects that sv_any is not NULL now. */ 2647 /* XXX Ilya implies that this is a bug in callers that assume this 2648 and ideally should be fixed. */ 2649 return 0.0; 2650 } 2651 #if defined(USE_LONG_DOUBLE) 2652 DEBUG_c({ 2653 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2654 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", 2655 PTR2UV(sv), SvNVX(sv)); 2656 RESTORE_NUMERIC_LOCAL(); 2657 }); 2658 #else 2659 DEBUG_c({ 2660 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2661 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", 2662 PTR2UV(sv), SvNVX(sv)); 2663 RESTORE_NUMERIC_LOCAL(); 2664 }); 2665 #endif 2666 return SvNVX(sv); 2667 } 2668 2669 /* 2670 =for apidoc sv_2num 2671 2672 Return an SV with the numeric value of the source SV, doing any necessary 2673 reference or overload conversion. You must use the C<SvNUM(sv)> macro to 2674 access this function. 2675 2676 =cut 2677 */ 2678 2679 SV * 2680 Perl_sv_2num(pTHX_ register SV *const sv) 2681 { 2682 PERL_ARGS_ASSERT_SV_2NUM; 2683 2684 if (!SvROK(sv)) 2685 return sv; 2686 if (SvAMAGIC(sv)) { 2687 SV * const tmpsv = AMG_CALLun(sv,numer); 2688 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) 2689 return sv_2num(tmpsv); 2690 } 2691 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); 2692 } 2693 2694 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or 2695 * UV as a string towards the end of buf, and return pointers to start and 2696 * end of it. 2697 * 2698 * We assume that buf is at least TYPE_CHARS(UV) long. 2699 */ 2700 2701 static char * 2702 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) 2703 { 2704 char *ptr = buf + TYPE_CHARS(UV); 2705 char * const ebuf = ptr; 2706 int sign; 2707 2708 PERL_ARGS_ASSERT_UIV_2BUF; 2709 2710 if (is_uv) 2711 sign = 0; 2712 else if (iv >= 0) { 2713 uv = iv; 2714 sign = 0; 2715 } else { 2716 uv = -iv; 2717 sign = 1; 2718 } 2719 do { 2720 *--ptr = '0' + (char)(uv % 10); 2721 } while (uv /= 10); 2722 if (sign) 2723 *--ptr = '-'; 2724 *peob = ebuf; 2725 return ptr; 2726 } 2727 2728 /* 2729 =for apidoc sv_2pv_flags 2730 2731 Returns a pointer to the string value of an SV, and sets *lp to its length. 2732 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string 2733 if necessary. 2734 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg> 2735 usually end up here too. 2736 2737 =cut 2738 */ 2739 2740 char * 2741 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags) 2742 { 2743 dVAR; 2744 register char *s; 2745 2746 if (!sv) { 2747 if (lp) 2748 *lp = 0; 2749 return (char *)""; 2750 } 2751 if (SvGMAGICAL(sv)) { 2752 if (flags & SV_GMAGIC) 2753 mg_get(sv); 2754 if (SvPOKp(sv)) { 2755 if (lp) 2756 *lp = SvCUR(sv); 2757 if (flags & SV_MUTABLE_RETURN) 2758 return SvPVX_mutable(sv); 2759 if (flags & SV_CONST_RETURN) 2760 return (char *)SvPVX_const(sv); 2761 return SvPVX(sv); 2762 } 2763 if (SvIOKp(sv) || SvNOKp(sv)) { 2764 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ 2765 STRLEN len; 2766 2767 if (SvIOKp(sv)) { 2768 len = SvIsUV(sv) 2769 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv)) 2770 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv)); 2771 } else { 2772 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf); 2773 len = strlen(tbuf); 2774 } 2775 assert(!SvROK(sv)); 2776 { 2777 dVAR; 2778 2779 #ifdef FIXNEGATIVEZERO 2780 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') { 2781 tbuf[0] = '0'; 2782 tbuf[1] = 0; 2783 len = 1; 2784 } 2785 #endif 2786 SvUPGRADE(sv, SVt_PV); 2787 if (lp) 2788 *lp = len; 2789 s = SvGROW_mutable(sv, len + 1); 2790 SvCUR_set(sv, len); 2791 SvPOKp_on(sv); 2792 return (char*)memcpy(s, tbuf, len + 1); 2793 } 2794 } 2795 if (SvROK(sv)) { 2796 goto return_rok; 2797 } 2798 assert(SvTYPE(sv) >= SVt_PVMG); 2799 /* This falls through to the report_uninit near the end of the 2800 function. */ 2801 } else if (SvTHINKFIRST(sv)) { 2802 if (SvROK(sv)) { 2803 return_rok: 2804 if (SvAMAGIC(sv)) { 2805 SV *const tmpstr = AMG_CALLun(sv,string); 2806 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { 2807 /* Unwrap this: */ 2808 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); 2809 */ 2810 2811 char *pv; 2812 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { 2813 if (flags & SV_CONST_RETURN) { 2814 pv = (char *) SvPVX_const(tmpstr); 2815 } else { 2816 pv = (flags & SV_MUTABLE_RETURN) 2817 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); 2818 } 2819 if (lp) 2820 *lp = SvCUR(tmpstr); 2821 } else { 2822 pv = sv_2pv_flags(tmpstr, lp, flags); 2823 } 2824 if (SvUTF8(tmpstr)) 2825 SvUTF8_on(sv); 2826 else 2827 SvUTF8_off(sv); 2828 return pv; 2829 } 2830 } 2831 { 2832 STRLEN len; 2833 char *retval; 2834 char *buffer; 2835 SV *const referent = SvRV(sv); 2836 2837 if (!referent) { 2838 len = 7; 2839 retval = buffer = savepvn("NULLREF", len); 2840 } else if (SvTYPE(referent) == SVt_REGEXP) { 2841 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); 2842 I32 seen_evals = 0; 2843 2844 assert(re); 2845 2846 /* If the regex is UTF-8 we want the containing scalar to 2847 have an UTF-8 flag too */ 2848 if (RX_UTF8(re)) 2849 SvUTF8_on(sv); 2850 else 2851 SvUTF8_off(sv); 2852 2853 if ((seen_evals = RX_SEEN_EVALS(re))) 2854 PL_reginterp_cnt += seen_evals; 2855 2856 if (lp) 2857 *lp = RX_WRAPLEN(re); 2858 2859 return RX_WRAPPED(re); 2860 } else { 2861 const char *const typestr = sv_reftype(referent, 0); 2862 const STRLEN typelen = strlen(typestr); 2863 UV addr = PTR2UV(referent); 2864 const char *stashname = NULL; 2865 STRLEN stashnamelen = 0; /* hush, gcc */ 2866 const char *buffer_end; 2867 2868 if (SvOBJECT(referent)) { 2869 const HEK *const name = HvNAME_HEK(SvSTASH(referent)); 2870 2871 if (name) { 2872 stashname = HEK_KEY(name); 2873 stashnamelen = HEK_LEN(name); 2874 2875 if (HEK_UTF8(name)) { 2876 SvUTF8_on(sv); 2877 } else { 2878 SvUTF8_off(sv); 2879 } 2880 } else { 2881 stashname = "__ANON__"; 2882 stashnamelen = 8; 2883 } 2884 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ 2885 + 2 * sizeof(UV) + 2 /* )\0 */; 2886 } else { 2887 len = typelen + 3 /* (0x */ 2888 + 2 * sizeof(UV) + 2 /* )\0 */; 2889 } 2890 2891 Newx(buffer, len, char); 2892 buffer_end = retval = buffer + len; 2893 2894 /* Working backwards */ 2895 *--retval = '\0'; 2896 *--retval = ')'; 2897 do { 2898 *--retval = PL_hexdigit[addr & 15]; 2899 } while (addr >>= 4); 2900 *--retval = 'x'; 2901 *--retval = '0'; 2902 *--retval = '('; 2903 2904 retval -= typelen; 2905 memcpy(retval, typestr, typelen); 2906 2907 if (stashname) { 2908 *--retval = '='; 2909 retval -= stashnamelen; 2910 memcpy(retval, stashname, stashnamelen); 2911 } 2912 /* retval may not neccesarily have reached the start of the 2913 buffer here. */ 2914 assert (retval >= buffer); 2915 2916 len = buffer_end - retval - 1; /* -1 for that \0 */ 2917 } 2918 if (lp) 2919 *lp = len; 2920 SAVEFREEPV(buffer); 2921 return retval; 2922 } 2923 } 2924 if (SvREADONLY(sv) && !SvOK(sv)) { 2925 if (lp) 2926 *lp = 0; 2927 if (flags & SV_UNDEF_RETURNS_NULL) 2928 return NULL; 2929 if (ckWARN(WARN_UNINITIALIZED)) 2930 report_uninit(sv); 2931 return (char *)""; 2932 } 2933 } 2934 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { 2935 /* I'm assuming that if both IV and NV are equally valid then 2936 converting the IV is going to be more efficient */ 2937 const U32 isUIOK = SvIsUV(sv); 2938 char buf[TYPE_CHARS(UV)]; 2939 char *ebuf, *ptr; 2940 STRLEN len; 2941 2942 if (SvTYPE(sv) < SVt_PVIV) 2943 sv_upgrade(sv, SVt_PVIV); 2944 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); 2945 len = ebuf - ptr; 2946 /* inlined from sv_setpvn */ 2947 s = SvGROW_mutable(sv, len + 1); 2948 Move(ptr, s, len, char); 2949 s += len; 2950 *s = '\0'; 2951 } 2952 else if (SvNOKp(sv)) { 2953 dSAVE_ERRNO; 2954 if (SvTYPE(sv) < SVt_PVNV) 2955 sv_upgrade(sv, SVt_PVNV); 2956 /* The +20 is pure guesswork. Configure test needed. --jhi */ 2957 s = SvGROW_mutable(sv, NV_DIG + 20); 2958 /* some Xenix systems wipe out errno here */ 2959 #ifdef apollo 2960 if (SvNVX(sv) == 0.0) 2961 my_strlcpy(s, "0", SvLEN(sv)); 2962 else 2963 #endif /*apollo*/ 2964 { 2965 Gconvert(SvNVX(sv), NV_DIG, 0, s); 2966 } 2967 RESTORE_ERRNO; 2968 #ifdef FIXNEGATIVEZERO 2969 if (*s == '-' && s[1] == '0' && !s[2]) { 2970 s[0] = '0'; 2971 s[1] = 0; 2972 } 2973 #endif 2974 while (*s) s++; 2975 #ifdef hcx 2976 if (s[-1] == '.') 2977 *--s = '\0'; 2978 #endif 2979 } 2980 else { 2981 if (isGV_with_GP(sv)) { 2982 GV *const gv = MUTABLE_GV(sv); 2983 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; 2984 SV *const buffer = sv_newmortal(); 2985 2986 /* FAKE globs can get coerced, so need to turn this off temporarily 2987 if it is on. */ 2988 SvFAKE_off(gv); 2989 gv_efullname3(buffer, gv, "*"); 2990 SvFLAGS(gv) |= wasfake; 2991 2992 if (SvPOK(buffer)) { 2993 if (lp) { 2994 *lp = SvCUR(buffer); 2995 } 2996 return SvPVX(buffer); 2997 } 2998 else { 2999 if (lp) 3000 *lp = 0; 3001 return (char *)""; 3002 } 3003 } 3004 3005 if (lp) 3006 *lp = 0; 3007 if (flags & SV_UNDEF_RETURNS_NULL) 3008 return NULL; 3009 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) 3010 report_uninit(sv); 3011 if (SvTYPE(sv) < SVt_PV) 3012 /* Typically the caller expects that sv_any is not NULL now. */ 3013 sv_upgrade(sv, SVt_PV); 3014 return (char *)""; 3015 } 3016 { 3017 const STRLEN len = s - SvPVX_const(sv); 3018 if (lp) 3019 *lp = len; 3020 SvCUR_set(sv, len); 3021 } 3022 SvPOK_on(sv); 3023 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 3024 PTR2UV(sv),SvPVX_const(sv))); 3025 if (flags & SV_CONST_RETURN) 3026 return (char *)SvPVX_const(sv); 3027 if (flags & SV_MUTABLE_RETURN) 3028 return SvPVX_mutable(sv); 3029 return SvPVX(sv); 3030 } 3031 3032 /* 3033 =for apidoc sv_copypv 3034 3035 Copies a stringified representation of the source SV into the 3036 destination SV. Automatically performs any necessary mg_get and 3037 coercion of numeric values into strings. Guaranteed to preserve 3038 UTF8 flag even from overloaded objects. Similar in nature to 3039 sv_2pv[_flags] but operates directly on an SV instead of just the 3040 string. Mostly uses sv_2pv_flags to do its work, except when that 3041 would lose the UTF-8'ness of the PV. 3042 3043 =cut 3044 */ 3045 3046 void 3047 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv) 3048 { 3049 STRLEN len; 3050 const char * const s = SvPV_const(ssv,len); 3051 3052 PERL_ARGS_ASSERT_SV_COPYPV; 3053 3054 sv_setpvn(dsv,s,len); 3055 if (SvUTF8(ssv)) 3056 SvUTF8_on(dsv); 3057 else 3058 SvUTF8_off(dsv); 3059 } 3060 3061 /* 3062 =for apidoc sv_2pvbyte 3063 3064 Return a pointer to the byte-encoded representation of the SV, and set *lp 3065 to its length. May cause the SV to be downgraded from UTF-8 as a 3066 side-effect. 3067 3068 Usually accessed via the C<SvPVbyte> macro. 3069 3070 =cut 3071 */ 3072 3073 char * 3074 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp) 3075 { 3076 PERL_ARGS_ASSERT_SV_2PVBYTE; 3077 3078 sv_utf8_downgrade(sv,0); 3079 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); 3080 } 3081 3082 /* 3083 =for apidoc sv_2pvutf8 3084 3085 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp 3086 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. 3087 3088 Usually accessed via the C<SvPVutf8> macro. 3089 3090 =cut 3091 */ 3092 3093 char * 3094 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp) 3095 { 3096 PERL_ARGS_ASSERT_SV_2PVUTF8; 3097 3098 sv_utf8_upgrade(sv); 3099 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); 3100 } 3101 3102 3103 /* 3104 =for apidoc sv_2bool 3105 3106 This function is only called on magical items, and is only used by 3107 sv_true() or its macro equivalent. 3108 3109 =cut 3110 */ 3111 3112 bool 3113 Perl_sv_2bool(pTHX_ register SV *const sv) 3114 { 3115 dVAR; 3116 3117 PERL_ARGS_ASSERT_SV_2BOOL; 3118 3119 SvGETMAGIC(sv); 3120 3121 if (!SvOK(sv)) 3122 return 0; 3123 if (SvROK(sv)) { 3124 if (SvAMAGIC(sv)) { 3125 SV * const tmpsv = AMG_CALLun(sv,bool_); 3126 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) 3127 return (bool)SvTRUE(tmpsv); 3128 } 3129 return SvRV(sv) != 0; 3130 } 3131 if (SvPOKp(sv)) { 3132 register XPV* const Xpvtmp = (XPV*)SvANY(sv); 3133 if (Xpvtmp && 3134 (*sv->sv_u.svu_pv > '0' || 3135 Xpvtmp->xpv_cur > 1 || 3136 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) 3137 return 1; 3138 else 3139 return 0; 3140 } 3141 else { 3142 if (SvIOKp(sv)) 3143 return SvIVX(sv) != 0; 3144 else { 3145 if (SvNOKp(sv)) 3146 return SvNVX(sv) != 0.0; 3147 else { 3148 if (isGV_with_GP(sv)) 3149 return TRUE; 3150 else 3151 return FALSE; 3152 } 3153 } 3154 } 3155 } 3156 3157 /* 3158 =for apidoc sv_utf8_upgrade 3159 3160 Converts the PV of an SV to its UTF-8-encoded form. 3161 Forces the SV to string form if it is not already. 3162 Will C<mg_get> on C<sv> if appropriate. 3163 Always sets the SvUTF8 flag to avoid future validity checks even 3164 if the whole string is the same in UTF-8 as not. 3165 Returns the number of bytes in the converted string 3166 3167 This is not as a general purpose byte encoding to Unicode interface: 3168 use the Encode extension for that. 3169 3170 =for apidoc sv_utf8_upgrade_nomg 3171 3172 Like sv_utf8_upgrade, but doesn't do magic on C<sv> 3173 3174 =for apidoc sv_utf8_upgrade_flags 3175 3176 Converts the PV of an SV to its UTF-8-encoded form. 3177 Forces the SV to string form if it is not already. 3178 Always sets the SvUTF8 flag to avoid future validity checks even 3179 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set, 3180 will C<mg_get> on C<sv> if appropriate, else not. 3181 Returns the number of bytes in the converted string 3182 C<sv_utf8_upgrade> and 3183 C<sv_utf8_upgrade_nomg> are implemented in terms of this function. 3184 3185 This is not as a general purpose byte encoding to Unicode interface: 3186 use the Encode extension for that. 3187 3188 =cut 3189 3190 The grow version is currently not externally documented. It adds a parameter, 3191 extra, which is the number of unused bytes the string of 'sv' is guaranteed to 3192 have free after it upon return. This allows the caller to reserve extra space 3193 that it intends to fill, to avoid extra grows. 3194 3195 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE, 3196 which can be used to tell this function to not first check to see if there are 3197 any characters that are different in UTF-8 (variant characters) which would 3198 force it to allocate a new string to sv, but to assume there are. Typically 3199 this flag is used by a routine that has already parsed the string to find that 3200 there are such characters, and passes this information on so that the work 3201 doesn't have to be repeated. 3202 3203 (One might think that the calling routine could pass in the position of the 3204 first such variant, so it wouldn't have to be found again. But that is not the 3205 case, because typically when the caller is likely to use this flag, it won't be 3206 calling this routine unless it finds something that won't fit into a byte. 3207 Otherwise it tries to not upgrade and just use bytes. But some things that 3208 do fit into a byte are variants in utf8, and the caller may not have been 3209 keeping track of these.) 3210 3211 If the routine itself changes the string, it adds a trailing NUL. Such a NUL 3212 isn't guaranteed due to having other routines do the work in some input cases, 3213 or if the input is already flagged as being in utf8. 3214 3215 The speed of this could perhaps be improved for many cases if someone wanted to 3216 write a fast function that counts the number of variant characters in a string, 3217 especially if it could return the position of the first one. 3218 3219 */ 3220 3221 STRLEN 3222 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra) 3223 { 3224 dVAR; 3225 3226 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; 3227 3228 if (sv == &PL_sv_undef) 3229 return 0; 3230 if (!SvPOK(sv)) { 3231 STRLEN len = 0; 3232 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { 3233 (void) sv_2pv_flags(sv,&len, flags); 3234 if (SvUTF8(sv)) { 3235 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3236 return len; 3237 } 3238 } else { 3239 (void) SvPV_force(sv,len); 3240 } 3241 } 3242 3243 if (SvUTF8(sv)) { 3244 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3245 return SvCUR(sv); 3246 } 3247 3248 if (SvIsCOW(sv)) { 3249 sv_force_normal_flags(sv, 0); 3250 } 3251 3252 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) { 3253 sv_recode_to_utf8(sv, PL_encoding); 3254 if (extra) SvGROW(sv, SvCUR(sv) + extra); 3255 return SvCUR(sv); 3256 } 3257 3258 if (SvCUR(sv) == 0) { 3259 if (extra) SvGROW(sv, extra); 3260 } else { /* Assume Latin-1/EBCDIC */ 3261 /* This function could be much more efficient if we 3262 * had a FLAG in SVs to signal if there are any variant 3263 * chars in the PV. Given that there isn't such a flag 3264 * make the loop as fast as possible (although there are certainly ways 3265 * to speed this up, eg. through vectorization) */ 3266 U8 * s = (U8 *) SvPVX_const(sv); 3267 U8 * e = (U8 *) SvEND(sv); 3268 U8 *t = s; 3269 STRLEN two_byte_count = 0; 3270 3271 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; 3272 3273 /* See if really will need to convert to utf8. We mustn't rely on our 3274 * incoming SV being well formed and having a trailing '\0', as certain 3275 * code in pp_formline can send us partially built SVs. */ 3276 3277 while (t < e) { 3278 const U8 ch = *t++; 3279 if (NATIVE_IS_INVARIANT(ch)) continue; 3280 3281 t--; /* t already incremented; re-point to first variant */ 3282 two_byte_count = 1; 3283 goto must_be_utf8; 3284 } 3285 3286 /* utf8 conversion not needed because all are invariants. Mark as 3287 * UTF-8 even if no variant - saves scanning loop */ 3288 SvUTF8_on(sv); 3289 return SvCUR(sv); 3290 3291 must_be_utf8: 3292 3293 /* Here, the string should be converted to utf8, either because of an 3294 * input flag (two_byte_count = 0), or because a character that 3295 * requires 2 bytes was found (two_byte_count = 1). t points either to 3296 * the beginning of the string (if we didn't examine anything), or to 3297 * the first variant. In either case, everything from s to t - 1 will 3298 * occupy only 1 byte each on output. 3299 * 3300 * There are two main ways to convert. One is to create a new string 3301 * and go through the input starting from the beginning, appending each 3302 * converted value onto the new string as we go along. It's probably 3303 * best to allocate enough space in the string for the worst possible 3304 * case rather than possibly running out of space and having to 3305 * reallocate and then copy what we've done so far. Since everything 3306 * from s to t - 1 is invariant, the destination can be initialized 3307 * with these using a fast memory copy 3308 * 3309 * The other way is to figure out exactly how big the string should be 3310 * by parsing the entire input. Then you don't have to make it big 3311 * enough to handle the worst possible case, and more importantly, if 3312 * the string you already have is large enough, you don't have to 3313 * allocate a new string, you can copy the last character in the input 3314 * string to the final position(s) that will be occupied by the 3315 * converted string and go backwards, stopping at t, since everything 3316 * before that is invariant. 3317 * 3318 * There are advantages and disadvantages to each method. 3319 * 3320 * In the first method, we can allocate a new string, do the memory 3321 * copy from the s to t - 1, and then proceed through the rest of the 3322 * string byte-by-byte. 3323 * 3324 * In the second method, we proceed through the rest of the input 3325 * string just calculating how big the converted string will be. Then 3326 * there are two cases: 3327 * 1) if the string has enough extra space to handle the converted 3328 * value. We go backwards through the string, converting until we 3329 * get to the position we are at now, and then stop. If this 3330 * position is far enough along in the string, this method is 3331 * faster than the other method. If the memory copy were the same 3332 * speed as the byte-by-byte loop, that position would be about 3333 * half-way, as at the half-way mark, parsing to the end and back 3334 * is one complete string's parse, the same amount as starting 3335 * over and going all the way through. Actually, it would be 3336 * somewhat less than half-way, as it's faster to just count bytes 3337 * than to also copy, and we don't have the overhead of allocating 3338 * a new string, changing the scalar to use it, and freeing the 3339 * existing one. But if the memory copy is fast, the break-even 3340 * point is somewhere after half way. The counting loop could be 3341 * sped up by vectorization, etc, to move the break-even point 3342 * further towards the beginning. 3343 * 2) if the string doesn't have enough space to handle the converted 3344 * value. A new string will have to be allocated, and one might 3345 * as well, given that, start from the beginning doing the first 3346 * method. We've spent extra time parsing the string and in 3347 * exchange all we've gotten is that we know precisely how big to 3348 * make the new one. Perl is more optimized for time than space, 3349 * so this case is a loser. 3350 * So what I've decided to do is not use the 2nd method unless it is 3351 * guaranteed that a new string won't have to be allocated, assuming 3352 * the worst case. I also decided not to put any more conditions on it 3353 * than this, for now. It seems likely that, since the worst case is 3354 * twice as big as the unknown portion of the string (plus 1), we won't 3355 * be guaranteed enough space, causing us to go to the first method, 3356 * unless the string is short, or the first variant character is near 3357 * the end of it. In either of these cases, it seems best to use the 3358 * 2nd method. The only circumstance I can think of where this would 3359 * be really slower is if the string had once had much more data in it 3360 * than it does now, but there is still a substantial amount in it */ 3361 3362 { 3363 STRLEN invariant_head = t - s; 3364 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; 3365 if (SvLEN(sv) < size) { 3366 3367 /* Here, have decided to allocate a new string */ 3368 3369 U8 *dst; 3370 U8 *d; 3371 3372 Newx(dst, size, U8); 3373 3374 /* If no known invariants at the beginning of the input string, 3375 * set so starts from there. Otherwise, can use memory copy to 3376 * get up to where we are now, and then start from here */ 3377 3378 if (invariant_head <= 0) { 3379 d = dst; 3380 } else { 3381 Copy(s, dst, invariant_head, char); 3382 d = dst + invariant_head; 3383 } 3384 3385 while (t < e) { 3386 const UV uv = NATIVE8_TO_UNI(*t++); 3387 if (UNI_IS_INVARIANT(uv)) 3388 *d++ = (U8)UNI_TO_NATIVE(uv); 3389 else { 3390 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv); 3391 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv); 3392 } 3393 } 3394 *d = '\0'; 3395 SvPV_free(sv); /* No longer using pre-existing string */ 3396 SvPV_set(sv, (char*)dst); 3397 SvCUR_set(sv, d - dst); 3398 SvLEN_set(sv, size); 3399 } else { 3400 3401 /* Here, have decided to get the exact size of the string. 3402 * Currently this happens only when we know that there is 3403 * guaranteed enough space to fit the converted string, so 3404 * don't have to worry about growing. If two_byte_count is 0, 3405 * then t points to the first byte of the string which hasn't 3406 * been examined yet. Otherwise two_byte_count is 1, and t 3407 * points to the first byte in the string that will expand to 3408 * two. Depending on this, start examining at t or 1 after t. 3409 * */ 3410 3411 U8 *d = t + two_byte_count; 3412 3413 3414 /* Count up the remaining bytes that expand to two */ 3415 3416 while (d < e) { 3417 const U8 chr = *d++; 3418 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++; 3419 } 3420 3421 /* The string will expand by just the number of bytes that 3422 * occupy two positions. But we are one afterwards because of 3423 * the increment just above. This is the place to put the 3424 * trailing NUL, and to set the length before we decrement */ 3425 3426 d += two_byte_count; 3427 SvCUR_set(sv, d - s); 3428 *d-- = '\0'; 3429 3430 3431 /* Having decremented d, it points to the position to put the 3432 * very last byte of the expanded string. Go backwards through 3433 * the string, copying and expanding as we go, stopping when we 3434 * get to the part that is invariant the rest of the way down */ 3435 3436 e--; 3437 while (e >= t) { 3438 const U8 ch = NATIVE8_TO_UNI(*e--); 3439 if (UNI_IS_INVARIANT(ch)) { 3440 *d-- = UNI_TO_NATIVE(ch); 3441 } else { 3442 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch); 3443 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch); 3444 } 3445 } 3446 } 3447 } 3448 } 3449 3450 /* Mark as UTF-8 even if no variant - saves scanning loop */ 3451 SvUTF8_on(sv); 3452 return SvCUR(sv); 3453 } 3454 3455 /* 3456 =for apidoc sv_utf8_downgrade 3457 3458 Attempts to convert the PV of an SV from characters to bytes. 3459 If the PV contains a character that cannot fit 3460 in a byte, this conversion will fail; 3461 in this case, either returns false or, if C<fail_ok> is not 3462 true, croaks. 3463 3464 This is not as a general purpose Unicode to byte encoding interface: 3465 use the Encode extension for that. 3466 3467 =cut 3468 */ 3469 3470 bool 3471 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok) 3472 { 3473 dVAR; 3474 3475 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; 3476 3477 if (SvPOKp(sv) && SvUTF8(sv)) { 3478 if (SvCUR(sv)) { 3479 U8 *s; 3480 STRLEN len; 3481 3482 if (SvIsCOW(sv)) { 3483 sv_force_normal_flags(sv, 0); 3484 } 3485 s = (U8 *) SvPV(sv, len); 3486 if (!utf8_to_bytes(s, &len)) { 3487 if (fail_ok) 3488 return FALSE; 3489 else { 3490 if (PL_op) 3491 Perl_croak(aTHX_ "Wide character in %s", 3492 OP_DESC(PL_op)); 3493 else 3494 Perl_croak(aTHX_ "Wide character"); 3495 } 3496 } 3497 SvCUR_set(sv, len); 3498 } 3499 } 3500 SvUTF8_off(sv); 3501 return TRUE; 3502 } 3503 3504 /* 3505 =for apidoc sv_utf8_encode 3506 3507 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8> 3508 flag off so that it looks like octets again. 3509 3510 =cut 3511 */ 3512 3513 void 3514 Perl_sv_utf8_encode(pTHX_ register SV *const sv) 3515 { 3516 PERL_ARGS_ASSERT_SV_UTF8_ENCODE; 3517 3518 if (SvIsCOW(sv)) { 3519 sv_force_normal_flags(sv, 0); 3520 } 3521 if (SvREADONLY(sv)) { 3522 Perl_croak(aTHX_ "%s", PL_no_modify); 3523 } 3524 (void) sv_utf8_upgrade(sv); 3525 SvUTF8_off(sv); 3526 } 3527 3528 /* 3529 =for apidoc sv_utf8_decode 3530 3531 If the PV of the SV is an octet sequence in UTF-8 3532 and contains a multiple-byte character, the C<SvUTF8> flag is turned on 3533 so that it looks like a character. If the PV contains only single-byte 3534 characters, the C<SvUTF8> flag stays being off. 3535 Scans PV for validity and returns false if the PV is invalid UTF-8. 3536 3537 =cut 3538 */ 3539 3540 bool 3541 Perl_sv_utf8_decode(pTHX_ register SV *const sv) 3542 { 3543 PERL_ARGS_ASSERT_SV_UTF8_DECODE; 3544 3545 if (SvPOKp(sv)) { 3546 const U8 *c; 3547 const U8 *e; 3548 3549 /* The octets may have got themselves encoded - get them back as 3550 * bytes 3551 */ 3552 if (!sv_utf8_downgrade(sv, TRUE)) 3553 return FALSE; 3554 3555 /* it is actually just a matter of turning the utf8 flag on, but 3556 * we want to make sure everything inside is valid utf8 first. 3557 */ 3558 c = (const U8 *) SvPVX_const(sv); 3559 if (!is_utf8_string(c, SvCUR(sv)+1)) 3560 return FALSE; 3561 e = (const U8 *) SvEND(sv); 3562 while (c < e) { 3563 const U8 ch = *c++; 3564 if (!UTF8_IS_INVARIANT(ch)) { 3565 SvUTF8_on(sv); 3566 break; 3567 } 3568 } 3569 } 3570 return TRUE; 3571 } 3572 3573 /* 3574 =for apidoc sv_setsv 3575 3576 Copies the contents of the source SV C<ssv> into the destination SV 3577 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this 3578 function if the source SV needs to be reused. Does not handle 'set' magic. 3579 Loosely speaking, it performs a copy-by-value, obliterating any previous 3580 content of the destination. 3581 3582 You probably want to use one of the assortment of wrappers, such as 3583 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and 3584 C<SvSetMagicSV_nosteal>. 3585 3586 =for apidoc sv_setsv_flags 3587 3588 Copies the contents of the source SV C<ssv> into the destination SV 3589 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this 3590 function if the source SV needs to be reused. Does not handle 'set' magic. 3591 Loosely speaking, it performs a copy-by-value, obliterating any previous 3592 content of the destination. 3593 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on 3594 C<ssv> if appropriate, else not. If the C<flags> parameter has the 3595 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv> 3596 and C<sv_setsv_nomg> are implemented in terms of this function. 3597 3598 You probably want to use one of the assortment of wrappers, such as 3599 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and 3600 C<SvSetMagicSV_nosteal>. 3601 3602 This is the primary function for copying scalars, and most other 3603 copy-ish functions and macros use this underneath. 3604 3605 =cut 3606 */ 3607 3608 static void 3609 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) 3610 { 3611 I32 mro_changes = 0; /* 1 = method, 2 = isa */ 3612 3613 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; 3614 3615 if (dtype != SVt_PVGV) { 3616 const char * const name = GvNAME(sstr); 3617 const STRLEN len = GvNAMELEN(sstr); 3618 { 3619 if (dtype >= SVt_PV) { 3620 SvPV_free(dstr); 3621 SvPV_set(dstr, 0); 3622 SvLEN_set(dstr, 0); 3623 SvCUR_set(dstr, 0); 3624 } 3625 SvUPGRADE(dstr, SVt_PVGV); 3626 (void)SvOK_off(dstr); 3627 /* FIXME - why are we doing this, then turning it off and on again 3628 below? */ 3629 isGV_with_GP_on(dstr); 3630 } 3631 GvSTASH(dstr) = GvSTASH(sstr); 3632 if (GvSTASH(dstr)) 3633 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); 3634 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD); 3635 SvFAKE_on(dstr); /* can coerce to non-glob */ 3636 } 3637 3638 if(GvGP(MUTABLE_GV(sstr))) { 3639 /* If source has method cache entry, clear it */ 3640 if(GvCVGEN(sstr)) { 3641 SvREFCNT_dec(GvCV(sstr)); 3642 GvCV(sstr) = NULL; 3643 GvCVGEN(sstr) = 0; 3644 } 3645 /* If source has a real method, then a method is 3646 going to change */ 3647 else if(GvCV((const GV *)sstr)) { 3648 mro_changes = 1; 3649 } 3650 } 3651 3652 /* If dest already had a real method, that's a change as well */ 3653 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) { 3654 mro_changes = 1; 3655 } 3656 3657 if(strEQ(GvNAME((const GV *)dstr),"ISA")) 3658 mro_changes = 2; 3659 3660 gp_free(MUTABLE_GV(dstr)); 3661 isGV_with_GP_off(dstr); 3662 (void)SvOK_off(dstr); 3663 isGV_with_GP_on(dstr); 3664 GvINTRO_off(dstr); /* one-shot flag */ 3665 GvGP(dstr) = gp_ref(GvGP(sstr)); 3666 if (SvTAINTED(sstr)) 3667 SvTAINT(dstr); 3668 if (GvIMPORTED(dstr) != GVf_IMPORTED 3669 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) 3670 { 3671 GvIMPORTED_on(dstr); 3672 } 3673 GvMULTI_on(dstr); 3674 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr)); 3675 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); 3676 return; 3677 } 3678 3679 static void 3680 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) 3681 { 3682 SV * const sref = SvREFCNT_inc(SvRV(sstr)); 3683 SV *dref = NULL; 3684 const int intro = GvINTRO(dstr); 3685 SV **location; 3686 U8 import_flag = 0; 3687 const U32 stype = SvTYPE(sref); 3688 3689 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; 3690 3691 if (intro) { 3692 GvINTRO_off(dstr); /* one-shot flag */ 3693 GvLINE(dstr) = CopLINE(PL_curcop); 3694 GvEGV(dstr) = MUTABLE_GV(dstr); 3695 } 3696 GvMULTI_on(dstr); 3697 switch (stype) { 3698 case SVt_PVCV: 3699 location = (SV **) &GvCV(dstr); 3700 import_flag = GVf_IMPORTED_CV; 3701 goto common; 3702 case SVt_PVHV: 3703 location = (SV **) &GvHV(dstr); 3704 import_flag = GVf_IMPORTED_HV; 3705 goto common; 3706 case SVt_PVAV: 3707 location = (SV **) &GvAV(dstr); 3708 import_flag = GVf_IMPORTED_AV; 3709 goto common; 3710 case SVt_PVIO: 3711 location = (SV **) &GvIOp(dstr); 3712 goto common; 3713 case SVt_PVFM: 3714 location = (SV **) &GvFORM(dstr); 3715 goto common; 3716 default: 3717 location = &GvSV(dstr); 3718 import_flag = GVf_IMPORTED_SV; 3719 common: 3720 if (intro) { 3721 if (stype == SVt_PVCV) { 3722 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/ 3723 if (GvCVGEN(dstr)) { 3724 SvREFCNT_dec(GvCV(dstr)); 3725 GvCV(dstr) = NULL; 3726 GvCVGEN(dstr) = 0; /* Switch off cacheness. */ 3727 } 3728 } 3729 SAVEGENERICSV(*location); 3730 } 3731 else 3732 dref = *location; 3733 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { 3734 CV* const cv = MUTABLE_CV(*location); 3735 if (cv) { 3736 if (!GvCVGEN((const GV *)dstr) && 3737 (CvROOT(cv) || CvXSUB(cv))) 3738 { 3739 /* Redefining a sub - warning is mandatory if 3740 it was a const and its value changed. */ 3741 if (CvCONST(cv) && CvCONST((const CV *)sref) 3742 && cv_const_sv(cv) 3743 == cv_const_sv((const CV *)sref)) { 3744 NOOP; 3745 /* They are 2 constant subroutines generated from 3746 the same constant. This probably means that 3747 they are really the "same" proxy subroutine 3748 instantiated in 2 places. Most likely this is 3749 when a constant is exported twice. Don't warn. 3750 */ 3751 } 3752 else if (ckWARN(WARN_REDEFINE) 3753 || (CvCONST(cv) 3754 && (!CvCONST((const CV *)sref) 3755 || sv_cmp(cv_const_sv(cv), 3756 cv_const_sv((const CV *) 3757 sref))))) { 3758 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 3759 (const char *) 3760 (CvCONST(cv) 3761 ? "Constant subroutine %s::%s redefined" 3762 : "Subroutine %s::%s redefined"), 3763 HvNAME_get(GvSTASH((const GV *)dstr)), 3764 GvENAME(MUTABLE_GV(dstr))); 3765 } 3766 } 3767 if (!intro) 3768 cv_ckproto_len(cv, (const GV *)dstr, 3769 SvPOK(sref) ? SvPVX_const(sref) : NULL, 3770 SvPOK(sref) ? SvCUR(sref) : 0); 3771 } 3772 GvCVGEN(dstr) = 0; /* Switch off cacheness. */ 3773 GvASSUMECV_on(dstr); 3774 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ 3775 } 3776 *location = sref; 3777 if (import_flag && !(GvFLAGS(dstr) & import_flag) 3778 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { 3779 GvFLAGS(dstr) |= import_flag; 3780 } 3781 if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) { 3782 sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); 3783 mro_isa_changed_in(GvSTASH(dstr)); 3784 } 3785 break; 3786 } 3787 SvREFCNT_dec(dref); 3788 if (SvTAINTED(sstr)) 3789 SvTAINT(dstr); 3790 return; 3791 } 3792 3793 void 3794 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) 3795 { 3796 dVAR; 3797 register U32 sflags; 3798 register int dtype; 3799 register svtype stype; 3800 3801 PERL_ARGS_ASSERT_SV_SETSV_FLAGS; 3802 3803 if (sstr == dstr) 3804 return; 3805 3806 if (SvIS_FREED(dstr)) { 3807 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf 3808 " to a freed scalar %p", SVfARG(sstr), (void *)dstr); 3809 } 3810 SV_CHECK_THINKFIRST_COW_DROP(dstr); 3811 if (!sstr) 3812 sstr = &PL_sv_undef; 3813 if (SvIS_FREED(sstr)) { 3814 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", 3815 (void*)sstr, (void*)dstr); 3816 } 3817 stype = SvTYPE(sstr); 3818 dtype = SvTYPE(dstr); 3819 3820 (void)SvAMAGIC_off(dstr); 3821 if ( SvVOK(dstr) ) 3822 { 3823 /* need to nuke the magic */ 3824 mg_free(dstr); 3825 } 3826 3827 /* There's a lot of redundancy below but we're going for speed here */ 3828 3829 switch (stype) { 3830 case SVt_NULL: 3831 undef_sstr: 3832 if (dtype != SVt_PVGV) { 3833 (void)SvOK_off(dstr); 3834 return; 3835 } 3836 break; 3837 case SVt_IV: 3838 if (SvIOK(sstr)) { 3839 switch (dtype) { 3840 case SVt_NULL: 3841 sv_upgrade(dstr, SVt_IV); 3842 break; 3843 case SVt_NV: 3844 case SVt_PV: 3845 sv_upgrade(dstr, SVt_PVIV); 3846 break; 3847 case SVt_PVGV: 3848 goto end_of_first_switch; 3849 } 3850 (void)SvIOK_only(dstr); 3851 SvIV_set(dstr, SvIVX(sstr)); 3852 if (SvIsUV(sstr)) 3853 SvIsUV_on(dstr); 3854 /* SvTAINTED can only be true if the SV has taint magic, which in 3855 turn means that the SV type is PVMG (or greater). This is the 3856 case statement for SVt_IV, so this cannot be true (whatever gcov 3857 may say). */ 3858 assert(!SvTAINTED(sstr)); 3859 return; 3860 } 3861 if (!SvROK(sstr)) 3862 goto undef_sstr; 3863 if (dtype < SVt_PV && dtype != SVt_IV) 3864 sv_upgrade(dstr, SVt_IV); 3865 break; 3866 3867 case SVt_NV: 3868 if (SvNOK(sstr)) { 3869 switch (dtype) { 3870 case SVt_NULL: 3871 case SVt_IV: 3872 sv_upgrade(dstr, SVt_NV); 3873 break; 3874 case SVt_PV: 3875 case SVt_PVIV: 3876 sv_upgrade(dstr, SVt_PVNV); 3877 break; 3878 case SVt_PVGV: 3879 goto end_of_first_switch; 3880 } 3881 SvNV_set(dstr, SvNVX(sstr)); 3882 (void)SvNOK_only(dstr); 3883 /* SvTAINTED can only be true if the SV has taint magic, which in 3884 turn means that the SV type is PVMG (or greater). This is the 3885 case statement for SVt_NV, so this cannot be true (whatever gcov 3886 may say). */ 3887 assert(!SvTAINTED(sstr)); 3888 return; 3889 } 3890 goto undef_sstr; 3891 3892 case SVt_PVFM: 3893 #ifdef PERL_OLD_COPY_ON_WRITE 3894 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { 3895 if (dtype < SVt_PVIV) 3896 sv_upgrade(dstr, SVt_PVIV); 3897 break; 3898 } 3899 /* Fall through */ 3900 #endif 3901 case SVt_PV: 3902 if (dtype < SVt_PV) 3903 sv_upgrade(dstr, SVt_PV); 3904 break; 3905 case SVt_PVIV: 3906 if (dtype < SVt_PVIV) 3907 sv_upgrade(dstr, SVt_PVIV); 3908 break; 3909 case SVt_PVNV: 3910 if (dtype < SVt_PVNV) 3911 sv_upgrade(dstr, SVt_PVNV); 3912 break; 3913 default: 3914 { 3915 const char * const type = sv_reftype(sstr,0); 3916 if (PL_op) 3917 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op)); 3918 else 3919 Perl_croak(aTHX_ "Bizarre copy of %s", type); 3920 } 3921 break; 3922 3923 case SVt_REGEXP: 3924 if (dtype < SVt_REGEXP) 3925 sv_upgrade(dstr, SVt_REGEXP); 3926 break; 3927 3928 /* case SVt_BIND: */ 3929 case SVt_PVLV: 3930 case SVt_PVGV: 3931 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { 3932 glob_assign_glob(dstr, sstr, dtype); 3933 return; 3934 } 3935 /* SvVALID means that this PVGV is playing at being an FBM. */ 3936 /*FALLTHROUGH*/ 3937 3938 case SVt_PVMG: 3939 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { 3940 mg_get(sstr); 3941 if (SvTYPE(sstr) != stype) { 3942 stype = SvTYPE(sstr); 3943 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) { 3944 glob_assign_glob(dstr, sstr, dtype); 3945 return; 3946 } 3947 } 3948 } 3949 if (stype == SVt_PVLV) 3950 SvUPGRADE(dstr, SVt_PVNV); 3951 else 3952 SvUPGRADE(dstr, (svtype)stype); 3953 } 3954 end_of_first_switch: 3955 3956 /* dstr may have been upgraded. */ 3957 dtype = SvTYPE(dstr); 3958 sflags = SvFLAGS(sstr); 3959 3960 if (dtype == SVt_PVCV || dtype == SVt_PVFM) { 3961 /* Assigning to a subroutine sets the prototype. */ 3962 if (SvOK(sstr)) { 3963 STRLEN len; 3964 const char *const ptr = SvPV_const(sstr, len); 3965 3966 SvGROW(dstr, len + 1); 3967 Copy(ptr, SvPVX(dstr), len + 1, char); 3968 SvCUR_set(dstr, len); 3969 SvPOK_only(dstr); 3970 SvFLAGS(dstr) |= sflags & SVf_UTF8; 3971 } else { 3972 SvOK_off(dstr); 3973 } 3974 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { 3975 const char * const type = sv_reftype(dstr,0); 3976 if (PL_op) 3977 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op)); 3978 else 3979 Perl_croak(aTHX_ "Cannot copy to %s", type); 3980 } else if (sflags & SVf_ROK) { 3981 if (isGV_with_GP(dstr) && dtype == SVt_PVGV 3982 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) { 3983 sstr = SvRV(sstr); 3984 if (sstr == dstr) { 3985 if (GvIMPORTED(dstr) != GVf_IMPORTED 3986 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) 3987 { 3988 GvIMPORTED_on(dstr); 3989 } 3990 GvMULTI_on(dstr); 3991 return; 3992 } 3993 glob_assign_glob(dstr, sstr, dtype); 3994 return; 3995 } 3996 3997 if (dtype >= SVt_PV) { 3998 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { 3999 glob_assign_ref(dstr, sstr); 4000 return; 4001 } 4002 if (SvPVX_const(dstr)) { 4003 SvPV_free(dstr); 4004 SvLEN_set(dstr, 0); 4005 SvCUR_set(dstr, 0); 4006 } 4007 } 4008 (void)SvOK_off(dstr); 4009 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); 4010 SvFLAGS(dstr) |= sflags & SVf_ROK; 4011 assert(!(sflags & SVp_NOK)); 4012 assert(!(sflags & SVp_IOK)); 4013 assert(!(sflags & SVf_NOK)); 4014 assert(!(sflags & SVf_IOK)); 4015 } 4016 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { 4017 if (!(sflags & SVf_OK)) { 4018 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 4019 "Undefined value assigned to typeglob"); 4020 } 4021 else { 4022 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV); 4023 if (dstr != (const SV *)gv) { 4024 if (GvGP(dstr)) 4025 gp_free(MUTABLE_GV(dstr)); 4026 GvGP(dstr) = gp_ref(GvGP(gv)); 4027 } 4028 } 4029 } 4030 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) { 4031 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); 4032 } 4033 else if (sflags & SVp_POK) { 4034 bool isSwipe = 0; 4035 4036 /* 4037 * Check to see if we can just swipe the string. If so, it's a 4038 * possible small lose on short strings, but a big win on long ones. 4039 * It might even be a win on short strings if SvPVX_const(dstr) 4040 * has to be allocated and SvPVX_const(sstr) has to be freed. 4041 * Likewise if we can set up COW rather than doing an actual copy, we 4042 * drop to the else clause, as the swipe code and the COW setup code 4043 * have much in common. 4044 */ 4045 4046 /* Whichever path we take through the next code, we want this true, 4047 and doing it now facilitates the COW check. */ 4048 (void)SvPOK_only(dstr); 4049 4050 if ( 4051 /* If we're already COW then this clause is not true, and if COW 4052 is allowed then we drop down to the else and make dest COW 4053 with us. If caller hasn't said that we're allowed to COW 4054 shared hash keys then we don't do the COW setup, even if the 4055 source scalar is a shared hash key scalar. */ 4056 (((flags & SV_COW_SHARED_HASH_KEYS) 4057 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY) 4058 : 1 /* If making a COW copy is forbidden then the behaviour we 4059 desire is as if the source SV isn't actually already 4060 COW, even if it is. So we act as if the source flags 4061 are not COW, rather than actually testing them. */ 4062 ) 4063 #ifndef PERL_OLD_COPY_ON_WRITE 4064 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic 4065 when PERL_OLD_COPY_ON_WRITE is defined a little wrong. 4066 Conceptually PERL_OLD_COPY_ON_WRITE being defined should 4067 override SV_COW_SHARED_HASH_KEYS, because it means "always COW" 4068 but in turn, it's somewhat dead code, never expected to go 4069 live, but more kept as a placeholder on how to do it better 4070 in a newer implementation. */ 4071 /* If we are COW and dstr is a suitable target then we drop down 4072 into the else and make dest a COW of us. */ 4073 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS 4074 #endif 4075 ) 4076 && 4077 !(isSwipe = 4078 (sflags & SVs_TEMP) && /* slated for free anyway? */ 4079 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ 4080 (!(flags & SV_NOSTEAL)) && 4081 /* and we're allowed to steal temps */ 4082 SvREFCNT(sstr) == 1 && /* and no other references to it? */ 4083 SvLEN(sstr) && /* and really is a string */ 4084 /* and won't be needed again, potentially */ 4085 !(PL_op && PL_op->op_type == OP_AASSIGN)) 4086 #ifdef PERL_OLD_COPY_ON_WRITE 4087 && ((flags & SV_COW_SHARED_HASH_KEYS) 4088 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS 4089 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS 4090 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM)) 4091 : 1) 4092 #endif 4093 ) { 4094 /* Failed the swipe test, and it's not a shared hash key either. 4095 Have to copy the string. */ 4096 STRLEN len = SvCUR(sstr); 4097 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ 4098 Move(SvPVX_const(sstr),SvPVX(dstr),len,char); 4099 SvCUR_set(dstr, len); 4100 *SvEND(dstr) = '\0'; 4101 } else { 4102 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always 4103 be true in here. */ 4104 /* Either it's a shared hash key, or it's suitable for 4105 copy-on-write or we can swipe the string. */ 4106 if (DEBUG_C_TEST) { 4107 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); 4108 sv_dump(sstr); 4109 sv_dump(dstr); 4110 } 4111 #ifdef PERL_OLD_COPY_ON_WRITE 4112 if (!isSwipe) { 4113 if ((sflags & (SVf_FAKE | SVf_READONLY)) 4114 != (SVf_FAKE | SVf_READONLY)) { 4115 SvREADONLY_on(sstr); 4116 SvFAKE_on(sstr); 4117 /* Make the source SV into a loop of 1. 4118 (about to become 2) */ 4119 SV_COW_NEXT_SV_SET(sstr, sstr); 4120 } 4121 } 4122 #endif 4123 /* Initial code is common. */ 4124 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ 4125 SvPV_free(dstr); 4126 } 4127 4128 if (!isSwipe) { 4129 /* making another shared SV. */ 4130 STRLEN cur = SvCUR(sstr); 4131 STRLEN len = SvLEN(sstr); 4132 #ifdef PERL_OLD_COPY_ON_WRITE 4133 if (len) { 4134 assert (SvTYPE(dstr) >= SVt_PVIV); 4135 /* SvIsCOW_normal */ 4136 /* splice us in between source and next-after-source. */ 4137 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); 4138 SV_COW_NEXT_SV_SET(sstr, dstr); 4139 SvPV_set(dstr, SvPVX_mutable(sstr)); 4140 } else 4141 #endif 4142 { 4143 /* SvIsCOW_shared_hash */ 4144 DEBUG_C(PerlIO_printf(Perl_debug_log, 4145 "Copy on write: Sharing hash\n")); 4146 4147 assert (SvTYPE(dstr) >= SVt_PV); 4148 SvPV_set(dstr, 4149 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); 4150 } 4151 SvLEN_set(dstr, len); 4152 SvCUR_set(dstr, cur); 4153 SvREADONLY_on(dstr); 4154 SvFAKE_on(dstr); 4155 } 4156 else 4157 { /* Passes the swipe test. */ 4158 SvPV_set(dstr, SvPVX_mutable(sstr)); 4159 SvLEN_set(dstr, SvLEN(sstr)); 4160 SvCUR_set(dstr, SvCUR(sstr)); 4161 4162 SvTEMP_off(dstr); 4163 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ 4164 SvPV_set(sstr, NULL); 4165 SvLEN_set(sstr, 0); 4166 SvCUR_set(sstr, 0); 4167 SvTEMP_off(sstr); 4168 } 4169 } 4170 if (sflags & SVp_NOK) { 4171 SvNV_set(dstr, SvNVX(sstr)); 4172 } 4173 if (sflags & SVp_IOK) { 4174 SvIV_set(dstr, SvIVX(sstr)); 4175 /* Must do this otherwise some other overloaded use of 0x80000000 4176 gets confused. I guess SVpbm_VALID */ 4177 if (sflags & SVf_IVisUV) 4178 SvIsUV_on(dstr); 4179 } 4180 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); 4181 { 4182 const MAGIC * const smg = SvVSTRING_mg(sstr); 4183 if (smg) { 4184 sv_magic(dstr, NULL, PERL_MAGIC_vstring, 4185 smg->mg_ptr, smg->mg_len); 4186 SvRMAGICAL_on(dstr); 4187 } 4188 } 4189 } 4190 else if (sflags & (SVp_IOK|SVp_NOK)) { 4191 (void)SvOK_off(dstr); 4192 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); 4193 if (sflags & SVp_IOK) { 4194 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ 4195 SvIV_set(dstr, SvIVX(sstr)); 4196 } 4197 if (sflags & SVp_NOK) { 4198 SvNV_set(dstr, SvNVX(sstr)); 4199 } 4200 } 4201 else { 4202 if (isGV_with_GP(sstr)) { 4203 /* This stringification rule for globs is spread in 3 places. 4204 This feels bad. FIXME. */ 4205 const U32 wasfake = sflags & SVf_FAKE; 4206 4207 /* FAKE globs can get coerced, so need to turn this off 4208 temporarily if it is on. */ 4209 SvFAKE_off(sstr); 4210 gv_efullname3(dstr, MUTABLE_GV(sstr), "*"); 4211 SvFLAGS(sstr) |= wasfake; 4212 } 4213 else 4214 (void)SvOK_off(dstr); 4215 } 4216 if (SvTAINTED(sstr)) 4217 SvTAINT(dstr); 4218 } 4219 4220 /* 4221 =for apidoc sv_setsv_mg 4222 4223 Like C<sv_setsv>, but also handles 'set' magic. 4224 4225 =cut 4226 */ 4227 4228 void 4229 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr) 4230 { 4231 PERL_ARGS_ASSERT_SV_SETSV_MG; 4232 4233 sv_setsv(dstr,sstr); 4234 SvSETMAGIC(dstr); 4235 } 4236 4237 #ifdef PERL_OLD_COPY_ON_WRITE 4238 SV * 4239 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) 4240 { 4241 STRLEN cur = SvCUR(sstr); 4242 STRLEN len = SvLEN(sstr); 4243 register char *new_pv; 4244 4245 PERL_ARGS_ASSERT_SV_SETSV_COW; 4246 4247 if (DEBUG_C_TEST) { 4248 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", 4249 (void*)sstr, (void*)dstr); 4250 sv_dump(sstr); 4251 if (dstr) 4252 sv_dump(dstr); 4253 } 4254 4255 if (dstr) { 4256 if (SvTHINKFIRST(dstr)) 4257 sv_force_normal_flags(dstr, SV_COW_DROP_PV); 4258 else if (SvPVX_const(dstr)) 4259 Safefree(SvPVX_const(dstr)); 4260 } 4261 else 4262 new_SV(dstr); 4263 SvUPGRADE(dstr, SVt_PVIV); 4264 4265 assert (SvPOK(sstr)); 4266 assert (SvPOKp(sstr)); 4267 assert (!SvIOK(sstr)); 4268 assert (!SvIOKp(sstr)); 4269 assert (!SvNOK(sstr)); 4270 assert (!SvNOKp(sstr)); 4271 4272 if (SvIsCOW(sstr)) { 4273 4274 if (SvLEN(sstr) == 0) { 4275 /* source is a COW shared hash key. */ 4276 DEBUG_C(PerlIO_printf(Perl_debug_log, 4277 "Fast copy on write: Sharing hash\n")); 4278 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); 4279 goto common_exit; 4280 } 4281 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); 4282 } else { 4283 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); 4284 SvUPGRADE(sstr, SVt_PVIV); 4285 SvREADONLY_on(sstr); 4286 SvFAKE_on(sstr); 4287 DEBUG_C(PerlIO_printf(Perl_debug_log, 4288 "Fast copy on write: Converting sstr to COW\n")); 4289 SV_COW_NEXT_SV_SET(dstr, sstr); 4290 } 4291 SV_COW_NEXT_SV_SET(sstr, dstr); 4292 new_pv = SvPVX_mutable(sstr); 4293 4294 common_exit: 4295 SvPV_set(dstr, new_pv); 4296 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY); 4297 if (SvUTF8(sstr)) 4298 SvUTF8_on(dstr); 4299 SvLEN_set(dstr, len); 4300 SvCUR_set(dstr, cur); 4301 if (DEBUG_C_TEST) { 4302 sv_dump(dstr); 4303 } 4304 return dstr; 4305 } 4306 #endif 4307 4308 /* 4309 =for apidoc sv_setpvn 4310 4311 Copies a string into an SV. The C<len> parameter indicates the number of 4312 bytes to be copied. If the C<ptr> argument is NULL the SV will become 4313 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>. 4314 4315 =cut 4316 */ 4317 4318 void 4319 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) 4320 { 4321 dVAR; 4322 register char *dptr; 4323 4324 PERL_ARGS_ASSERT_SV_SETPVN; 4325 4326 SV_CHECK_THINKFIRST_COW_DROP(sv); 4327 if (!ptr) { 4328 (void)SvOK_off(sv); 4329 return; 4330 } 4331 else { 4332 /* len is STRLEN which is unsigned, need to copy to signed */ 4333 const IV iv = len; 4334 if (iv < 0) 4335 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen"); 4336 } 4337 SvUPGRADE(sv, SVt_PV); 4338 4339 dptr = SvGROW(sv, len + 1); 4340 Move(ptr,dptr,len,char); 4341 dptr[len] = '\0'; 4342 SvCUR_set(sv, len); 4343 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4344 SvTAINT(sv); 4345 } 4346 4347 /* 4348 =for apidoc sv_setpvn_mg 4349 4350 Like C<sv_setpvn>, but also handles 'set' magic. 4351 4352 =cut 4353 */ 4354 4355 void 4356 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) 4357 { 4358 PERL_ARGS_ASSERT_SV_SETPVN_MG; 4359 4360 sv_setpvn(sv,ptr,len); 4361 SvSETMAGIC(sv); 4362 } 4363 4364 /* 4365 =for apidoc sv_setpv 4366 4367 Copies a string into an SV. The string must be null-terminated. Does not 4368 handle 'set' magic. See C<sv_setpv_mg>. 4369 4370 =cut 4371 */ 4372 4373 void 4374 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr) 4375 { 4376 dVAR; 4377 register STRLEN len; 4378 4379 PERL_ARGS_ASSERT_SV_SETPV; 4380 4381 SV_CHECK_THINKFIRST_COW_DROP(sv); 4382 if (!ptr) { 4383 (void)SvOK_off(sv); 4384 return; 4385 } 4386 len = strlen(ptr); 4387 SvUPGRADE(sv, SVt_PV); 4388 4389 SvGROW(sv, len + 1); 4390 Move(ptr,SvPVX(sv),len+1,char); 4391 SvCUR_set(sv, len); 4392 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4393 SvTAINT(sv); 4394 } 4395 4396 /* 4397 =for apidoc sv_setpv_mg 4398 4399 Like C<sv_setpv>, but also handles 'set' magic. 4400 4401 =cut 4402 */ 4403 4404 void 4405 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr) 4406 { 4407 PERL_ARGS_ASSERT_SV_SETPV_MG; 4408 4409 sv_setpv(sv,ptr); 4410 SvSETMAGIC(sv); 4411 } 4412 4413 /* 4414 =for apidoc sv_usepvn_flags 4415 4416 Tells an SV to use C<ptr> to find its string value. Normally the 4417 string is stored inside the SV but sv_usepvn allows the SV to use an 4418 outside string. The C<ptr> should point to memory that was allocated 4419 by C<malloc>. The string length, C<len>, must be supplied. By default 4420 this function will realloc (i.e. move) the memory pointed to by C<ptr>, 4421 so that pointer should not be freed or used by the programmer after 4422 giving it to sv_usepvn, and neither should any pointers from "behind" 4423 that pointer (e.g. ptr + 1) be used. 4424 4425 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> & 4426 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc 4427 will be skipped. (i.e. the buffer is actually at least 1 byte longer than 4428 C<len>, and already meets the requirements for storing in C<SvPVX>) 4429 4430 =cut 4431 */ 4432 4433 void 4434 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) 4435 { 4436 dVAR; 4437 STRLEN allocate; 4438 4439 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS; 4440 4441 SV_CHECK_THINKFIRST_COW_DROP(sv); 4442 SvUPGRADE(sv, SVt_PV); 4443 if (!ptr) { 4444 (void)SvOK_off(sv); 4445 if (flags & SV_SMAGIC) 4446 SvSETMAGIC(sv); 4447 return; 4448 } 4449 if (SvPVX_const(sv)) 4450 SvPV_free(sv); 4451 4452 #ifdef DEBUGGING 4453 if (flags & SV_HAS_TRAILING_NUL) 4454 assert(ptr[len] == '\0'); 4455 #endif 4456 4457 allocate = (flags & SV_HAS_TRAILING_NUL) 4458 ? len + 1 : 4459 #ifdef Perl_safesysmalloc_size 4460 len + 1; 4461 #else 4462 PERL_STRLEN_ROUNDUP(len + 1); 4463 #endif 4464 if (flags & SV_HAS_TRAILING_NUL) { 4465 /* It's long enough - do nothing. 4466 Specfically Perl_newCONSTSUB is relying on this. */ 4467 } else { 4468 #ifdef DEBUGGING 4469 /* Force a move to shake out bugs in callers. */ 4470 char *new_ptr = (char*)safemalloc(allocate); 4471 Copy(ptr, new_ptr, len, char); 4472 PoisonFree(ptr,len,char); 4473 Safefree(ptr); 4474 ptr = new_ptr; 4475 #else 4476 ptr = (char*) saferealloc (ptr, allocate); 4477 #endif 4478 } 4479 #ifdef Perl_safesysmalloc_size 4480 SvLEN_set(sv, Perl_safesysmalloc_size(ptr)); 4481 #else 4482 SvLEN_set(sv, allocate); 4483 #endif 4484 SvCUR_set(sv, len); 4485 SvPV_set(sv, ptr); 4486 if (!(flags & SV_HAS_TRAILING_NUL)) { 4487 ptr[len] = '\0'; 4488 } 4489 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4490 SvTAINT(sv); 4491 if (flags & SV_SMAGIC) 4492 SvSETMAGIC(sv); 4493 } 4494 4495 #ifdef PERL_OLD_COPY_ON_WRITE 4496 /* Need to do this *after* making the SV normal, as we need the buffer 4497 pointer to remain valid until after we've copied it. If we let go too early, 4498 another thread could invalidate it by unsharing last of the same hash key 4499 (which it can do by means other than releasing copy-on-write Svs) 4500 or by changing the other copy-on-write SVs in the loop. */ 4501 STATIC void 4502 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after) 4503 { 4504 PERL_ARGS_ASSERT_SV_RELEASE_COW; 4505 4506 { /* this SV was SvIsCOW_normal(sv) */ 4507 /* we need to find the SV pointing to us. */ 4508 SV *current = SV_COW_NEXT_SV(after); 4509 4510 if (current == sv) { 4511 /* The SV we point to points back to us (there were only two of us 4512 in the loop.) 4513 Hence other SV is no longer copy on write either. */ 4514 SvFAKE_off(after); 4515 SvREADONLY_off(after); 4516 } else { 4517 /* We need to follow the pointers around the loop. */ 4518 SV *next; 4519 while ((next = SV_COW_NEXT_SV(current)) != sv) { 4520 assert (next); 4521 current = next; 4522 /* don't loop forever if the structure is bust, and we have 4523 a pointer into a closed loop. */ 4524 assert (current != after); 4525 assert (SvPVX_const(current) == pvx); 4526 } 4527 /* Make the SV before us point to the SV after us. */ 4528 SV_COW_NEXT_SV_SET(current, after); 4529 } 4530 } 4531 } 4532 #endif 4533 /* 4534 =for apidoc sv_force_normal_flags 4535 4536 Undo various types of fakery on an SV: if the PV is a shared string, make 4537 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to 4538 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when 4539 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set 4540 then a copy-on-write scalar drops its PV buffer (if any) and becomes 4541 SvPOK_off rather than making a copy. (Used where this scalar is about to be 4542 set to some other value.) In addition, the C<flags> parameter gets passed to 4543 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function 4544 with flags set to 0. 4545 4546 =cut 4547 */ 4548 4549 void 4550 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) 4551 { 4552 dVAR; 4553 4554 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; 4555 4556 #ifdef PERL_OLD_COPY_ON_WRITE 4557 if (SvREADONLY(sv)) { 4558 if (SvFAKE(sv)) { 4559 const char * const pvx = SvPVX_const(sv); 4560 const STRLEN len = SvLEN(sv); 4561 const STRLEN cur = SvCUR(sv); 4562 /* next COW sv in the loop. If len is 0 then this is a shared-hash 4563 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as 4564 we'll fail an assertion. */ 4565 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; 4566 4567 if (DEBUG_C_TEST) { 4568 PerlIO_printf(Perl_debug_log, 4569 "Copy on write: Force normal %ld\n", 4570 (long) flags); 4571 sv_dump(sv); 4572 } 4573 SvFAKE_off(sv); 4574 SvREADONLY_off(sv); 4575 /* This SV doesn't own the buffer, so need to Newx() a new one: */ 4576 SvPV_set(sv, NULL); 4577 SvLEN_set(sv, 0); 4578 if (flags & SV_COW_DROP_PV) { 4579 /* OK, so we don't need to copy our buffer. */ 4580 SvPOK_off(sv); 4581 } else { 4582 SvGROW(sv, cur + 1); 4583 Move(pvx,SvPVX(sv),cur,char); 4584 SvCUR_set(sv, cur); 4585 *SvEND(sv) = '\0'; 4586 } 4587 if (len) { 4588 sv_release_COW(sv, pvx, next); 4589 } else { 4590 unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); 4591 } 4592 if (DEBUG_C_TEST) { 4593 sv_dump(sv); 4594 } 4595 } 4596 else if (IN_PERL_RUNTIME) 4597 Perl_croak(aTHX_ "%s", PL_no_modify); 4598 } 4599 #else 4600 if (SvREADONLY(sv)) { 4601 if (SvFAKE(sv)) { 4602 const char * const pvx = SvPVX_const(sv); 4603 const STRLEN len = SvCUR(sv); 4604 SvFAKE_off(sv); 4605 SvREADONLY_off(sv); 4606 SvPV_set(sv, NULL); 4607 SvLEN_set(sv, 0); 4608 SvGROW(sv, len + 1); 4609 Move(pvx,SvPVX(sv),len,char); 4610 *SvEND(sv) = '\0'; 4611 unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); 4612 } 4613 else if (IN_PERL_RUNTIME) 4614 Perl_croak(aTHX_ "%s", PL_no_modify); 4615 } 4616 #endif 4617 if (SvROK(sv)) 4618 sv_unref_flags(sv, flags); 4619 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) 4620 sv_unglob(sv); 4621 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { 4622 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous 4623 to sv_unglob. We only need it here, so inline it. */ 4624 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; 4625 SV *const temp = newSV_type(new_type); 4626 void *const temp_p = SvANY(sv); 4627 4628 if (new_type == SVt_PVMG) { 4629 SvMAGIC_set(temp, SvMAGIC(sv)); 4630 SvMAGIC_set(sv, NULL); 4631 SvSTASH_set(temp, SvSTASH(sv)); 4632 SvSTASH_set(sv, NULL); 4633 } 4634 SvCUR_set(temp, SvCUR(sv)); 4635 /* Remember that SvPVX is in the head, not the body. */ 4636 if (SvLEN(temp)) { 4637 SvLEN_set(temp, SvLEN(sv)); 4638 /* This signals "buffer is owned by someone else" in sv_clear, 4639 which is the least effort way to stop it freeing the buffer. 4640 */ 4641 SvLEN_set(sv, SvLEN(sv)+1); 4642 } else { 4643 /* Their buffer is already owned by someone else. */ 4644 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv)); 4645 SvLEN_set(temp, SvCUR(sv)+1); 4646 } 4647 4648 /* Now swap the rest of the bodies. */ 4649 4650 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK); 4651 SvFLAGS(sv) |= new_type; 4652 SvANY(sv) = SvANY(temp); 4653 4654 SvFLAGS(temp) &= ~(SVTYPEMASK); 4655 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; 4656 SvANY(temp) = temp_p; 4657 4658 SvREFCNT_dec(temp); 4659 } 4660 } 4661 4662 /* 4663 =for apidoc sv_chop 4664 4665 Efficient removal of characters from the beginning of the string buffer. 4666 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside 4667 the string buffer. The C<ptr> becomes the first character of the adjusted 4668 string. Uses the "OOK hack". 4669 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer 4670 refer to the same chunk of data. 4671 4672 =cut 4673 */ 4674 4675 void 4676 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) 4677 { 4678 STRLEN delta; 4679 STRLEN old_delta; 4680 U8 *p; 4681 #ifdef DEBUGGING 4682 const U8 *real_start; 4683 #endif 4684 STRLEN max_delta; 4685 4686 PERL_ARGS_ASSERT_SV_CHOP; 4687 4688 if (!ptr || !SvPOKp(sv)) 4689 return; 4690 delta = ptr - SvPVX_const(sv); 4691 if (!delta) { 4692 /* Nothing to do. */ 4693 return; 4694 } 4695 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line, 4696 nothing uses the value of ptr any more. */ 4697 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); 4698 if (ptr <= SvPVX_const(sv)) 4699 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", 4700 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); 4701 SV_CHECK_THINKFIRST(sv); 4702 if (delta > max_delta) 4703 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p", 4704 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv), 4705 SvPVX_const(sv) + max_delta); 4706 4707 if (!SvOOK(sv)) { 4708 if (!SvLEN(sv)) { /* make copy of shared string */ 4709 const char *pvx = SvPVX_const(sv); 4710 const STRLEN len = SvCUR(sv); 4711 SvGROW(sv, len + 1); 4712 Move(pvx,SvPVX(sv),len,char); 4713 *SvEND(sv) = '\0'; 4714 } 4715 SvFLAGS(sv) |= SVf_OOK; 4716 old_delta = 0; 4717 } else { 4718 SvOOK_offset(sv, old_delta); 4719 } 4720 SvLEN_set(sv, SvLEN(sv) - delta); 4721 SvCUR_set(sv, SvCUR(sv) - delta); 4722 SvPV_set(sv, SvPVX(sv) + delta); 4723 4724 p = (U8 *)SvPVX_const(sv); 4725 4726 delta += old_delta; 4727 4728 #ifdef DEBUGGING 4729 real_start = p - delta; 4730 #endif 4731 4732 assert(delta); 4733 if (delta < 0x100) { 4734 *--p = (U8) delta; 4735 } else { 4736 *--p = 0; 4737 p -= sizeof(STRLEN); 4738 Copy((U8*)&delta, p, sizeof(STRLEN), U8); 4739 } 4740 4741 #ifdef DEBUGGING 4742 /* Fill the preceding buffer with sentinals to verify that no-one is 4743 using it. */ 4744 while (p > real_start) { 4745 --p; 4746 *p = (U8)PTR2UV(p); 4747 } 4748 #endif 4749 } 4750 4751 /* 4752 =for apidoc sv_catpvn 4753 4754 Concatenates the string onto the end of the string which is in the SV. The 4755 C<len> indicates number of bytes to copy. If the SV has the UTF-8 4756 status set, then the bytes appended should be valid UTF-8. 4757 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>. 4758 4759 =for apidoc sv_catpvn_flags 4760 4761 Concatenates the string onto the end of the string which is in the SV. The 4762 C<len> indicates number of bytes to copy. If the SV has the UTF-8 4763 status set, then the bytes appended should be valid UTF-8. 4764 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if 4765 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented 4766 in terms of this function. 4767 4768 =cut 4769 */ 4770 4771 void 4772 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags) 4773 { 4774 dVAR; 4775 STRLEN dlen; 4776 const char * const dstr = SvPV_force_flags(dsv, dlen, flags); 4777 4778 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS; 4779 4780 SvGROW(dsv, dlen + slen + 1); 4781 if (sstr == dstr) 4782 sstr = SvPVX_const(dsv); 4783 Move(sstr, SvPVX(dsv) + dlen, slen, char); 4784 SvCUR_set(dsv, SvCUR(dsv) + slen); 4785 *SvEND(dsv) = '\0'; 4786 (void)SvPOK_only_UTF8(dsv); /* validate pointer */ 4787 SvTAINT(dsv); 4788 if (flags & SV_SMAGIC) 4789 SvSETMAGIC(dsv); 4790 } 4791 4792 /* 4793 =for apidoc sv_catsv 4794 4795 Concatenates the string from SV C<ssv> onto the end of the string in 4796 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but 4797 not 'set' magic. See C<sv_catsv_mg>. 4798 4799 =for apidoc sv_catsv_flags 4800 4801 Concatenates the string from SV C<ssv> onto the end of the string in 4802 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC> 4803 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv> 4804 and C<sv_catsv_nomg> are implemented in terms of this function. 4805 4806 =cut */ 4807 4808 void 4809 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags) 4810 { 4811 dVAR; 4812 4813 PERL_ARGS_ASSERT_SV_CATSV_FLAGS; 4814 4815 if (ssv) { 4816 STRLEN slen; 4817 const char *spv = SvPV_const(ssv, slen); 4818 if (spv) { 4819 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, 4820 gcc version 2.95.2 20000220 (Debian GNU/Linux) for 4821 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously 4822 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though 4823 dsv->sv_flags doesn't have that bit set. 4824 Andy Dougherty 12 Oct 2001 4825 */ 4826 const I32 sutf8 = DO_UTF8(ssv); 4827 I32 dutf8; 4828 4829 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) 4830 mg_get(dsv); 4831 dutf8 = DO_UTF8(dsv); 4832 4833 if (dutf8 != sutf8) { 4834 if (dutf8) { 4835 /* Not modifying source SV, so taking a temporary copy. */ 4836 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP); 4837 4838 sv_utf8_upgrade(csv); 4839 spv = SvPV_const(csv, slen); 4840 } 4841 else 4842 /* Leave enough space for the cat that's about to happen */ 4843 sv_utf8_upgrade_flags_grow(dsv, 0, slen); 4844 } 4845 sv_catpvn_nomg(dsv, spv, slen); 4846 } 4847 } 4848 if (flags & SV_SMAGIC) 4849 SvSETMAGIC(dsv); 4850 } 4851 4852 /* 4853 =for apidoc sv_catpv 4854 4855 Concatenates the string onto the end of the string which is in the SV. 4856 If the SV has the UTF-8 status set, then the bytes appended should be 4857 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>. 4858 4859 =cut */ 4860 4861 void 4862 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr) 4863 { 4864 dVAR; 4865 register STRLEN len; 4866 STRLEN tlen; 4867 char *junk; 4868 4869 PERL_ARGS_ASSERT_SV_CATPV; 4870 4871 if (!ptr) 4872 return; 4873 junk = SvPV_force(sv, tlen); 4874 len = strlen(ptr); 4875 SvGROW(sv, tlen + len + 1); 4876 if (ptr == junk) 4877 ptr = SvPVX_const(sv); 4878 Move(ptr,SvPVX(sv)+tlen,len+1,char); 4879 SvCUR_set(sv, SvCUR(sv) + len); 4880 (void)SvPOK_only_UTF8(sv); /* validate pointer */ 4881 SvTAINT(sv); 4882 } 4883 4884 /* 4885 =for apidoc sv_catpv_mg 4886 4887 Like C<sv_catpv>, but also handles 'set' magic. 4888 4889 =cut 4890 */ 4891 4892 void 4893 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr) 4894 { 4895 PERL_ARGS_ASSERT_SV_CATPV_MG; 4896 4897 sv_catpv(sv,ptr); 4898 SvSETMAGIC(sv); 4899 } 4900 4901 /* 4902 =for apidoc newSV 4903 4904 Creates a new SV. A non-zero C<len> parameter indicates the number of 4905 bytes of preallocated string space the SV should have. An extra byte for a 4906 trailing NUL is also reserved. (SvPOK is not set for the SV even if string 4907 space is allocated.) The reference count for the new SV is set to 1. 4908 4909 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first 4910 parameter, I<x>, a debug aid which allowed callers to identify themselves. 4911 This aid has been superseded by a new build option, PERL_MEM_LOG (see 4912 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS 4913 modules supporting older perls. 4914 4915 =cut 4916 */ 4917 4918 SV * 4919 Perl_newSV(pTHX_ const STRLEN len) 4920 { 4921 dVAR; 4922 register SV *sv; 4923 4924 new_SV(sv); 4925 if (len) { 4926 sv_upgrade(sv, SVt_PV); 4927 SvGROW(sv, len + 1); 4928 } 4929 return sv; 4930 } 4931 /* 4932 =for apidoc sv_magicext 4933 4934 Adds magic to an SV, upgrading it if necessary. Applies the 4935 supplied vtable and returns a pointer to the magic added. 4936 4937 Note that C<sv_magicext> will allow things that C<sv_magic> will not. 4938 In particular, you can add magic to SvREADONLY SVs, and add more than 4939 one instance of the same 'how'. 4940 4941 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is 4942 stored, if C<namlen> is zero then C<name> is stored as-is and - as another 4943 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed 4944 to contain an C<SV*> and is stored as-is with its REFCNT incremented. 4945 4946 (This is now used as a subroutine by C<sv_magic>.) 4947 4948 =cut 4949 */ 4950 MAGIC * 4951 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 4952 const MGVTBL *const vtable, const char *const name, const I32 namlen) 4953 { 4954 dVAR; 4955 MAGIC* mg; 4956 4957 PERL_ARGS_ASSERT_SV_MAGICEXT; 4958 4959 SvUPGRADE(sv, SVt_PVMG); 4960 Newxz(mg, 1, MAGIC); 4961 mg->mg_moremagic = SvMAGIC(sv); 4962 SvMAGIC_set(sv, mg); 4963 4964 /* Sometimes a magic contains a reference loop, where the sv and 4965 object refer to each other. To prevent a reference loop that 4966 would prevent such objects being freed, we look for such loops 4967 and if we find one we avoid incrementing the object refcount. 4968 4969 Note we cannot do this to avoid self-tie loops as intervening RV must 4970 have its REFCNT incremented to keep it in existence. 4971 4972 */ 4973 if (!obj || obj == sv || 4974 how == PERL_MAGIC_arylen || 4975 how == PERL_MAGIC_symtab || 4976 (SvTYPE(obj) == SVt_PVGV && 4977 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv 4978 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv 4979 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) 4980 { 4981 mg->mg_obj = obj; 4982 } 4983 else { 4984 mg->mg_obj = SvREFCNT_inc_simple(obj); 4985 mg->mg_flags |= MGf_REFCOUNTED; 4986 } 4987 4988 /* Normal self-ties simply pass a null object, and instead of 4989 using mg_obj directly, use the SvTIED_obj macro to produce a 4990 new RV as needed. For glob "self-ties", we are tieing the PVIO 4991 with an RV obj pointing to the glob containing the PVIO. In 4992 this case, to avoid a reference loop, we need to weaken the 4993 reference. 4994 */ 4995 4996 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && 4997 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv) 4998 { 4999 sv_rvweaken(obj); 5000 } 5001 5002 mg->mg_type = how; 5003 mg->mg_len = namlen; 5004 if (name) { 5005 if (namlen > 0) 5006 mg->mg_ptr = savepvn(name, namlen); 5007 else if (namlen == HEf_SVKEY) { 5008 /* Yes, this is casting away const. This is only for the case of 5009 HEf_SVKEY. I think we need to document this abberation of the 5010 constness of the API, rather than making name non-const, as 5011 that change propagating outwards a long way. */ 5012 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); 5013 } else 5014 mg->mg_ptr = (char *) name; 5015 } 5016 mg->mg_virtual = (MGVTBL *) vtable; 5017 5018 mg_magical(sv); 5019 if (SvGMAGICAL(sv)) 5020 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); 5021 return mg; 5022 } 5023 5024 /* 5025 =for apidoc sv_magic 5026 5027 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary, 5028 then adds a new magic item of type C<how> to the head of the magic list. 5029 5030 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the 5031 handling of the C<name> and C<namlen> arguments. 5032 5033 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also 5034 to add more than one instance of the same 'how'. 5035 5036 =cut 5037 */ 5038 5039 void 5040 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, 5041 const char *const name, const I32 namlen) 5042 { 5043 dVAR; 5044 const MGVTBL *vtable; 5045 MAGIC* mg; 5046 5047 PERL_ARGS_ASSERT_SV_MAGIC; 5048 5049 #ifdef PERL_OLD_COPY_ON_WRITE 5050 if (SvIsCOW(sv)) 5051 sv_force_normal_flags(sv, 0); 5052 #endif 5053 if (SvREADONLY(sv)) { 5054 if ( 5055 /* its okay to attach magic to shared strings; the subsequent 5056 * upgrade to PVMG will unshare the string */ 5057 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG) 5058 5059 && IN_PERL_RUNTIME 5060 && how != PERL_MAGIC_regex_global 5061 && how != PERL_MAGIC_bm 5062 && how != PERL_MAGIC_fm 5063 && how != PERL_MAGIC_sv 5064 && how != PERL_MAGIC_backref 5065 ) 5066 { 5067 Perl_croak(aTHX_ "%s", PL_no_modify); 5068 } 5069 } 5070 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { 5071 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { 5072 /* sv_magic() refuses to add a magic of the same 'how' as an 5073 existing one 5074 */ 5075 if (how == PERL_MAGIC_taint) { 5076 mg->mg_len |= 1; 5077 /* Any scalar which already had taint magic on which someone 5078 (erroneously?) did SvIOK_on() or similar will now be 5079 incorrectly sporting public "OK" flags. */ 5080 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); 5081 } 5082 return; 5083 } 5084 } 5085 5086 switch (how) { 5087 case PERL_MAGIC_sv: 5088 vtable = &PL_vtbl_sv; 5089 break; 5090 case PERL_MAGIC_overload: 5091 vtable = &PL_vtbl_amagic; 5092 break; 5093 case PERL_MAGIC_overload_elem: 5094 vtable = &PL_vtbl_amagicelem; 5095 break; 5096 case PERL_MAGIC_overload_table: 5097 vtable = &PL_vtbl_ovrld; 5098 break; 5099 case PERL_MAGIC_bm: 5100 vtable = &PL_vtbl_bm; 5101 break; 5102 case PERL_MAGIC_regdata: 5103 vtable = &PL_vtbl_regdata; 5104 break; 5105 case PERL_MAGIC_regdatum: 5106 vtable = &PL_vtbl_regdatum; 5107 break; 5108 case PERL_MAGIC_env: 5109 vtable = &PL_vtbl_env; 5110 break; 5111 case PERL_MAGIC_fm: 5112 vtable = &PL_vtbl_fm; 5113 break; 5114 case PERL_MAGIC_envelem: 5115 vtable = &PL_vtbl_envelem; 5116 break; 5117 case PERL_MAGIC_regex_global: 5118 vtable = &PL_vtbl_mglob; 5119 break; 5120 case PERL_MAGIC_isa: 5121 vtable = &PL_vtbl_isa; 5122 break; 5123 case PERL_MAGIC_isaelem: 5124 vtable = &PL_vtbl_isaelem; 5125 break; 5126 case PERL_MAGIC_nkeys: 5127 vtable = &PL_vtbl_nkeys; 5128 break; 5129 case PERL_MAGIC_dbfile: 5130 vtable = NULL; 5131 break; 5132 case PERL_MAGIC_dbline: 5133 vtable = &PL_vtbl_dbline; 5134 break; 5135 #ifdef USE_LOCALE_COLLATE 5136 case PERL_MAGIC_collxfrm: 5137 vtable = &PL_vtbl_collxfrm; 5138 break; 5139 #endif /* USE_LOCALE_COLLATE */ 5140 case PERL_MAGIC_tied: 5141 vtable = &PL_vtbl_pack; 5142 break; 5143 case PERL_MAGIC_tiedelem: 5144 case PERL_MAGIC_tiedscalar: 5145 vtable = &PL_vtbl_packelem; 5146 break; 5147 case PERL_MAGIC_qr: 5148 vtable = &PL_vtbl_regexp; 5149 break; 5150 case PERL_MAGIC_sig: 5151 vtable = &PL_vtbl_sig; 5152 break; 5153 case PERL_MAGIC_sigelem: 5154 vtable = &PL_vtbl_sigelem; 5155 break; 5156 case PERL_MAGIC_taint: 5157 vtable = &PL_vtbl_taint; 5158 break; 5159 case PERL_MAGIC_uvar: 5160 vtable = &PL_vtbl_uvar; 5161 break; 5162 case PERL_MAGIC_vec: 5163 vtable = &PL_vtbl_vec; 5164 break; 5165 case PERL_MAGIC_arylen_p: 5166 case PERL_MAGIC_rhash: 5167 case PERL_MAGIC_symtab: 5168 case PERL_MAGIC_vstring: 5169 vtable = NULL; 5170 break; 5171 case PERL_MAGIC_utf8: 5172 vtable = &PL_vtbl_utf8; 5173 break; 5174 case PERL_MAGIC_substr: 5175 vtable = &PL_vtbl_substr; 5176 break; 5177 case PERL_MAGIC_defelem: 5178 vtable = &PL_vtbl_defelem; 5179 break; 5180 case PERL_MAGIC_arylen: 5181 vtable = &PL_vtbl_arylen; 5182 break; 5183 case PERL_MAGIC_pos: 5184 vtable = &PL_vtbl_pos; 5185 break; 5186 case PERL_MAGIC_backref: 5187 vtable = &PL_vtbl_backref; 5188 break; 5189 case PERL_MAGIC_hintselem: 5190 vtable = &PL_vtbl_hintselem; 5191 break; 5192 case PERL_MAGIC_hints: 5193 vtable = &PL_vtbl_hints; 5194 break; 5195 case PERL_MAGIC_ext: 5196 /* Reserved for use by extensions not perl internals. */ 5197 /* Useful for attaching extension internal data to perl vars. */ 5198 /* Note that multiple extensions may clash if magical scalars */ 5199 /* etc holding private data from one are passed to another. */ 5200 vtable = NULL; 5201 break; 5202 default: 5203 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); 5204 } 5205 5206 /* Rest of work is done else where */ 5207 mg = sv_magicext(sv,obj,how,vtable,name,namlen); 5208 5209 switch (how) { 5210 case PERL_MAGIC_taint: 5211 mg->mg_len = 1; 5212 break; 5213 case PERL_MAGIC_ext: 5214 case PERL_MAGIC_dbfile: 5215 SvRMAGICAL_on(sv); 5216 break; 5217 } 5218 } 5219 5220 /* 5221 =for apidoc sv_unmagic 5222 5223 Removes all magic of type C<type> from an SV. 5224 5225 =cut 5226 */ 5227 5228 int 5229 Perl_sv_unmagic(pTHX_ SV *const sv, const int type) 5230 { 5231 MAGIC* mg; 5232 MAGIC** mgp; 5233 5234 PERL_ARGS_ASSERT_SV_UNMAGIC; 5235 5236 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) 5237 return 0; 5238 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); 5239 for (mg = *mgp; mg; mg = *mgp) { 5240 if (mg->mg_type == type) { 5241 const MGVTBL* const vtbl = mg->mg_virtual; 5242 *mgp = mg->mg_moremagic; 5243 if (vtbl && vtbl->svt_free) 5244 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); 5245 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 5246 if (mg->mg_len > 0) 5247 Safefree(mg->mg_ptr); 5248 else if (mg->mg_len == HEf_SVKEY) 5249 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); 5250 else if (mg->mg_type == PERL_MAGIC_utf8) 5251 Safefree(mg->mg_ptr); 5252 } 5253 if (mg->mg_flags & MGf_REFCOUNTED) 5254 SvREFCNT_dec(mg->mg_obj); 5255 Safefree(mg); 5256 } 5257 else 5258 mgp = &mg->mg_moremagic; 5259 } 5260 if (SvMAGIC(sv)) { 5261 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ 5262 mg_magical(sv); /* else fix the flags now */ 5263 } 5264 else { 5265 SvMAGICAL_off(sv); 5266 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 5267 } 5268 return 0; 5269 } 5270 5271 /* 5272 =for apidoc sv_rvweaken 5273 5274 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the 5275 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and 5276 push a back-reference to this RV onto the array of backreferences 5277 associated with that magic. If the RV is magical, set magic will be 5278 called after the RV is cleared. 5279 5280 =cut 5281 */ 5282 5283 SV * 5284 Perl_sv_rvweaken(pTHX_ SV *const sv) 5285 { 5286 SV *tsv; 5287 5288 PERL_ARGS_ASSERT_SV_RVWEAKEN; 5289 5290 if (!SvOK(sv)) /* let undefs pass */ 5291 return sv; 5292 if (!SvROK(sv)) 5293 Perl_croak(aTHX_ "Can't weaken a nonreference"); 5294 else if (SvWEAKREF(sv)) { 5295 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); 5296 return sv; 5297 } 5298 tsv = SvRV(sv); 5299 Perl_sv_add_backref(aTHX_ tsv, sv); 5300 SvWEAKREF_on(sv); 5301 SvREFCNT_dec(tsv); 5302 return sv; 5303 } 5304 5305 /* Give tsv backref magic if it hasn't already got it, then push a 5306 * back-reference to sv onto the array associated with the backref magic. 5307 */ 5308 5309 /* A discussion about the backreferences array and its refcount: 5310 * 5311 * The AV holding the backreferences is pointed to either as the mg_obj of 5312 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux 5313 * structure, from the xhv_backreferences field. (A HV without hv_aux will 5314 * have the standard magic instead.) The array is created with a refcount 5315 * of 2. This means that if during global destruction the array gets 5316 * picked on first to have its refcount decremented by the random zapper, 5317 * it won't actually be freed, meaning it's still theere for when its 5318 * parent gets freed. 5319 * When the parent SV is freed, in the case of magic, the magic is freed, 5320 * Perl_magic_killbackrefs is called which decrements one refcount, then 5321 * mg_obj is freed which kills the second count. 5322 * In the vase of a HV being freed, one ref is removed by 5323 * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it 5324 * calls. 5325 */ 5326 5327 void 5328 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) 5329 { 5330 dVAR; 5331 AV *av; 5332 5333 PERL_ARGS_ASSERT_SV_ADD_BACKREF; 5334 5335 if (SvTYPE(tsv) == SVt_PVHV) { 5336 AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); 5337 5338 av = *avp; 5339 if (!av) { 5340 /* There is no AV in the offical place - try a fixup. */ 5341 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref); 5342 5343 if (mg) { 5344 /* Aha. They've got it stowed in magic. Bring it back. */ 5345 av = MUTABLE_AV(mg->mg_obj); 5346 /* Stop mg_free decreasing the refernce count. */ 5347 mg->mg_obj = NULL; 5348 /* Stop mg_free even calling the destructor, given that 5349 there's no AV to free up. */ 5350 mg->mg_virtual = 0; 5351 sv_unmagic(tsv, PERL_MAGIC_backref); 5352 } else { 5353 av = newAV(); 5354 AvREAL_off(av); 5355 SvREFCNT_inc_simple_void(av); /* see discussion above */ 5356 } 5357 *avp = av; 5358 } 5359 } else { 5360 const MAGIC *const mg 5361 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; 5362 if (mg) 5363 av = MUTABLE_AV(mg->mg_obj); 5364 else { 5365 av = newAV(); 5366 AvREAL_off(av); 5367 sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0); 5368 /* av now has a refcnt of 2; see discussion above */ 5369 } 5370 } 5371 if (AvFILLp(av) >= AvMAX(av)) { 5372 av_extend(av, AvFILLp(av)+1); 5373 } 5374 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ 5375 } 5376 5377 /* delete a back-reference to ourselves from the backref magic associated 5378 * with the SV we point to. 5379 */ 5380 5381 STATIC void 5382 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) 5383 { 5384 dVAR; 5385 AV *av = NULL; 5386 SV **svp; 5387 I32 i; 5388 5389 PERL_ARGS_ASSERT_SV_DEL_BACKREF; 5390 5391 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) { 5392 av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); 5393 /* We mustn't attempt to "fix up" the hash here by moving the 5394 backreference array back to the hv_aux structure, as that is stored 5395 in the main HvARRAY(), and hfreentries assumes that no-one 5396 reallocates HvARRAY() while it is running. */ 5397 } 5398 if (!av) { 5399 const MAGIC *const mg 5400 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; 5401 if (mg) 5402 av = MUTABLE_AV(mg->mg_obj); 5403 } 5404 5405 if (!av) 5406 Perl_croak(aTHX_ "panic: del_backref"); 5407 5408 assert(!SvIS_FREED(av)); 5409 5410 svp = AvARRAY(av); 5411 /* We shouldn't be in here more than once, but for paranoia reasons lets 5412 not assume this. */ 5413 for (i = AvFILLp(av); i >= 0; i--) { 5414 if (svp[i] == sv) { 5415 const SSize_t fill = AvFILLp(av); 5416 if (i != fill) { 5417 /* We weren't the last entry. 5418 An unordered list has this property that you can take the 5419 last element off the end to fill the hole, and it's still 5420 an unordered list :-) 5421 */ 5422 svp[i] = svp[fill]; 5423 } 5424 svp[fill] = NULL; 5425 AvFILLp(av) = fill - 1; 5426 } 5427 } 5428 } 5429 5430 int 5431 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) 5432 { 5433 SV **svp = AvARRAY(av); 5434 5435 PERL_ARGS_ASSERT_SV_KILL_BACKREFS; 5436 PERL_UNUSED_ARG(sv); 5437 5438 assert(!svp || !SvIS_FREED(av)); 5439 if (svp) { 5440 SV *const *const last = svp + AvFILLp(av); 5441 5442 while (svp <= last) { 5443 if (*svp) { 5444 SV *const referrer = *svp; 5445 if (SvWEAKREF(referrer)) { 5446 /* XXX Should we check that it hasn't changed? */ 5447 SvRV_set(referrer, 0); 5448 SvOK_off(referrer); 5449 SvWEAKREF_off(referrer); 5450 SvSETMAGIC(referrer); 5451 } else if (SvTYPE(referrer) == SVt_PVGV || 5452 SvTYPE(referrer) == SVt_PVLV) { 5453 /* You lookin' at me? */ 5454 assert(GvSTASH(referrer)); 5455 assert(GvSTASH(referrer) == (const HV *)sv); 5456 GvSTASH(referrer) = 0; 5457 } else { 5458 Perl_croak(aTHX_ 5459 "panic: magic_killbackrefs (flags=%"UVxf")", 5460 (UV)SvFLAGS(referrer)); 5461 } 5462 5463 *svp = NULL; 5464 } 5465 svp++; 5466 } 5467 } 5468 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ 5469 return 0; 5470 } 5471 5472 /* 5473 =for apidoc sv_insert 5474 5475 Inserts a string at the specified offset/length within the SV. Similar to 5476 the Perl substr() function. Handles get magic. 5477 5478 =for apidoc sv_insert_flags 5479 5480 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>. 5481 5482 =cut 5483 */ 5484 5485 void 5486 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) 5487 { 5488 dVAR; 5489 register char *big; 5490 register char *mid; 5491 register char *midend; 5492 register char *bigend; 5493 register I32 i; 5494 STRLEN curlen; 5495 5496 PERL_ARGS_ASSERT_SV_INSERT_FLAGS; 5497 5498 if (!bigstr) 5499 Perl_croak(aTHX_ "Can't modify non-existent substring"); 5500 SvPV_force_flags(bigstr, curlen, flags); 5501 (void)SvPOK_only_UTF8(bigstr); 5502 if (offset + len > curlen) { 5503 SvGROW(bigstr, offset+len+1); 5504 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); 5505 SvCUR_set(bigstr, offset+len); 5506 } 5507 5508 SvTAINT(bigstr); 5509 i = littlelen - len; 5510 if (i > 0) { /* string might grow */ 5511 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); 5512 mid = big + offset + len; 5513 midend = bigend = big + SvCUR(bigstr); 5514 bigend += i; 5515 *bigend = '\0'; 5516 while (midend > mid) /* shove everything down */ 5517 *--bigend = *--midend; 5518 Move(little,big+offset,littlelen,char); 5519 SvCUR_set(bigstr, SvCUR(bigstr) + i); 5520 SvSETMAGIC(bigstr); 5521 return; 5522 } 5523 else if (i == 0) { 5524 Move(little,SvPVX(bigstr)+offset,len,char); 5525 SvSETMAGIC(bigstr); 5526 return; 5527 } 5528 5529 big = SvPVX(bigstr); 5530 mid = big + offset; 5531 midend = mid + len; 5532 bigend = big + SvCUR(bigstr); 5533 5534 if (midend > bigend) 5535 Perl_croak(aTHX_ "panic: sv_insert"); 5536 5537 if (mid - big > bigend - midend) { /* faster to shorten from end */ 5538 if (littlelen) { 5539 Move(little, mid, littlelen,char); 5540 mid += littlelen; 5541 } 5542 i = bigend - midend; 5543 if (i > 0) { 5544 Move(midend, mid, i,char); 5545 mid += i; 5546 } 5547 *mid = '\0'; 5548 SvCUR_set(bigstr, mid - big); 5549 } 5550 else if ((i = mid - big)) { /* faster from front */ 5551 midend -= littlelen; 5552 mid = midend; 5553 Move(big, midend - i, i, char); 5554 sv_chop(bigstr,midend-i); 5555 if (littlelen) 5556 Move(little, mid, littlelen,char); 5557 } 5558 else if (littlelen) { 5559 midend -= littlelen; 5560 sv_chop(bigstr,midend); 5561 Move(little,midend,littlelen,char); 5562 } 5563 else { 5564 sv_chop(bigstr,midend); 5565 } 5566 SvSETMAGIC(bigstr); 5567 } 5568 5569 /* 5570 =for apidoc sv_replace 5571 5572 Make the first argument a copy of the second, then delete the original. 5573 The target SV physically takes over ownership of the body of the source SV 5574 and inherits its flags; however, the target keeps any magic it owns, 5575 and any magic in the source is discarded. 5576 Note that this is a rather specialist SV copying operation; most of the 5577 time you'll want to use C<sv_setsv> or one of its many macro front-ends. 5578 5579 =cut 5580 */ 5581 5582 void 5583 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv) 5584 { 5585 dVAR; 5586 const U32 refcnt = SvREFCNT(sv); 5587 5588 PERL_ARGS_ASSERT_SV_REPLACE; 5589 5590 SV_CHECK_THINKFIRST_COW_DROP(sv); 5591 if (SvREFCNT(nsv) != 1) { 5592 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" 5593 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); 5594 } 5595 if (SvMAGICAL(sv)) { 5596 if (SvMAGICAL(nsv)) 5597 mg_free(nsv); 5598 else 5599 sv_upgrade(nsv, SVt_PVMG); 5600 SvMAGIC_set(nsv, SvMAGIC(sv)); 5601 SvFLAGS(nsv) |= SvMAGICAL(sv); 5602 SvMAGICAL_off(sv); 5603 SvMAGIC_set(sv, NULL); 5604 } 5605 SvREFCNT(sv) = 0; 5606 sv_clear(sv); 5607 assert(!SvREFCNT(sv)); 5608 #ifdef DEBUG_LEAKING_SCALARS 5609 sv->sv_flags = nsv->sv_flags; 5610 sv->sv_any = nsv->sv_any; 5611 sv->sv_refcnt = nsv->sv_refcnt; 5612 sv->sv_u = nsv->sv_u; 5613 #else 5614 StructCopy(nsv,sv,SV); 5615 #endif 5616 if(SvTYPE(sv) == SVt_IV) { 5617 SvANY(sv) 5618 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 5619 } 5620 5621 5622 #ifdef PERL_OLD_COPY_ON_WRITE 5623 if (SvIsCOW_normal(nsv)) { 5624 /* We need to follow the pointers around the loop to make the 5625 previous SV point to sv, rather than nsv. */ 5626 SV *next; 5627 SV *current = nsv; 5628 while ((next = SV_COW_NEXT_SV(current)) != nsv) { 5629 assert(next); 5630 current = next; 5631 assert(SvPVX_const(current) == SvPVX_const(nsv)); 5632 } 5633 /* Make the SV before us point to the SV after us. */ 5634 if (DEBUG_C_TEST) { 5635 PerlIO_printf(Perl_debug_log, "previous is\n"); 5636 sv_dump(current); 5637 PerlIO_printf(Perl_debug_log, 5638 "move it from 0x%"UVxf" to 0x%"UVxf"\n", 5639 (UV) SV_COW_NEXT_SV(current), (UV) sv); 5640 } 5641 SV_COW_NEXT_SV_SET(current, sv); 5642 } 5643 #endif 5644 SvREFCNT(sv) = refcnt; 5645 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ 5646 SvREFCNT(nsv) = 0; 5647 del_SV(nsv); 5648 } 5649 5650 /* 5651 =for apidoc sv_clear 5652 5653 Clear an SV: call any destructors, free up any memory used by the body, 5654 and free the body itself. The SV's head is I<not> freed, although 5655 its type is set to all 1's so that it won't inadvertently be assumed 5656 to be live during global destruction etc. 5657 This function should only be called when REFCNT is zero. Most of the time 5658 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>) 5659 instead. 5660 5661 =cut 5662 */ 5663 5664 void 5665 Perl_sv_clear(pTHX_ register SV *const sv) 5666 { 5667 dVAR; 5668 const U32 type = SvTYPE(sv); 5669 const struct body_details *const sv_type_details 5670 = bodies_by_type + type; 5671 HV *stash; 5672 5673 PERL_ARGS_ASSERT_SV_CLEAR; 5674 assert(SvREFCNT(sv) == 0); 5675 assert(SvTYPE(sv) != SVTYPEMASK); 5676 5677 if (type <= SVt_IV) { 5678 /* See the comment in sv.h about the collusion between this early 5679 return and the overloading of the NULL and IV slots in the size 5680 table. */ 5681 if (SvROK(sv)) { 5682 SV * const target = SvRV(sv); 5683 if (SvWEAKREF(sv)) 5684 sv_del_backref(target, sv); 5685 else 5686 SvREFCNT_dec(target); 5687 } 5688 SvFLAGS(sv) &= SVf_BREAK; 5689 SvFLAGS(sv) |= SVTYPEMASK; 5690 return; 5691 } 5692 5693 if (SvOBJECT(sv)) { 5694 if (PL_defstash && /* Still have a symbol table? */ 5695 SvDESTROYABLE(sv)) 5696 { 5697 dSP; 5698 HV* stash; 5699 do { 5700 CV* destructor; 5701 stash = SvSTASH(sv); 5702 destructor = StashHANDLER(stash,DESTROY); 5703 if (destructor 5704 /* A constant subroutine can have no side effects, so 5705 don't bother calling it. */ 5706 && !CvCONST(destructor) 5707 /* Don't bother calling an empty destructor */ 5708 && (CvISXSUB(destructor) 5709 || (CvSTART(destructor) 5710 && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)))) 5711 { 5712 SV* const tmpref = newRV(sv); 5713 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ 5714 ENTER; 5715 PUSHSTACKi(PERLSI_DESTROY); 5716 EXTEND(SP, 2); 5717 PUSHMARK(SP); 5718 PUSHs(tmpref); 5719 PUTBACK; 5720 call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); 5721 5722 5723 POPSTACK; 5724 SPAGAIN; 5725 LEAVE; 5726 if(SvREFCNT(tmpref) < 2) { 5727 /* tmpref is not kept alive! */ 5728 SvREFCNT(sv)--; 5729 SvRV_set(tmpref, NULL); 5730 SvROK_off(tmpref); 5731 } 5732 SvREFCNT_dec(tmpref); 5733 } 5734 } while (SvOBJECT(sv) && SvSTASH(sv) != stash); 5735 5736 5737 if (SvREFCNT(sv)) { 5738 if (PL_in_clean_objs) 5739 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'", 5740 HvNAME_get(stash)); 5741 /* DESTROY gave object new lease on life */ 5742 return; 5743 } 5744 } 5745 5746 if (SvOBJECT(sv)) { 5747 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ 5748 SvOBJECT_off(sv); /* Curse the object. */ 5749 if (type != SVt_PVIO) 5750 --PL_sv_objcount; /* XXX Might want something more general */ 5751 } 5752 } 5753 if (type >= SVt_PVMG) { 5754 if (type == SVt_PVMG && SvPAD_OUR(sv)) { 5755 SvREFCNT_dec(SvOURSTASH(sv)); 5756 } else if (SvMAGIC(sv)) 5757 mg_free(sv); 5758 if (type == SVt_PVMG && SvPAD_TYPED(sv)) 5759 SvREFCNT_dec(SvSTASH(sv)); 5760 } 5761 switch (type) { 5762 /* case SVt_BIND: */ 5763 case SVt_PVIO: 5764 if (IoIFP(sv) && 5765 IoIFP(sv) != PerlIO_stdin() && 5766 IoIFP(sv) != PerlIO_stdout() && 5767 IoIFP(sv) != PerlIO_stderr()) 5768 { 5769 io_close(MUTABLE_IO(sv), FALSE); 5770 } 5771 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) 5772 PerlDir_close(IoDIRP(sv)); 5773 IoDIRP(sv) = (DIR*)NULL; 5774 Safefree(IoTOP_NAME(sv)); 5775 Safefree(IoFMT_NAME(sv)); 5776 Safefree(IoBOTTOM_NAME(sv)); 5777 goto freescalar; 5778 case SVt_REGEXP: 5779 /* FIXME for plugins */ 5780 pregfree2((REGEXP*) sv); 5781 goto freescalar; 5782 case SVt_PVCV: 5783 case SVt_PVFM: 5784 cv_undef(MUTABLE_CV(sv)); 5785 goto freescalar; 5786 case SVt_PVHV: 5787 if (PL_last_swash_hv == (const HV *)sv) { 5788 PL_last_swash_hv = NULL; 5789 } 5790 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); 5791 hv_undef(MUTABLE_HV(sv)); 5792 break; 5793 case SVt_PVAV: 5794 if (PL_comppad == MUTABLE_AV(sv)) { 5795 PL_comppad = NULL; 5796 PL_curpad = NULL; 5797 } 5798 av_undef(MUTABLE_AV(sv)); 5799 break; 5800 case SVt_PVLV: 5801 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ 5802 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); 5803 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; 5804 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); 5805 } 5806 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ 5807 SvREFCNT_dec(LvTARG(sv)); 5808 case SVt_PVGV: 5809 if (isGV_with_GP(sv)) { 5810 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) 5811 && HvNAME_get(stash)) 5812 mro_method_changed_in(stash); 5813 gp_free(MUTABLE_GV(sv)); 5814 if (GvNAME_HEK(sv)) 5815 unshare_hek(GvNAME_HEK(sv)); 5816 /* If we're in a stash, we don't own a reference to it. However it does 5817 have a back reference to us, which needs to be cleared. */ 5818 if (!SvVALID(sv) && (stash = GvSTASH(sv))) 5819 sv_del_backref(MUTABLE_SV(stash), sv); 5820 } 5821 /* FIXME. There are probably more unreferenced pointers to SVs in the 5822 interpreter struct that we should check and tidy in a similar 5823 fashion to this: */ 5824 if ((const GV *)sv == PL_last_in_gv) 5825 PL_last_in_gv = NULL; 5826 case SVt_PVMG: 5827 case SVt_PVNV: 5828 case SVt_PVIV: 5829 case SVt_PV: 5830 freescalar: 5831 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ 5832 if (SvOOK(sv)) { 5833 STRLEN offset; 5834 SvOOK_offset(sv, offset); 5835 SvPV_set(sv, SvPVX_mutable(sv) - offset); 5836 /* Don't even bother with turning off the OOK flag. */ 5837 } 5838 if (SvROK(sv)) { 5839 SV * const target = SvRV(sv); 5840 if (SvWEAKREF(sv)) 5841 sv_del_backref(target, sv); 5842 else 5843 SvREFCNT_dec(target); 5844 } 5845 #ifdef PERL_OLD_COPY_ON_WRITE 5846 else if (SvPVX_const(sv)) { 5847 if (SvIsCOW(sv)) { 5848 if (DEBUG_C_TEST) { 5849 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); 5850 sv_dump(sv); 5851 } 5852 if (SvLEN(sv)) { 5853 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); 5854 } else { 5855 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); 5856 } 5857 5858 SvFAKE_off(sv); 5859 } else if (SvLEN(sv)) { 5860 Safefree(SvPVX_const(sv)); 5861 } 5862 } 5863 #else 5864 else if (SvPVX_const(sv) && SvLEN(sv)) 5865 Safefree(SvPVX_mutable(sv)); 5866 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) { 5867 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); 5868 SvFAKE_off(sv); 5869 } 5870 #endif 5871 break; 5872 case SVt_NV: 5873 break; 5874 } 5875 5876 SvFLAGS(sv) &= SVf_BREAK; 5877 SvFLAGS(sv) |= SVTYPEMASK; 5878 5879 if (sv_type_details->arena) { 5880 del_body(((char *)SvANY(sv) + sv_type_details->offset), 5881 &PL_body_roots[type]); 5882 } 5883 else if (sv_type_details->body_size) { 5884 my_safefree(SvANY(sv)); 5885 } 5886 } 5887 5888 /* 5889 =for apidoc sv_newref 5890 5891 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper 5892 instead. 5893 5894 =cut 5895 */ 5896 5897 SV * 5898 Perl_sv_newref(pTHX_ SV *const sv) 5899 { 5900 PERL_UNUSED_CONTEXT; 5901 if (sv) 5902 (SvREFCNT(sv))++; 5903 return sv; 5904 } 5905 5906 /* 5907 =for apidoc sv_free 5908 5909 Decrement an SV's reference count, and if it drops to zero, call 5910 C<sv_clear> to invoke destructors and free up any memory used by 5911 the body; finally, deallocate the SV's head itself. 5912 Normally called via a wrapper macro C<SvREFCNT_dec>. 5913 5914 =cut 5915 */ 5916 5917 void 5918 Perl_sv_free(pTHX_ SV *const sv) 5919 { 5920 dVAR; 5921 if (!sv) 5922 return; 5923 if (SvREFCNT(sv) == 0) { 5924 if (SvFLAGS(sv) & SVf_BREAK) 5925 /* this SV's refcnt has been artificially decremented to 5926 * trigger cleanup */ 5927 return; 5928 if (PL_in_clean_all) /* All is fair */ 5929 return; 5930 if (SvREADONLY(sv) && SvIMMORTAL(sv)) { 5931 /* make sure SvREFCNT(sv)==0 happens very seldom */ 5932 SvREFCNT(sv) = (~(U32)0)/2; 5933 return; 5934 } 5935 if (ckWARN_d(WARN_INTERNAL)) { 5936 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP 5937 Perl_dump_sv_child(aTHX_ sv); 5938 #else 5939 #ifdef DEBUG_LEAKING_SCALARS 5940 sv_dump(sv); 5941 #endif 5942 #ifdef DEBUG_LEAKING_SCALARS_ABORT 5943 if (PL_warnhook == PERL_WARNHOOK_FATAL 5944 || ckDEAD(packWARN(WARN_INTERNAL))) { 5945 /* Don't let Perl_warner cause us to escape our fate: */ 5946 abort(); 5947 } 5948 #endif 5949 /* This may not return: */ 5950 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 5951 "Attempt to free unreferenced scalar: SV 0x%"UVxf 5952 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 5953 #endif 5954 } 5955 #ifdef DEBUG_LEAKING_SCALARS_ABORT 5956 abort(); 5957 #endif 5958 return; 5959 } 5960 if (--(SvREFCNT(sv)) > 0) 5961 return; 5962 Perl_sv_free2(aTHX_ sv); 5963 } 5964 5965 void 5966 Perl_sv_free2(pTHX_ SV *const sv) 5967 { 5968 dVAR; 5969 5970 PERL_ARGS_ASSERT_SV_FREE2; 5971 5972 #ifdef DEBUGGING 5973 if (SvTEMP(sv)) { 5974 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), 5975 "Attempt to free temp prematurely: SV 0x%"UVxf 5976 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); 5977 return; 5978 } 5979 #endif 5980 if (SvREADONLY(sv) && SvIMMORTAL(sv)) { 5981 /* make sure SvREFCNT(sv)==0 happens very seldom */ 5982 SvREFCNT(sv) = (~(U32)0)/2; 5983 return; 5984 } 5985 sv_clear(sv); 5986 if (! SvREFCNT(sv)) 5987 del_SV(sv); 5988 } 5989 5990 /* 5991 =for apidoc sv_len 5992 5993 Returns the length of the string in the SV. Handles magic and type 5994 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot. 5995 5996 =cut 5997 */ 5998 5999 STRLEN 6000 Perl_sv_len(pTHX_ register SV *const sv) 6001 { 6002 STRLEN len; 6003 6004 if (!sv) 6005 return 0; 6006 6007 if (SvGMAGICAL(sv)) 6008 len = mg_length(sv); 6009 else 6010 (void)SvPV_const(sv, len); 6011 return len; 6012 } 6013 6014 /* 6015 =for apidoc sv_len_utf8 6016 6017 Returns the number of characters in the string in an SV, counting wide 6018 UTF-8 bytes as a single character. Handles magic and type coercion. 6019 6020 =cut 6021 */ 6022 6023 /* 6024 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the 6025 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below. 6026 * (Note that the mg_len is not the length of the mg_ptr field. 6027 * This allows the cache to store the character length of the string without 6028 * needing to malloc() extra storage to attach to the mg_ptr.) 6029 * 6030 */ 6031 6032 STRLEN 6033 Perl_sv_len_utf8(pTHX_ register SV *const sv) 6034 { 6035 if (!sv) 6036 return 0; 6037 6038 if (SvGMAGICAL(sv)) 6039 return mg_length(sv); 6040 else 6041 { 6042 STRLEN len; 6043 const U8 *s = (U8*)SvPV_const(sv, len); 6044 6045 if (PL_utf8cache) { 6046 STRLEN ulen; 6047 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 6048 6049 if (mg && mg->mg_len != -1) { 6050 ulen = mg->mg_len; 6051 if (PL_utf8cache < 0) { 6052 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); 6053 if (real != ulen) { 6054 /* Need to turn the assertions off otherwise we may 6055 recurse infinitely while printing error messages. 6056 */ 6057 SAVEI8(PL_utf8cache); 6058 PL_utf8cache = 0; 6059 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf 6060 " real %"UVuf" for %"SVf, 6061 (UV) ulen, (UV) real, SVfARG(sv)); 6062 } 6063 } 6064 } 6065 else { 6066 ulen = Perl_utf8_length(aTHX_ s, s + len); 6067 if (!SvREADONLY(sv)) { 6068 if (!mg && (SvTYPE(sv) < SVt_PVMG || 6069 !(mg = mg_find(sv, PERL_MAGIC_utf8)))) { 6070 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8, 6071 &PL_vtbl_utf8, 0, 0); 6072 } 6073 assert(mg); 6074 mg->mg_len = ulen; 6075 /* For now, treat "overflowed" as "still unknown". 6076 See RT #72924. */ 6077 if (ulen != (STRLEN) mg->mg_len) 6078 mg->mg_len = -1; 6079 } 6080 } 6081 return ulen; 6082 } 6083 return Perl_utf8_length(aTHX_ s, s + len); 6084 } 6085 } 6086 6087 /* Walk forwards to find the byte corresponding to the passed in UTF-8 6088 offset. */ 6089 static STRLEN 6090 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, 6091 STRLEN uoffset) 6092 { 6093 const U8 *s = start; 6094 6095 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS; 6096 6097 while (s < send && uoffset--) 6098 s += UTF8SKIP(s); 6099 if (s > send) { 6100 /* This is the existing behaviour. Possibly it should be a croak, as 6101 it's actually a bounds error */ 6102 s = send; 6103 } 6104 return s - start; 6105 } 6106 6107 /* Given the length of the string in both bytes and UTF-8 characters, decide 6108 whether to walk forwards or backwards to find the byte corresponding to 6109 the passed in UTF-8 offset. */ 6110 static STRLEN 6111 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, 6112 const STRLEN uoffset, const STRLEN uend) 6113 { 6114 STRLEN backw = uend - uoffset; 6115 6116 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY; 6117 6118 if (uoffset < 2 * backw) { 6119 /* The assumption is that going forwards is twice the speed of going 6120 forward (that's where the 2 * backw comes from). 6121 (The real figure of course depends on the UTF-8 data.) */ 6122 return sv_pos_u2b_forwards(start, send, uoffset); 6123 } 6124 6125 while (backw--) { 6126 send--; 6127 while (UTF8_IS_CONTINUATION(*send)) 6128 send--; 6129 } 6130 return send - start; 6131 } 6132 6133 /* For the string representation of the given scalar, find the byte 6134 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0 6135 give another position in the string, *before* the sought offset, which 6136 (which is always true, as 0, 0 is a valid pair of positions), which should 6137 help reduce the amount of linear searching. 6138 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which 6139 will be used to reduce the amount of linear searching. The cache will be 6140 created if necessary, and the found value offered to it for update. */ 6141 static STRLEN 6142 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, 6143 const U8 *const send, const STRLEN uoffset, 6144 STRLEN uoffset0, STRLEN boffset0) 6145 { 6146 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ 6147 bool found = FALSE; 6148 6149 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED; 6150 6151 assert (uoffset >= uoffset0); 6152 6153 if (!SvREADONLY(sv) 6154 && PL_utf8cache 6155 && (*mgp || (SvTYPE(sv) >= SVt_PVMG && 6156 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { 6157 if ((*mgp)->mg_ptr) { 6158 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; 6159 if (cache[0] == uoffset) { 6160 /* An exact match. */ 6161 return cache[1]; 6162 } 6163 if (cache[2] == uoffset) { 6164 /* An exact match. */ 6165 return cache[3]; 6166 } 6167 6168 if (cache[0] < uoffset) { 6169 /* The cache already knows part of the way. */ 6170 if (cache[0] > uoffset0) { 6171 /* The cache knows more than the passed in pair */ 6172 uoffset0 = cache[0]; 6173 boffset0 = cache[1]; 6174 } 6175 if ((*mgp)->mg_len != -1) { 6176 /* And we know the end too. */ 6177 boffset = boffset0 6178 + sv_pos_u2b_midway(start + boffset0, send, 6179 uoffset - uoffset0, 6180 (*mgp)->mg_len - uoffset0); 6181 } else { 6182 boffset = boffset0 6183 + sv_pos_u2b_forwards(start + boffset0, 6184 send, uoffset - uoffset0); 6185 } 6186 } 6187 else if (cache[2] < uoffset) { 6188 /* We're between the two cache entries. */ 6189 if (cache[2] > uoffset0) { 6190 /* and the cache knows more than the passed in pair */ 6191 uoffset0 = cache[2]; 6192 boffset0 = cache[3]; 6193 } 6194 6195 boffset = boffset0 6196 + sv_pos_u2b_midway(start + boffset0, 6197 start + cache[1], 6198 uoffset - uoffset0, 6199 cache[0] - uoffset0); 6200 } else { 6201 boffset = boffset0 6202 + sv_pos_u2b_midway(start + boffset0, 6203 start + cache[3], 6204 uoffset - uoffset0, 6205 cache[2] - uoffset0); 6206 } 6207 found = TRUE; 6208 } 6209 else if ((*mgp)->mg_len != -1) { 6210 /* If we can take advantage of a passed in offset, do so. */ 6211 /* In fact, offset0 is either 0, or less than offset, so don't 6212 need to worry about the other possibility. */ 6213 boffset = boffset0 6214 + sv_pos_u2b_midway(start + boffset0, send, 6215 uoffset - uoffset0, 6216 (*mgp)->mg_len - uoffset0); 6217 found = TRUE; 6218 } 6219 } 6220 6221 if (!found || PL_utf8cache < 0) { 6222 const STRLEN real_boffset 6223 = boffset0 + sv_pos_u2b_forwards(start + boffset0, 6224 send, uoffset - uoffset0); 6225 6226 if (found && PL_utf8cache < 0) { 6227 if (real_boffset != boffset) { 6228 /* Need to turn the assertions off otherwise we may recurse 6229 infinitely while printing error messages. */ 6230 SAVEI8(PL_utf8cache); 6231 PL_utf8cache = 0; 6232 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf 6233 " real %"UVuf" for %"SVf, 6234 (UV) boffset, (UV) real_boffset, SVfARG(sv)); 6235 } 6236 } 6237 boffset = real_boffset; 6238 } 6239 6240 if (PL_utf8cache) 6241 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); 6242 return boffset; 6243 } 6244 6245 6246 /* 6247 =for apidoc sv_pos_u2b_flags 6248 6249 Converts the value pointed to by offsetp from a count of UTF-8 chars from 6250 the start of the string, to a count of the equivalent number of bytes; if 6251 lenp is non-zero, it does the same to lenp, but this time starting from 6252 the offset, rather than from the start of the string. Handles type coercion. 6253 I<flags> is passed to C<SvPV_flags>, and usually should be 6254 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic. 6255 6256 =cut 6257 */ 6258 6259 /* 6260 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential 6261 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and 6262 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). 6263 * 6264 */ 6265 6266 STRLEN 6267 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, 6268 U32 flags) 6269 { 6270 const U8 *start; 6271 STRLEN len; 6272 STRLEN boffset; 6273 6274 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS; 6275 6276 start = (U8*)SvPV_flags(sv, len, flags); 6277 if (len) { 6278 const U8 * const send = start + len; 6279 MAGIC *mg = NULL; 6280 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); 6281 6282 if (lenp) { 6283 /* Convert the relative offset to absolute. */ 6284 const STRLEN uoffset2 = uoffset + *lenp; 6285 const STRLEN boffset2 6286 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, 6287 uoffset, boffset) - boffset; 6288 6289 *lenp = boffset2; 6290 } 6291 } else { 6292 if (lenp) 6293 *lenp = 0; 6294 boffset = 0; 6295 } 6296 6297 return boffset; 6298 } 6299 6300 /* 6301 =for apidoc sv_pos_u2b 6302 6303 Converts the value pointed to by offsetp from a count of UTF-8 chars from 6304 the start of the string, to a count of the equivalent number of bytes; if 6305 lenp is non-zero, it does the same to lenp, but this time starting from 6306 the offset, rather than from the start of the string. Handles magic and 6307 type coercion. 6308 6309 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer 6310 than 2Gb. 6311 6312 =cut 6313 */ 6314 6315 /* 6316 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential 6317 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and 6318 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). 6319 * 6320 */ 6321 6322 /* This function is subject to size and sign problems */ 6323 6324 void 6325 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) 6326 { 6327 PERL_ARGS_ASSERT_SV_POS_U2B; 6328 6329 if (lenp) { 6330 STRLEN ulen = (STRLEN)*lenp; 6331 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, 6332 SV_GMAGIC|SV_CONST_RETURN); 6333 *lenp = (I32)ulen; 6334 } else { 6335 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, 6336 SV_GMAGIC|SV_CONST_RETURN); 6337 } 6338 } 6339 6340 /* Create and update the UTF8 magic offset cache, with the proffered utf8/ 6341 byte length pairing. The (byte) length of the total SV is passed in too, 6342 as blen, because for some (more esoteric) SVs, the call to SvPV_const() 6343 may not have updated SvCUR, so we can't rely on reading it directly. 6344 6345 The proffered utf8/byte length pairing isn't used if the cache already has 6346 two pairs, and swapping either for the proffered pair would increase the 6347 RMS of the intervals between known byte offsets. 6348 6349 The cache itself consists of 4 STRLEN values 6350 0: larger UTF-8 offset 6351 1: corresponding byte offset 6352 2: smaller UTF-8 offset 6353 3: corresponding byte offset 6354 6355 Unused cache pairs have the value 0, 0. 6356 Keeping the cache "backwards" means that the invariant of 6357 cache[0] >= cache[2] is maintained even with empty slots, which means that 6358 the code that uses it doesn't need to worry if only 1 entry has actually 6359 been set to non-zero. It also makes the "position beyond the end of the 6360 cache" logic much simpler, as the first slot is always the one to start 6361 from. 6362 */ 6363 static void 6364 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte, 6365 const STRLEN utf8, const STRLEN blen) 6366 { 6367 STRLEN *cache; 6368 6369 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE; 6370 6371 if (SvREADONLY(sv)) 6372 return; 6373 6374 if (!*mgp && (SvTYPE(sv) < SVt_PVMG || 6375 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { 6376 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 6377 0); 6378 (*mgp)->mg_len = -1; 6379 } 6380 assert(*mgp); 6381 6382 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) { 6383 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); 6384 (*mgp)->mg_ptr = (char *) cache; 6385 } 6386 assert(cache); 6387 6388 if (PL_utf8cache < 0 && SvPOKp(sv)) { 6389 /* SvPOKp() because it's possible that sv has string overloading, and 6390 therefore is a reference, hence SvPVX() is actually a pointer. 6391 This cures the (very real) symptoms of RT 69422, but I'm not actually 6392 sure whether we should even be caching the results of UTF-8 6393 operations on overloading, given that nothing stops overloading 6394 returning a different value every time it's called. */ 6395 const U8 *start = (const U8 *) SvPVX_const(sv); 6396 const STRLEN realutf8 = utf8_length(start, start + byte); 6397 6398 if (realutf8 != utf8) { 6399 /* Need to turn the assertions off otherwise we may recurse 6400 infinitely while printing error messages. */ 6401 SAVEI8(PL_utf8cache); 6402 PL_utf8cache = 0; 6403 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf 6404 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv)); 6405 } 6406 } 6407 6408 /* Cache is held with the later position first, to simplify the code 6409 that deals with unbounded ends. */ 6410 6411 ASSERT_UTF8_CACHE(cache); 6412 if (cache[1] == 0) { 6413 /* Cache is totally empty */ 6414 cache[0] = utf8; 6415 cache[1] = byte; 6416 } else if (cache[3] == 0) { 6417 if (byte > cache[1]) { 6418 /* New one is larger, so goes first. */ 6419 cache[2] = cache[0]; 6420 cache[3] = cache[1]; 6421 cache[0] = utf8; 6422 cache[1] = byte; 6423 } else { 6424 cache[2] = utf8; 6425 cache[3] = byte; 6426 } 6427 } else { 6428 #define THREEWAY_SQUARE(a,b,c,d) \ 6429 ((float)((d) - (c))) * ((float)((d) - (c))) \ 6430 + ((float)((c) - (b))) * ((float)((c) - (b))) \ 6431 + ((float)((b) - (a))) * ((float)((b) - (a))) 6432 6433 /* Cache has 2 slots in use, and we know three potential pairs. 6434 Keep the two that give the lowest RMS distance. Do the 6435 calcualation in bytes simply because we always know the byte 6436 length. squareroot has the same ordering as the positive value, 6437 so don't bother with the actual square root. */ 6438 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen); 6439 if (byte > cache[1]) { 6440 /* New position is after the existing pair of pairs. */ 6441 const float keep_earlier 6442 = THREEWAY_SQUARE(0, cache[3], byte, blen); 6443 const float keep_later 6444 = THREEWAY_SQUARE(0, cache[1], byte, blen); 6445 6446 if (keep_later < keep_earlier) { 6447 if (keep_later < existing) { 6448 cache[2] = cache[0]; 6449 cache[3] = cache[1]; 6450 cache[0] = utf8; 6451 cache[1] = byte; 6452 } 6453 } 6454 else { 6455 if (keep_earlier < existing) { 6456 cache[0] = utf8; 6457 cache[1] = byte; 6458 } 6459 } 6460 } 6461 else if (byte > cache[3]) { 6462 /* New position is between the existing pair of pairs. */ 6463 const float keep_earlier 6464 = THREEWAY_SQUARE(0, cache[3], byte, blen); 6465 const float keep_later 6466 = THREEWAY_SQUARE(0, byte, cache[1], blen); 6467 6468 if (keep_later < keep_earlier) { 6469 if (keep_later < existing) { 6470 cache[2] = utf8; 6471 cache[3] = byte; 6472 } 6473 } 6474 else { 6475 if (keep_earlier < existing) { 6476 cache[0] = utf8; 6477 cache[1] = byte; 6478 } 6479 } 6480 } 6481 else { 6482 /* New position is before the existing pair of pairs. */ 6483 const float keep_earlier 6484 = THREEWAY_SQUARE(0, byte, cache[3], blen); 6485 const float keep_later 6486 = THREEWAY_SQUARE(0, byte, cache[1], blen); 6487 6488 if (keep_later < keep_earlier) { 6489 if (keep_later < existing) { 6490 cache[2] = utf8; 6491 cache[3] = byte; 6492 } 6493 } 6494 else { 6495 if (keep_earlier < existing) { 6496 cache[0] = cache[2]; 6497 cache[1] = cache[3]; 6498 cache[2] = utf8; 6499 cache[3] = byte; 6500 } 6501 } 6502 } 6503 } 6504 ASSERT_UTF8_CACHE(cache); 6505 } 6506 6507 /* We already know all of the way, now we may be able to walk back. The same 6508 assumption is made as in S_sv_pos_u2b_midway(), namely that walking 6509 backward is half the speed of walking forward. */ 6510 static STRLEN 6511 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, 6512 const U8 *end, STRLEN endu) 6513 { 6514 const STRLEN forw = target - s; 6515 STRLEN backw = end - target; 6516 6517 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY; 6518 6519 if (forw < 2 * backw) { 6520 return utf8_length(s, target); 6521 } 6522 6523 while (end > target) { 6524 end--; 6525 while (UTF8_IS_CONTINUATION(*end)) { 6526 end--; 6527 } 6528 endu--; 6529 } 6530 return endu; 6531 } 6532 6533 /* 6534 =for apidoc sv_pos_b2u 6535 6536 Converts the value pointed to by offsetp from a count of bytes from the 6537 start of the string, to a count of the equivalent number of UTF-8 chars. 6538 Handles magic and type coercion. 6539 6540 =cut 6541 */ 6542 6543 /* 6544 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential 6545 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and 6546 * byte offsets. 6547 * 6548 */ 6549 void 6550 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp) 6551 { 6552 const U8* s; 6553 const STRLEN byte = *offsetp; 6554 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */ 6555 STRLEN blen; 6556 MAGIC* mg = NULL; 6557 const U8* send; 6558 bool found = FALSE; 6559 6560 PERL_ARGS_ASSERT_SV_POS_B2U; 6561 6562 if (!sv) 6563 return; 6564 6565 s = (const U8*)SvPV_const(sv, blen); 6566 6567 if (blen < byte) 6568 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); 6569 6570 send = s + byte; 6571 6572 if (!SvREADONLY(sv) 6573 && PL_utf8cache 6574 && SvTYPE(sv) >= SVt_PVMG 6575 && (mg = mg_find(sv, PERL_MAGIC_utf8))) 6576 { 6577 if (mg->mg_ptr) { 6578 STRLEN * const cache = (STRLEN *) mg->mg_ptr; 6579 if (cache[1] == byte) { 6580 /* An exact match. */ 6581 *offsetp = cache[0]; 6582 return; 6583 } 6584 if (cache[3] == byte) { 6585 /* An exact match. */ 6586 *offsetp = cache[2]; 6587 return; 6588 } 6589 6590 if (cache[1] < byte) { 6591 /* We already know part of the way. */ 6592 if (mg->mg_len != -1) { 6593 /* Actually, we know the end too. */ 6594 len = cache[0] 6595 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, 6596 s + blen, mg->mg_len - cache[0]); 6597 } else { 6598 len = cache[0] + utf8_length(s + cache[1], send); 6599 } 6600 } 6601 else if (cache[3] < byte) { 6602 /* We're between the two cached pairs, so we do the calculation 6603 offset by the byte/utf-8 positions for the earlier pair, 6604 then add the utf-8 characters from the string start to 6605 there. */ 6606 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, 6607 s + cache[1], cache[0] - cache[2]) 6608 + cache[2]; 6609 6610 } 6611 else { /* cache[3] > byte */ 6612 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], 6613 cache[2]); 6614 6615 } 6616 ASSERT_UTF8_CACHE(cache); 6617 found = TRUE; 6618 } else if (mg->mg_len != -1) { 6619 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); 6620 found = TRUE; 6621 } 6622 } 6623 if (!found || PL_utf8cache < 0) { 6624 const STRLEN real_len = utf8_length(s, send); 6625 6626 if (found && PL_utf8cache < 0) { 6627 if (len != real_len) { 6628 /* Need to turn the assertions off otherwise we may recurse 6629 infinitely while printing error messages. */ 6630 SAVEI8(PL_utf8cache); 6631 PL_utf8cache = 0; 6632 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf 6633 " real %"UVuf" for %"SVf, 6634 (UV) len, (UV) real_len, SVfARG(sv)); 6635 } 6636 } 6637 len = real_len; 6638 } 6639 *offsetp = len; 6640 6641 if (PL_utf8cache) 6642 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen); 6643 } 6644 6645 /* 6646 =for apidoc sv_eq 6647 6648 Returns a boolean indicating whether the strings in the two SVs are 6649 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will 6650 coerce its args to strings if necessary. 6651 6652 =cut 6653 */ 6654 6655 I32 6656 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) 6657 { 6658 dVAR; 6659 const char *pv1; 6660 STRLEN cur1; 6661 const char *pv2; 6662 STRLEN cur2; 6663 I32 eq = 0; 6664 char *tpv = NULL; 6665 SV* svrecode = NULL; 6666 6667 if (!sv1) { 6668 pv1 = ""; 6669 cur1 = 0; 6670 } 6671 else { 6672 /* if pv1 and pv2 are the same, second SvPV_const call may 6673 * invalidate pv1, so we may need to make a copy */ 6674 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { 6675 pv1 = SvPV_const(sv1, cur1); 6676 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); 6677 } 6678 pv1 = SvPV_const(sv1, cur1); 6679 } 6680 6681 if (!sv2){ 6682 pv2 = ""; 6683 cur2 = 0; 6684 } 6685 else 6686 pv2 = SvPV_const(sv2, cur2); 6687 6688 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { 6689 /* Differing utf8ness. 6690 * Do not UTF8size the comparands as a side-effect. */ 6691 if (PL_encoding) { 6692 if (SvUTF8(sv1)) { 6693 svrecode = newSVpvn(pv2, cur2); 6694 sv_recode_to_utf8(svrecode, PL_encoding); 6695 pv2 = SvPV_const(svrecode, cur2); 6696 } 6697 else { 6698 svrecode = newSVpvn(pv1, cur1); 6699 sv_recode_to_utf8(svrecode, PL_encoding); 6700 pv1 = SvPV_const(svrecode, cur1); 6701 } 6702 /* Now both are in UTF-8. */ 6703 if (cur1 != cur2) { 6704 SvREFCNT_dec(svrecode); 6705 return FALSE; 6706 } 6707 } 6708 else { 6709 bool is_utf8 = TRUE; 6710 6711 if (SvUTF8(sv1)) { 6712 /* sv1 is the UTF-8 one, 6713 * if is equal it must be downgrade-able */ 6714 char * const pv = (char*)bytes_from_utf8((const U8*)pv1, 6715 &cur1, &is_utf8); 6716 if (pv != pv1) 6717 pv1 = tpv = pv; 6718 } 6719 else { 6720 /* sv2 is the UTF-8 one, 6721 * if is equal it must be downgrade-able */ 6722 char * const pv = (char *)bytes_from_utf8((const U8*)pv2, 6723 &cur2, &is_utf8); 6724 if (pv != pv2) 6725 pv2 = tpv = pv; 6726 } 6727 if (is_utf8) { 6728 /* Downgrade not possible - cannot be eq */ 6729 assert (tpv == 0); 6730 return FALSE; 6731 } 6732 } 6733 } 6734 6735 if (cur1 == cur2) 6736 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); 6737 6738 SvREFCNT_dec(svrecode); 6739 if (tpv) 6740 Safefree(tpv); 6741 6742 return eq; 6743 } 6744 6745 /* 6746 =for apidoc sv_cmp 6747 6748 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the 6749 string in C<sv1> is less than, equal to, or greater than the string in 6750 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will 6751 coerce its args to strings if necessary. See also C<sv_cmp_locale>. 6752 6753 =cut 6754 */ 6755 6756 I32 6757 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2) 6758 { 6759 dVAR; 6760 STRLEN cur1, cur2; 6761 const char *pv1, *pv2; 6762 char *tpv = NULL; 6763 I32 cmp; 6764 SV *svrecode = NULL; 6765 6766 if (!sv1) { 6767 pv1 = ""; 6768 cur1 = 0; 6769 } 6770 else 6771 pv1 = SvPV_const(sv1, cur1); 6772 6773 if (!sv2) { 6774 pv2 = ""; 6775 cur2 = 0; 6776 } 6777 else 6778 pv2 = SvPV_const(sv2, cur2); 6779 6780 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { 6781 /* Differing utf8ness. 6782 * Do not UTF8size the comparands as a side-effect. */ 6783 if (SvUTF8(sv1)) { 6784 if (PL_encoding) { 6785 svrecode = newSVpvn(pv2, cur2); 6786 sv_recode_to_utf8(svrecode, PL_encoding); 6787 pv2 = SvPV_const(svrecode, cur2); 6788 } 6789 else { 6790 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2); 6791 } 6792 } 6793 else { 6794 if (PL_encoding) { 6795 svrecode = newSVpvn(pv1, cur1); 6796 sv_recode_to_utf8(svrecode, PL_encoding); 6797 pv1 = SvPV_const(svrecode, cur1); 6798 } 6799 else { 6800 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1); 6801 } 6802 } 6803 } 6804 6805 if (!cur1) { 6806 cmp = cur2 ? -1 : 0; 6807 } else if (!cur2) { 6808 cmp = 1; 6809 } else { 6810 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2); 6811 6812 if (retval) { 6813 cmp = retval < 0 ? -1 : 1; 6814 } else if (cur1 == cur2) { 6815 cmp = 0; 6816 } else { 6817 cmp = cur1 < cur2 ? -1 : 1; 6818 } 6819 } 6820 6821 SvREFCNT_dec(svrecode); 6822 if (tpv) 6823 Safefree(tpv); 6824 6825 return cmp; 6826 } 6827 6828 /* 6829 =for apidoc sv_cmp_locale 6830 6831 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 6832 'use bytes' aware, handles get magic, and will coerce its args to strings 6833 if necessary. See also C<sv_cmp>. 6834 6835 =cut 6836 */ 6837 6838 I32 6839 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2) 6840 { 6841 dVAR; 6842 #ifdef USE_LOCALE_COLLATE 6843 6844 char *pv1, *pv2; 6845 STRLEN len1, len2; 6846 I32 retval; 6847 6848 if (PL_collation_standard) 6849 goto raw_compare; 6850 6851 len1 = 0; 6852 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL; 6853 len2 = 0; 6854 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL; 6855 6856 if (!pv1 || !len1) { 6857 if (pv2 && len2) 6858 return -1; 6859 else 6860 goto raw_compare; 6861 } 6862 else { 6863 if (!pv2 || !len2) 6864 return 1; 6865 } 6866 6867 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); 6868 6869 if (retval) 6870 return retval < 0 ? -1 : 1; 6871 6872 /* 6873 * When the result of collation is equality, that doesn't mean 6874 * that there are no differences -- some locales exclude some 6875 * characters from consideration. So to avoid false equalities, 6876 * we use the raw string as a tiebreaker. 6877 */ 6878 6879 raw_compare: 6880 /*FALLTHROUGH*/ 6881 6882 #endif /* USE_LOCALE_COLLATE */ 6883 6884 return sv_cmp(sv1, sv2); 6885 } 6886 6887 6888 #ifdef USE_LOCALE_COLLATE 6889 6890 /* 6891 =for apidoc sv_collxfrm 6892 6893 Add Collate Transform magic to an SV if it doesn't already have it. 6894 6895 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the 6896 scalar data of the variable, but transformed to such a format that a normal 6897 memory comparison can be used to compare the data according to the locale 6898 settings. 6899 6900 =cut 6901 */ 6902 6903 char * 6904 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp) 6905 { 6906 dVAR; 6907 MAGIC *mg; 6908 6909 PERL_ARGS_ASSERT_SV_COLLXFRM; 6910 6911 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; 6912 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { 6913 const char *s; 6914 char *xf; 6915 STRLEN len, xlen; 6916 6917 if (mg) 6918 Safefree(mg->mg_ptr); 6919 s = SvPV_const(sv, len); 6920 if ((xf = mem_collxfrm(s, len, &xlen))) { 6921 if (! mg) { 6922 #ifdef PERL_OLD_COPY_ON_WRITE 6923 if (SvIsCOW(sv)) 6924 sv_force_normal_flags(sv, 0); 6925 #endif 6926 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, 6927 0, 0); 6928 assert(mg); 6929 } 6930 mg->mg_ptr = xf; 6931 mg->mg_len = xlen; 6932 } 6933 else { 6934 if (mg) { 6935 mg->mg_ptr = NULL; 6936 mg->mg_len = -1; 6937 } 6938 } 6939 } 6940 if (mg && mg->mg_ptr) { 6941 *nxp = mg->mg_len; 6942 return mg->mg_ptr + sizeof(PL_collation_ix); 6943 } 6944 else { 6945 *nxp = 0; 6946 return NULL; 6947 } 6948 } 6949 6950 #endif /* USE_LOCALE_COLLATE */ 6951 6952 /* 6953 =for apidoc sv_gets 6954 6955 Get a line from the filehandle and store it into the SV, optionally 6956 appending to the currently-stored string. 6957 6958 =cut 6959 */ 6960 6961 char * 6962 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) 6963 { 6964 dVAR; 6965 const char *rsptr; 6966 STRLEN rslen; 6967 register STDCHAR rslast; 6968 register STDCHAR *bp; 6969 register I32 cnt; 6970 I32 i = 0; 6971 I32 rspara = 0; 6972 6973 PERL_ARGS_ASSERT_SV_GETS; 6974 6975 if (SvTHINKFIRST(sv)) 6976 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); 6977 /* XXX. If you make this PVIV, then copy on write can copy scalars read 6978 from <>. 6979 However, perlbench says it's slower, because the existing swipe code 6980 is faster than copy on write. 6981 Swings and roundabouts. */ 6982 SvUPGRADE(sv, SVt_PV); 6983 6984 SvSCREAM_off(sv); 6985 6986 if (append) { 6987 if (PerlIO_isutf8(fp)) { 6988 if (!SvUTF8(sv)) { 6989 sv_utf8_upgrade_nomg(sv); 6990 sv_pos_u2b(sv,&append,0); 6991 } 6992 } else if (SvUTF8(sv)) { 6993 SV * const tsv = newSV(0); 6994 sv_gets(tsv, fp, 0); 6995 sv_utf8_upgrade_nomg(tsv); 6996 SvCUR_set(sv,append); 6997 sv_catsv(sv,tsv); 6998 sv_free(tsv); 6999 goto return_string_or_null; 7000 } 7001 } 7002 7003 SvPOK_only(sv); 7004 if (PerlIO_isutf8(fp)) 7005 SvUTF8_on(sv); 7006 7007 if (IN_PERL_COMPILETIME) { 7008 /* we always read code in line mode */ 7009 rsptr = "\n"; 7010 rslen = 1; 7011 } 7012 else if (RsSNARF(PL_rs)) { 7013 /* If it is a regular disk file use size from stat() as estimate 7014 of amount we are going to read -- may result in mallocing 7015 more memory than we really need if the layers below reduce 7016 the size we read (e.g. CRLF or a gzip layer). 7017 */ 7018 Stat_t st; 7019 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { 7020 const Off_t offset = PerlIO_tell(fp); 7021 if (offset != (Off_t) -1 && st.st_size + append > offset) { 7022 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); 7023 } 7024 } 7025 rsptr = NULL; 7026 rslen = 0; 7027 } 7028 else if (RsRECORD(PL_rs)) { 7029 I32 bytesread; 7030 char *buffer; 7031 U32 recsize; 7032 #ifdef VMS 7033 int fd; 7034 #endif 7035 7036 /* Grab the size of the record we're getting */ 7037 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ 7038 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; 7039 /* Go yank in */ 7040 #ifdef VMS 7041 /* VMS wants read instead of fread, because fread doesn't respect */ 7042 /* RMS record boundaries. This is not necessarily a good thing to be */ 7043 /* doing, but we've got no other real choice - except avoid stdio 7044 as implementation - perhaps write a :vms layer ? 7045 */ 7046 fd = PerlIO_fileno(fp); 7047 if (fd == -1) { /* in-memory file from PerlIO::Scalar */ 7048 bytesread = PerlIO_read(fp, buffer, recsize); 7049 } 7050 else { 7051 bytesread = PerlLIO_read(fd, buffer, recsize); 7052 } 7053 #else 7054 bytesread = PerlIO_read(fp, buffer, recsize); 7055 #endif 7056 if (bytesread < 0) 7057 bytesread = 0; 7058 SvCUR_set(sv, bytesread + append); 7059 buffer[bytesread] = '\0'; 7060 goto return_string_or_null; 7061 } 7062 else if (RsPARA(PL_rs)) { 7063 rsptr = "\n\n"; 7064 rslen = 2; 7065 rspara = 1; 7066 } 7067 else { 7068 /* Get $/ i.e. PL_rs into same encoding as stream wants */ 7069 if (PerlIO_isutf8(fp)) { 7070 rsptr = SvPVutf8(PL_rs, rslen); 7071 } 7072 else { 7073 if (SvUTF8(PL_rs)) { 7074 if (!sv_utf8_downgrade(PL_rs, TRUE)) { 7075 Perl_croak(aTHX_ "Wide character in $/"); 7076 } 7077 } 7078 rsptr = SvPV_const(PL_rs, rslen); 7079 } 7080 } 7081 7082 rslast = rslen ? rsptr[rslen - 1] : '\0'; 7083 7084 if (rspara) { /* have to do this both before and after */ 7085 do { /* to make sure file boundaries work right */ 7086 if (PerlIO_eof(fp)) 7087 return 0; 7088 i = PerlIO_getc(fp); 7089 if (i != '\n') { 7090 if (i == -1) 7091 return 0; 7092 PerlIO_ungetc(fp,i); 7093 break; 7094 } 7095 } while (i != EOF); 7096 } 7097 7098 /* See if we know enough about I/O mechanism to cheat it ! */ 7099 7100 /* This used to be #ifdef test - it is made run-time test for ease 7101 of abstracting out stdio interface. One call should be cheap 7102 enough here - and may even be a macro allowing compile 7103 time optimization. 7104 */ 7105 7106 if (PerlIO_fast_gets(fp)) { 7107 7108 /* 7109 * We're going to steal some values from the stdio struct 7110 * and put EVERYTHING in the innermost loop into registers. 7111 */ 7112 register STDCHAR *ptr; 7113 STRLEN bpx; 7114 I32 shortbuffered; 7115 7116 #if defined(VMS) && defined(PERLIO_IS_STDIO) 7117 /* An ungetc()d char is handled separately from the regular 7118 * buffer, so we getc() it back out and stuff it in the buffer. 7119 */ 7120 i = PerlIO_getc(fp); 7121 if (i == EOF) return 0; 7122 *(--((*fp)->_ptr)) = (unsigned char) i; 7123 (*fp)->_cnt++; 7124 #endif 7125 7126 /* Here is some breathtakingly efficient cheating */ 7127 7128 cnt = PerlIO_get_cnt(fp); /* get count into register */ 7129 /* make sure we have the room */ 7130 if ((I32)(SvLEN(sv) - append) <= cnt + 1) { 7131 /* Not room for all of it 7132 if we are looking for a separator and room for some 7133 */ 7134 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { 7135 /* just process what we have room for */ 7136 shortbuffered = cnt - SvLEN(sv) + append + 1; 7137 cnt -= shortbuffered; 7138 } 7139 else { 7140 shortbuffered = 0; 7141 /* remember that cnt can be negative */ 7142 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); 7143 } 7144 } 7145 else 7146 shortbuffered = 0; 7147 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */ 7148 ptr = (STDCHAR*)PerlIO_get_ptr(fp); 7149 DEBUG_P(PerlIO_printf(Perl_debug_log, 7150 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 7151 DEBUG_P(PerlIO_printf(Perl_debug_log, 7152 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 7153 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 7154 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); 7155 for (;;) { 7156 screamer: 7157 if (cnt > 0) { 7158 if (rslen) { 7159 while (cnt > 0) { /* this | eat */ 7160 cnt--; 7161 if ((*bp++ = *ptr++) == rslast) /* really | dust */ 7162 goto thats_all_folks; /* screams | sed :-) */ 7163 } 7164 } 7165 else { 7166 Copy(ptr, bp, cnt, char); /* this | eat */ 7167 bp += cnt; /* screams | dust */ 7168 ptr += cnt; /* louder | sed :-) */ 7169 cnt = 0; 7170 } 7171 } 7172 7173 if (shortbuffered) { /* oh well, must extend */ 7174 cnt = shortbuffered; 7175 shortbuffered = 0; 7176 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ 7177 SvCUR_set(sv, bpx); 7178 SvGROW(sv, SvLEN(sv) + append + cnt + 2); 7179 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ 7180 continue; 7181 } 7182 7183 DEBUG_P(PerlIO_printf(Perl_debug_log, 7184 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", 7185 PTR2UV(ptr),(long)cnt)); 7186 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ 7187 #if 0 7188 DEBUG_P(PerlIO_printf(Perl_debug_log, 7189 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 7190 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 7191 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 7192 #endif 7193 /* This used to call 'filbuf' in stdio form, but as that behaves like 7194 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing 7195 another abstraction. */ 7196 i = PerlIO_getc(fp); /* get more characters */ 7197 #if 0 7198 DEBUG_P(PerlIO_printf(Perl_debug_log, 7199 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 7200 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 7201 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 7202 #endif 7203 cnt = PerlIO_get_cnt(fp); 7204 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ 7205 DEBUG_P(PerlIO_printf(Perl_debug_log, 7206 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 7207 7208 if (i == EOF) /* all done for ever? */ 7209 goto thats_really_all_folks; 7210 7211 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ 7212 SvCUR_set(sv, bpx); 7213 SvGROW(sv, bpx + cnt + 2); 7214 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ 7215 7216 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ 7217 7218 if (rslen && (STDCHAR)i == rslast) /* all done for now? */ 7219 goto thats_all_folks; 7220 } 7221 7222 thats_all_folks: 7223 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || 7224 memNE((char*)bp - rslen, rsptr, rslen)) 7225 goto screamer; /* go back to the fray */ 7226 thats_really_all_folks: 7227 if (shortbuffered) 7228 cnt += shortbuffered; 7229 DEBUG_P(PerlIO_printf(Perl_debug_log, 7230 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); 7231 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ 7232 DEBUG_P(PerlIO_printf(Perl_debug_log, 7233 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", 7234 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), 7235 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); 7236 *bp = '\0'; 7237 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ 7238 DEBUG_P(PerlIO_printf(Perl_debug_log, 7239 "Screamer: done, len=%ld, string=|%.*s|\n", 7240 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); 7241 } 7242 else 7243 { 7244 /*The big, slow, and stupid way. */ 7245 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ 7246 STDCHAR *buf = NULL; 7247 Newx(buf, 8192, STDCHAR); 7248 assert(buf); 7249 #else 7250 STDCHAR buf[8192]; 7251 #endif 7252 7253 screamer2: 7254 if (rslen) { 7255 register const STDCHAR * const bpe = buf + sizeof(buf); 7256 bp = buf; 7257 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) 7258 ; /* keep reading */ 7259 cnt = bp - buf; 7260 } 7261 else { 7262 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); 7263 /* Accomodate broken VAXC compiler, which applies U8 cast to 7264 * both args of ?: operator, causing EOF to change into 255 7265 */ 7266 if (cnt > 0) 7267 i = (U8)buf[cnt - 1]; 7268 else 7269 i = EOF; 7270 } 7271 7272 if (cnt < 0) 7273 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ 7274 if (append) 7275 sv_catpvn(sv, (char *) buf, cnt); 7276 else 7277 sv_setpvn(sv, (char *) buf, cnt); 7278 7279 if (i != EOF && /* joy */ 7280 (!rslen || 7281 SvCUR(sv) < rslen || 7282 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) 7283 { 7284 append = -1; 7285 /* 7286 * If we're reading from a TTY and we get a short read, 7287 * indicating that the user hit his EOF character, we need 7288 * to notice it now, because if we try to read from the TTY 7289 * again, the EOF condition will disappear. 7290 * 7291 * The comparison of cnt to sizeof(buf) is an optimization 7292 * that prevents unnecessary calls to feof(). 7293 * 7294 * - jik 9/25/96 7295 */ 7296 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) 7297 goto screamer2; 7298 } 7299 7300 #ifdef USE_HEAP_INSTEAD_OF_STACK 7301 Safefree(buf); 7302 #endif 7303 } 7304 7305 if (rspara) { /* have to do this both before and after */ 7306 while (i != EOF) { /* to make sure file boundaries work right */ 7307 i = PerlIO_getc(fp); 7308 if (i != '\n') { 7309 PerlIO_ungetc(fp,i); 7310 break; 7311 } 7312 } 7313 } 7314 7315 return_string_or_null: 7316 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; 7317 } 7318 7319 /* 7320 =for apidoc sv_inc 7321 7322 Auto-increment of the value in the SV, doing string to numeric conversion 7323 if necessary. Handles 'get' magic. 7324 7325 =cut 7326 */ 7327 7328 void 7329 Perl_sv_inc(pTHX_ register SV *const sv) 7330 { 7331 dVAR; 7332 register char *d; 7333 int flags; 7334 7335 if (!sv) 7336 return; 7337 SvGETMAGIC(sv); 7338 if (SvTHINKFIRST(sv)) { 7339 if (SvIsCOW(sv)) 7340 sv_force_normal_flags(sv, 0); 7341 if (SvREADONLY(sv)) { 7342 if (IN_PERL_RUNTIME) 7343 Perl_croak(aTHX_ "%s", PL_no_modify); 7344 } 7345 if (SvROK(sv)) { 7346 IV i; 7347 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) 7348 return; 7349 i = PTR2IV(SvRV(sv)); 7350 sv_unref(sv); 7351 sv_setiv(sv, i); 7352 } 7353 } 7354 flags = SvFLAGS(sv); 7355 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { 7356 /* It's (privately or publicly) a float, but not tested as an 7357 integer, so test it to see. */ 7358 (void) SvIV(sv); 7359 flags = SvFLAGS(sv); 7360 } 7361 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 7362 /* It's publicly an integer, or privately an integer-not-float */ 7363 #ifdef PERL_PRESERVE_IVUV 7364 oops_its_int: 7365 #endif 7366 if (SvIsUV(sv)) { 7367 if (SvUVX(sv) == UV_MAX) 7368 sv_setnv(sv, UV_MAX_P1); 7369 else 7370 (void)SvIOK_only_UV(sv); 7371 SvUV_set(sv, SvUVX(sv) + 1); 7372 } else { 7373 if (SvIVX(sv) == IV_MAX) 7374 sv_setuv(sv, (UV)IV_MAX + 1); 7375 else { 7376 (void)SvIOK_only(sv); 7377 SvIV_set(sv, SvIVX(sv) + 1); 7378 } 7379 } 7380 return; 7381 } 7382 if (flags & SVp_NOK) { 7383 const NV was = SvNVX(sv); 7384 if (NV_OVERFLOWS_INTEGERS_AT && 7385 was >= NV_OVERFLOWS_INTEGERS_AT) { 7386 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), 7387 "Lost precision when incrementing %" NVff " by 1", 7388 was); 7389 } 7390 (void)SvNOK_only(sv); 7391 SvNV_set(sv, was + 1.0); 7392 return; 7393 } 7394 7395 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { 7396 if ((flags & SVTYPEMASK) < SVt_PVIV) 7397 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); 7398 (void)SvIOK_only(sv); 7399 SvIV_set(sv, 1); 7400 return; 7401 } 7402 d = SvPVX(sv); 7403 while (isALPHA(*d)) d++; 7404 while (isDIGIT(*d)) d++; 7405 if (d < SvEND(sv)) { 7406 #ifdef PERL_PRESERVE_IVUV 7407 /* Got to punt this as an integer if needs be, but we don't issue 7408 warnings. Probably ought to make the sv_iv_please() that does 7409 the conversion if possible, and silently. */ 7410 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); 7411 if (numtype && !(numtype & IS_NUMBER_INFINITY)) { 7412 /* Need to try really hard to see if it's an integer. 7413 9.22337203685478e+18 is an integer. 7414 but "9.22337203685478e+18" + 0 is UV=9223372036854779904 7415 so $a="9.22337203685478e+18"; $a+0; $a++ 7416 needs to be the same as $a="9.22337203685478e+18"; $a++ 7417 or we go insane. */ 7418 7419 (void) sv_2iv(sv); 7420 if (SvIOK(sv)) 7421 goto oops_its_int; 7422 7423 /* sv_2iv *should* have made this an NV */ 7424 if (flags & SVp_NOK) { 7425 (void)SvNOK_only(sv); 7426 SvNV_set(sv, SvNVX(sv) + 1.0); 7427 return; 7428 } 7429 /* I don't think we can get here. Maybe I should assert this 7430 And if we do get here I suspect that sv_setnv will croak. NWC 7431 Fall through. */ 7432 #if defined(USE_LONG_DOUBLE) 7433 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", 7434 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 7435 #else 7436 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", 7437 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 7438 #endif 7439 } 7440 #endif /* PERL_PRESERVE_IVUV */ 7441 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); 7442 return; 7443 } 7444 d--; 7445 while (d >= SvPVX_const(sv)) { 7446 if (isDIGIT(*d)) { 7447 if (++*d <= '9') 7448 return; 7449 *(d--) = '0'; 7450 } 7451 else { 7452 #ifdef EBCDIC 7453 /* MKS: The original code here died if letters weren't consecutive. 7454 * at least it didn't have to worry about non-C locales. The 7455 * new code assumes that ('z'-'a')==('Z'-'A'), letters are 7456 * arranged in order (although not consecutively) and that only 7457 * [A-Za-z] are accepted by isALPHA in the C locale. 7458 */ 7459 if (*d != 'z' && *d != 'Z') { 7460 do { ++*d; } while (!isALPHA(*d)); 7461 return; 7462 } 7463 *(d--) -= 'z' - 'a'; 7464 #else 7465 ++*d; 7466 if (isALPHA(*d)) 7467 return; 7468 *(d--) -= 'z' - 'a' + 1; 7469 #endif 7470 } 7471 } 7472 /* oh,oh, the number grew */ 7473 SvGROW(sv, SvCUR(sv) + 2); 7474 SvCUR_set(sv, SvCUR(sv) + 1); 7475 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) 7476 *d = d[-1]; 7477 if (isDIGIT(d[1])) 7478 *d = '1'; 7479 else 7480 *d = d[1]; 7481 } 7482 7483 /* 7484 =for apidoc sv_dec 7485 7486 Auto-decrement of the value in the SV, doing string to numeric conversion 7487 if necessary. Handles 'get' magic. 7488 7489 =cut 7490 */ 7491 7492 void 7493 Perl_sv_dec(pTHX_ register SV *const sv) 7494 { 7495 dVAR; 7496 int flags; 7497 7498 if (!sv) 7499 return; 7500 SvGETMAGIC(sv); 7501 if (SvTHINKFIRST(sv)) { 7502 if (SvIsCOW(sv)) 7503 sv_force_normal_flags(sv, 0); 7504 if (SvREADONLY(sv)) { 7505 if (IN_PERL_RUNTIME) 7506 Perl_croak(aTHX_ "%s", PL_no_modify); 7507 } 7508 if (SvROK(sv)) { 7509 IV i; 7510 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) 7511 return; 7512 i = PTR2IV(SvRV(sv)); 7513 sv_unref(sv); 7514 sv_setiv(sv, i); 7515 } 7516 } 7517 /* Unlike sv_inc we don't have to worry about string-never-numbers 7518 and keeping them magic. But we mustn't warn on punting */ 7519 flags = SvFLAGS(sv); 7520 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 7521 /* It's publicly an integer, or privately an integer-not-float */ 7522 #ifdef PERL_PRESERVE_IVUV 7523 oops_its_int: 7524 #endif 7525 if (SvIsUV(sv)) { 7526 if (SvUVX(sv) == 0) { 7527 (void)SvIOK_only(sv); 7528 SvIV_set(sv, -1); 7529 } 7530 else { 7531 (void)SvIOK_only_UV(sv); 7532 SvUV_set(sv, SvUVX(sv) - 1); 7533 } 7534 } else { 7535 if (SvIVX(sv) == IV_MIN) { 7536 sv_setnv(sv, (NV)IV_MIN); 7537 goto oops_its_num; 7538 } 7539 else { 7540 (void)SvIOK_only(sv); 7541 SvIV_set(sv, SvIVX(sv) - 1); 7542 } 7543 } 7544 return; 7545 } 7546 if (flags & SVp_NOK) { 7547 oops_its_num: 7548 { 7549 const NV was = SvNVX(sv); 7550 if (NV_OVERFLOWS_INTEGERS_AT && 7551 was <= -NV_OVERFLOWS_INTEGERS_AT) { 7552 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), 7553 "Lost precision when decrementing %" NVff " by 1", 7554 was); 7555 } 7556 (void)SvNOK_only(sv); 7557 SvNV_set(sv, was - 1.0); 7558 return; 7559 } 7560 } 7561 if (!(flags & SVp_POK)) { 7562 if ((flags & SVTYPEMASK) < SVt_PVIV) 7563 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); 7564 SvIV_set(sv, -1); 7565 (void)SvIOK_only(sv); 7566 return; 7567 } 7568 #ifdef PERL_PRESERVE_IVUV 7569 { 7570 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); 7571 if (numtype && !(numtype & IS_NUMBER_INFINITY)) { 7572 /* Need to try really hard to see if it's an integer. 7573 9.22337203685478e+18 is an integer. 7574 but "9.22337203685478e+18" + 0 is UV=9223372036854779904 7575 so $a="9.22337203685478e+18"; $a+0; $a-- 7576 needs to be the same as $a="9.22337203685478e+18"; $a-- 7577 or we go insane. */ 7578 7579 (void) sv_2iv(sv); 7580 if (SvIOK(sv)) 7581 goto oops_its_int; 7582 7583 /* sv_2iv *should* have made this an NV */ 7584 if (flags & SVp_NOK) { 7585 (void)SvNOK_only(sv); 7586 SvNV_set(sv, SvNVX(sv) - 1.0); 7587 return; 7588 } 7589 /* I don't think we can get here. Maybe I should assert this 7590 And if we do get here I suspect that sv_setnv will croak. NWC 7591 Fall through. */ 7592 #if defined(USE_LONG_DOUBLE) 7593 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", 7594 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 7595 #else 7596 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", 7597 SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); 7598 #endif 7599 } 7600 } 7601 #endif /* PERL_PRESERVE_IVUV */ 7602 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ 7603 } 7604 7605 /* this define is used to eliminate a chunk of duplicated but shared logic 7606 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be 7607 * used anywhere but here - yves 7608 */ 7609 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \ 7610 STMT_START { \ 7611 EXTEND_MORTAL(1); \ 7612 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \ 7613 } STMT_END 7614 7615 /* 7616 =for apidoc sv_mortalcopy 7617 7618 Creates a new SV which is a copy of the original SV (using C<sv_setsv>). 7619 The new SV is marked as mortal. It will be destroyed "soon", either by an 7620 explicit call to FREETMPS, or by an implicit call at places such as 7621 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>. 7622 7623 =cut 7624 */ 7625 7626 /* Make a string that will exist for the duration of the expression 7627 * evaluation. Actually, it may have to last longer than that, but 7628 * hopefully we won't free it until it has been assigned to a 7629 * permanent location. */ 7630 7631 SV * 7632 Perl_sv_mortalcopy(pTHX_ SV *const oldstr) 7633 { 7634 dVAR; 7635 register SV *sv; 7636 7637 new_SV(sv); 7638 sv_setsv(sv,oldstr); 7639 PUSH_EXTEND_MORTAL__SV_C(sv); 7640 SvTEMP_on(sv); 7641 return sv; 7642 } 7643 7644 /* 7645 =for apidoc sv_newmortal 7646 7647 Creates a new null SV which is mortal. The reference count of the SV is 7648 set to 1. It will be destroyed "soon", either by an explicit call to 7649 FREETMPS, or by an implicit call at places such as statement boundaries. 7650 See also C<sv_mortalcopy> and C<sv_2mortal>. 7651 7652 =cut 7653 */ 7654 7655 SV * 7656 Perl_sv_newmortal(pTHX) 7657 { 7658 dVAR; 7659 register SV *sv; 7660 7661 new_SV(sv); 7662 SvFLAGS(sv) = SVs_TEMP; 7663 PUSH_EXTEND_MORTAL__SV_C(sv); 7664 return sv; 7665 } 7666 7667 7668 /* 7669 =for apidoc newSVpvn_flags 7670 7671 Creates a new SV and copies a string into it. The reference count for the 7672 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length 7673 string. You are responsible for ensuring that the source string is at least 7674 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined. 7675 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>. 7676 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before 7677 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the 7678 C<SVf_UTF8> flag will be set on the new SV. 7679 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as 7680 7681 #define newSVpvn_utf8(s, len, u) \ 7682 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) 7683 7684 =cut 7685 */ 7686 7687 SV * 7688 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) 7689 { 7690 dVAR; 7691 register SV *sv; 7692 7693 /* All the flags we don't support must be zero. 7694 And we're new code so I'm going to assert this from the start. */ 7695 assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); 7696 new_SV(sv); 7697 sv_setpvn(sv,s,len); 7698 7699 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal() 7700 * and do what it does outselves here. 7701 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags 7702 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which 7703 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we 7704 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx) 7705 */ 7706 7707 SvFLAGS(sv) |= flags; 7708 7709 if(flags & SVs_TEMP){ 7710 PUSH_EXTEND_MORTAL__SV_C(sv); 7711 } 7712 7713 return sv; 7714 } 7715 7716 /* 7717 =for apidoc sv_2mortal 7718 7719 Marks an existing SV as mortal. The SV will be destroyed "soon", either 7720 by an explicit call to FREETMPS, or by an implicit call at places such as 7721 statement boundaries. SvTEMP() is turned on which means that the SV's 7722 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal> 7723 and C<sv_mortalcopy>. 7724 7725 =cut 7726 */ 7727 7728 SV * 7729 Perl_sv_2mortal(pTHX_ register SV *const sv) 7730 { 7731 dVAR; 7732 if (!sv) 7733 return NULL; 7734 if (SvREADONLY(sv) && SvIMMORTAL(sv)) 7735 return sv; 7736 PUSH_EXTEND_MORTAL__SV_C(sv); 7737 SvTEMP_on(sv); 7738 return sv; 7739 } 7740 7741 /* 7742 =for apidoc newSVpv 7743 7744 Creates a new SV and copies a string into it. The reference count for the 7745 SV is set to 1. If C<len> is zero, Perl will compute the length using 7746 strlen(). For efficiency, consider using C<newSVpvn> instead. 7747 7748 =cut 7749 */ 7750 7751 SV * 7752 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) 7753 { 7754 dVAR; 7755 register SV *sv; 7756 7757 new_SV(sv); 7758 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); 7759 return sv; 7760 } 7761 7762 /* 7763 =for apidoc newSVpvn 7764 7765 Creates a new SV and copies a string into it. The reference count for the 7766 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length 7767 string. You are responsible for ensuring that the source string is at least 7768 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined. 7769 7770 =cut 7771 */ 7772 7773 SV * 7774 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len) 7775 { 7776 dVAR; 7777 register SV *sv; 7778 7779 new_SV(sv); 7780 sv_setpvn(sv,s,len); 7781 return sv; 7782 } 7783 7784 /* 7785 =for apidoc newSVhek 7786 7787 Creates a new SV from the hash key structure. It will generate scalars that 7788 point to the shared string table where possible. Returns a new (undefined) 7789 SV if the hek is NULL. 7790 7791 =cut 7792 */ 7793 7794 SV * 7795 Perl_newSVhek(pTHX_ const HEK *const hek) 7796 { 7797 dVAR; 7798 if (!hek) { 7799 SV *sv; 7800 7801 new_SV(sv); 7802 return sv; 7803 } 7804 7805 if (HEK_LEN(hek) == HEf_SVKEY) { 7806 return newSVsv(*(SV**)HEK_KEY(hek)); 7807 } else { 7808 const int flags = HEK_FLAGS(hek); 7809 if (flags & HVhek_WASUTF8) { 7810 /* Trouble :-) 7811 Andreas would like keys he put in as utf8 to come back as utf8 7812 */ 7813 STRLEN utf8_len = HEK_LEN(hek); 7814 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); 7815 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len); 7816 7817 SvUTF8_on (sv); 7818 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ 7819 return sv; 7820 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) { 7821 /* We don't have a pointer to the hv, so we have to replicate the 7822 flag into every HEK. This hv is using custom a hasing 7823 algorithm. Hence we can't return a shared string scalar, as 7824 that would contain the (wrong) hash value, and might get passed 7825 into an hv routine with a regular hash. 7826 Similarly, a hash that isn't using shared hash keys has to have 7827 the flag in every key so that we know not to try to call 7828 share_hek_kek on it. */ 7829 7830 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); 7831 if (HEK_UTF8(hek)) 7832 SvUTF8_on (sv); 7833 return sv; 7834 } 7835 /* This will be overwhelminly the most common case. */ 7836 { 7837 /* Inline most of newSVpvn_share(), because share_hek_hek() is far 7838 more efficient than sharepvn(). */ 7839 SV *sv; 7840 7841 new_SV(sv); 7842 sv_upgrade(sv, SVt_PV); 7843 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); 7844 SvCUR_set(sv, HEK_LEN(hek)); 7845 SvLEN_set(sv, 0); 7846 SvREADONLY_on(sv); 7847 SvFAKE_on(sv); 7848 SvPOK_on(sv); 7849 if (HEK_UTF8(hek)) 7850 SvUTF8_on(sv); 7851 return sv; 7852 } 7853 } 7854 } 7855 7856 /* 7857 =for apidoc newSVpvn_share 7858 7859 Creates a new SV with its SvPVX_const pointing to a shared string in the string 7860 table. If the string does not already exist in the table, it is created 7861 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that 7862 value is used; otherwise the hash is computed. The string's hash can be later 7863 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is 7864 that as the string table is used for shared hash keys these strings will have 7865 SvPVX_const == HeKEY and hash lookup will avoid string compare. 7866 7867 =cut 7868 */ 7869 7870 SV * 7871 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) 7872 { 7873 dVAR; 7874 register SV *sv; 7875 bool is_utf8 = FALSE; 7876 const char *const orig_src = src; 7877 7878 if (len < 0) { 7879 STRLEN tmplen = -len; 7880 is_utf8 = TRUE; 7881 /* See the note in hv.c:hv_fetch() --jhi */ 7882 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); 7883 len = tmplen; 7884 } 7885 if (!hash) 7886 PERL_HASH(hash, src, len); 7887 new_SV(sv); 7888 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it 7889 changes here, update it there too. */ 7890 sv_upgrade(sv, SVt_PV); 7891 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); 7892 SvCUR_set(sv, len); 7893 SvLEN_set(sv, 0); 7894 SvREADONLY_on(sv); 7895 SvFAKE_on(sv); 7896 SvPOK_on(sv); 7897 if (is_utf8) 7898 SvUTF8_on(sv); 7899 if (src != orig_src) 7900 Safefree(src); 7901 return sv; 7902 } 7903 7904 7905 #if defined(PERL_IMPLICIT_CONTEXT) 7906 7907 /* pTHX_ magic can't cope with varargs, so this is a no-context 7908 * version of the main function, (which may itself be aliased to us). 7909 * Don't access this version directly. 7910 */ 7911 7912 SV * 7913 Perl_newSVpvf_nocontext(const char *const pat, ...) 7914 { 7915 dTHX; 7916 register SV *sv; 7917 va_list args; 7918 7919 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT; 7920 7921 va_start(args, pat); 7922 sv = vnewSVpvf(pat, &args); 7923 va_end(args); 7924 return sv; 7925 } 7926 #endif 7927 7928 /* 7929 =for apidoc newSVpvf 7930 7931 Creates a new SV and initializes it with the string formatted like 7932 C<sprintf>. 7933 7934 =cut 7935 */ 7936 7937 SV * 7938 Perl_newSVpvf(pTHX_ const char *const pat, ...) 7939 { 7940 register SV *sv; 7941 va_list args; 7942 7943 PERL_ARGS_ASSERT_NEWSVPVF; 7944 7945 va_start(args, pat); 7946 sv = vnewSVpvf(pat, &args); 7947 va_end(args); 7948 return sv; 7949 } 7950 7951 /* backend for newSVpvf() and newSVpvf_nocontext() */ 7952 7953 SV * 7954 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) 7955 { 7956 dVAR; 7957 register SV *sv; 7958 7959 PERL_ARGS_ASSERT_VNEWSVPVF; 7960 7961 new_SV(sv); 7962 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 7963 return sv; 7964 } 7965 7966 /* 7967 =for apidoc newSVnv 7968 7969 Creates a new SV and copies a floating point value into it. 7970 The reference count for the SV is set to 1. 7971 7972 =cut 7973 */ 7974 7975 SV * 7976 Perl_newSVnv(pTHX_ const NV n) 7977 { 7978 dVAR; 7979 register SV *sv; 7980 7981 new_SV(sv); 7982 sv_setnv(sv,n); 7983 return sv; 7984 } 7985 7986 /* 7987 =for apidoc newSViv 7988 7989 Creates a new SV and copies an integer into it. The reference count for the 7990 SV is set to 1. 7991 7992 =cut 7993 */ 7994 7995 SV * 7996 Perl_newSViv(pTHX_ const IV i) 7997 { 7998 dVAR; 7999 register SV *sv; 8000 8001 new_SV(sv); 8002 sv_setiv(sv,i); 8003 return sv; 8004 } 8005 8006 /* 8007 =for apidoc newSVuv 8008 8009 Creates a new SV and copies an unsigned integer into it. 8010 The reference count for the SV is set to 1. 8011 8012 =cut 8013 */ 8014 8015 SV * 8016 Perl_newSVuv(pTHX_ const UV u) 8017 { 8018 dVAR; 8019 register SV *sv; 8020 8021 new_SV(sv); 8022 sv_setuv(sv,u); 8023 return sv; 8024 } 8025 8026 /* 8027 =for apidoc newSV_type 8028 8029 Creates a new SV, of the type specified. The reference count for the new SV 8030 is set to 1. 8031 8032 =cut 8033 */ 8034 8035 SV * 8036 Perl_newSV_type(pTHX_ const svtype type) 8037 { 8038 register SV *sv; 8039 8040 new_SV(sv); 8041 sv_upgrade(sv, type); 8042 return sv; 8043 } 8044 8045 /* 8046 =for apidoc newRV_noinc 8047 8048 Creates an RV wrapper for an SV. The reference count for the original 8049 SV is B<not> incremented. 8050 8051 =cut 8052 */ 8053 8054 SV * 8055 Perl_newRV_noinc(pTHX_ SV *const tmpRef) 8056 { 8057 dVAR; 8058 register SV *sv = newSV_type(SVt_IV); 8059 8060 PERL_ARGS_ASSERT_NEWRV_NOINC; 8061 8062 SvTEMP_off(tmpRef); 8063 SvRV_set(sv, tmpRef); 8064 SvROK_on(sv); 8065 return sv; 8066 } 8067 8068 /* newRV_inc is the official function name to use now. 8069 * newRV_inc is in fact #defined to newRV in sv.h 8070 */ 8071 8072 SV * 8073 Perl_newRV(pTHX_ SV *const sv) 8074 { 8075 dVAR; 8076 8077 PERL_ARGS_ASSERT_NEWRV; 8078 8079 return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); 8080 } 8081 8082 /* 8083 =for apidoc newSVsv 8084 8085 Creates a new SV which is an exact duplicate of the original SV. 8086 (Uses C<sv_setsv>). 8087 8088 =cut 8089 */ 8090 8091 SV * 8092 Perl_newSVsv(pTHX_ register SV *const old) 8093 { 8094 dVAR; 8095 register SV *sv; 8096 8097 if (!old) 8098 return NULL; 8099 if (SvTYPE(old) == SVTYPEMASK) { 8100 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); 8101 return NULL; 8102 } 8103 new_SV(sv); 8104 /* SV_GMAGIC is the default for sv_setv() 8105 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games 8106 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */ 8107 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL); 8108 return sv; 8109 } 8110 8111 /* 8112 =for apidoc sv_reset 8113 8114 Underlying implementation for the C<reset> Perl function. 8115 Note that the perl-level function is vaguely deprecated. 8116 8117 =cut 8118 */ 8119 8120 void 8121 Perl_sv_reset(pTHX_ register const char *s, HV *const stash) 8122 { 8123 dVAR; 8124 char todo[PERL_UCHAR_MAX+1]; 8125 8126 PERL_ARGS_ASSERT_SV_RESET; 8127 8128 if (!stash) 8129 return; 8130 8131 if (!*s) { /* reset ?? searches */ 8132 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); 8133 if (mg) { 8134 const U32 count = mg->mg_len / sizeof(PMOP**); 8135 PMOP **pmp = (PMOP**) mg->mg_ptr; 8136 PMOP *const *const end = pmp + count; 8137 8138 while (pmp < end) { 8139 #ifdef USE_ITHREADS 8140 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); 8141 #else 8142 (*pmp)->op_pmflags &= ~PMf_USED; 8143 #endif 8144 ++pmp; 8145 } 8146 } 8147 return; 8148 } 8149 8150 /* reset variables */ 8151 8152 if (!HvARRAY(stash)) 8153 return; 8154 8155 Zero(todo, 256, char); 8156 while (*s) { 8157 I32 max; 8158 I32 i = (unsigned char)*s; 8159 if (s[1] == '-') { 8160 s += 2; 8161 } 8162 max = (unsigned char)*s++; 8163 for ( ; i <= max; i++) { 8164 todo[i] = 1; 8165 } 8166 for (i = 0; i <= (I32) HvMAX(stash); i++) { 8167 HE *entry; 8168 for (entry = HvARRAY(stash)[i]; 8169 entry; 8170 entry = HeNEXT(entry)) 8171 { 8172 register GV *gv; 8173 register SV *sv; 8174 8175 if (!todo[(U8)*HeKEY(entry)]) 8176 continue; 8177 gv = MUTABLE_GV(HeVAL(entry)); 8178 sv = GvSV(gv); 8179 if (sv) { 8180 if (SvTHINKFIRST(sv)) { 8181 if (!SvREADONLY(sv) && SvROK(sv)) 8182 sv_unref(sv); 8183 /* XXX Is this continue a bug? Why should THINKFIRST 8184 exempt us from resetting arrays and hashes? */ 8185 continue; 8186 } 8187 SvOK_off(sv); 8188 if (SvTYPE(sv) >= SVt_PV) { 8189 SvCUR_set(sv, 0); 8190 if (SvPVX_const(sv) != NULL) 8191 *SvPVX(sv) = '\0'; 8192 SvTAINT(sv); 8193 } 8194 } 8195 if (GvAV(gv)) { 8196 av_clear(GvAV(gv)); 8197 } 8198 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { 8199 #if defined(VMS) 8200 Perl_die(aTHX_ "Can't reset %%ENV on this system"); 8201 #else /* ! VMS */ 8202 hv_clear(GvHV(gv)); 8203 # if defined(USE_ENVIRON_ARRAY) 8204 if (gv == PL_envgv) 8205 my_clearenv(); 8206 # endif /* USE_ENVIRON_ARRAY */ 8207 #endif /* VMS */ 8208 } 8209 } 8210 } 8211 } 8212 } 8213 8214 /* 8215 =for apidoc sv_2io 8216 8217 Using various gambits, try to get an IO from an SV: the IO slot if its a 8218 GV; or the recursive result if we're an RV; or the IO slot of the symbol 8219 named after the PV if we're a string. 8220 8221 =cut 8222 */ 8223 8224 IO* 8225 Perl_sv_2io(pTHX_ SV *const sv) 8226 { 8227 IO* io; 8228 GV* gv; 8229 8230 PERL_ARGS_ASSERT_SV_2IO; 8231 8232 switch (SvTYPE(sv)) { 8233 case SVt_PVIO: 8234 io = MUTABLE_IO(sv); 8235 break; 8236 case SVt_PVGV: 8237 if (isGV_with_GP(sv)) { 8238 gv = MUTABLE_GV(sv); 8239 io = GvIO(gv); 8240 if (!io) 8241 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); 8242 break; 8243 } 8244 /* FALL THROUGH */ 8245 default: 8246 if (!SvOK(sv)) 8247 Perl_croak(aTHX_ PL_no_usym, "filehandle"); 8248 if (SvROK(sv)) 8249 return sv_2io(SvRV(sv)); 8250 gv = gv_fetchsv(sv, 0, SVt_PVIO); 8251 if (gv) 8252 io = GvIO(gv); 8253 else 8254 io = 0; 8255 if (!io) 8256 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv)); 8257 break; 8258 } 8259 return io; 8260 } 8261 8262 /* 8263 =for apidoc sv_2cv 8264 8265 Using various gambits, try to get a CV from an SV; in addition, try if 8266 possible to set C<*st> and C<*gvp> to the stash and GV associated with it. 8267 The flags in C<lref> are passed to gv_fetchsv. 8268 8269 =cut 8270 */ 8271 8272 CV * 8273 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) 8274 { 8275 dVAR; 8276 GV *gv = NULL; 8277 CV *cv = NULL; 8278 8279 PERL_ARGS_ASSERT_SV_2CV; 8280 8281 if (!sv) { 8282 *st = NULL; 8283 *gvp = NULL; 8284 return NULL; 8285 } 8286 switch (SvTYPE(sv)) { 8287 case SVt_PVCV: 8288 *st = CvSTASH(sv); 8289 *gvp = NULL; 8290 return MUTABLE_CV(sv); 8291 case SVt_PVHV: 8292 case SVt_PVAV: 8293 *st = NULL; 8294 *gvp = NULL; 8295 return NULL; 8296 case SVt_PVGV: 8297 if (isGV_with_GP(sv)) { 8298 gv = MUTABLE_GV(sv); 8299 *gvp = gv; 8300 *st = GvESTASH(gv); 8301 goto fix_gv; 8302 } 8303 /* FALL THROUGH */ 8304 8305 default: 8306 if (SvROK(sv)) { 8307 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ 8308 SvGETMAGIC(sv); 8309 tryAMAGICunDEREF(to_cv); 8310 8311 sv = SvRV(sv); 8312 if (SvTYPE(sv) == SVt_PVCV) { 8313 cv = MUTABLE_CV(sv); 8314 *gvp = NULL; 8315 *st = CvSTASH(cv); 8316 return cv; 8317 } 8318 else if(isGV_with_GP(sv)) 8319 gv = MUTABLE_GV(sv); 8320 else 8321 Perl_croak(aTHX_ "Not a subroutine reference"); 8322 } 8323 else if (isGV_with_GP(sv)) { 8324 SvGETMAGIC(sv); 8325 gv = MUTABLE_GV(sv); 8326 } 8327 else 8328 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */ 8329 *gvp = gv; 8330 if (!gv) { 8331 *st = NULL; 8332 return NULL; 8333 } 8334 /* Some flags to gv_fetchsv mean don't really create the GV */ 8335 if (!isGV_with_GP(gv)) { 8336 *st = NULL; 8337 return NULL; 8338 } 8339 *st = GvESTASH(gv); 8340 fix_gv: 8341 if (lref && !GvCVu(gv)) { 8342 SV *tmpsv; 8343 ENTER; 8344 tmpsv = newSV(0); 8345 gv_efullname3(tmpsv, gv, NULL); 8346 /* XXX this is probably not what they think they're getting. 8347 * It has the same effect as "sub name;", i.e. just a forward 8348 * declaration! */ 8349 newSUB(start_subparse(FALSE, 0), 8350 newSVOP(OP_CONST, 0, tmpsv), 8351 NULL, NULL); 8352 LEAVE; 8353 if (!GvCVu(gv)) 8354 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", 8355 SVfARG(SvOK(sv) ? sv : &PL_sv_no)); 8356 } 8357 return GvCVu(gv); 8358 } 8359 } 8360 8361 /* 8362 =for apidoc sv_true 8363 8364 Returns true if the SV has a true value by Perl's rules. 8365 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may 8366 instead use an in-line version. 8367 8368 =cut 8369 */ 8370 8371 I32 8372 Perl_sv_true(pTHX_ register SV *const sv) 8373 { 8374 if (!sv) 8375 return 0; 8376 if (SvPOK(sv)) { 8377 register const XPV* const tXpv = (XPV*)SvANY(sv); 8378 if (tXpv && 8379 (tXpv->xpv_cur > 1 || 8380 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) 8381 return 1; 8382 else 8383 return 0; 8384 } 8385 else { 8386 if (SvIOK(sv)) 8387 return SvIVX(sv) != 0; 8388 else { 8389 if (SvNOK(sv)) 8390 return SvNVX(sv) != 0.0; 8391 else 8392 return sv_2bool(sv); 8393 } 8394 } 8395 } 8396 8397 /* 8398 =for apidoc sv_pvn_force 8399 8400 Get a sensible string out of the SV somehow. 8401 A private implementation of the C<SvPV_force> macro for compilers which 8402 can't cope with complex macro expressions. Always use the macro instead. 8403 8404 =for apidoc sv_pvn_force_flags 8405 8406 Get a sensible string out of the SV somehow. 8407 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if 8408 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are 8409 implemented in terms of this function. 8410 You normally want to use the various wrapper macros instead: see 8411 C<SvPV_force> and C<SvPV_force_nomg> 8412 8413 =cut 8414 */ 8415 8416 char * 8417 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) 8418 { 8419 dVAR; 8420 8421 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; 8422 8423 if (SvTHINKFIRST(sv) && !SvROK(sv)) 8424 sv_force_normal_flags(sv, 0); 8425 8426 if (SvPOK(sv)) { 8427 if (lp) 8428 *lp = SvCUR(sv); 8429 } 8430 else { 8431 char *s; 8432 STRLEN len; 8433 8434 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) { 8435 const char * const ref = sv_reftype(sv,0); 8436 if (PL_op) 8437 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", 8438 ref, OP_NAME(PL_op)); 8439 else 8440 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); 8441 } 8442 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) 8443 || isGV_with_GP(sv)) 8444 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), 8445 OP_NAME(PL_op)); 8446 s = sv_2pv_flags(sv, &len, flags); 8447 if (lp) 8448 *lp = len; 8449 8450 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ 8451 if (SvROK(sv)) 8452 sv_unref(sv); 8453 SvUPGRADE(sv, SVt_PV); /* Never FALSE */ 8454 SvGROW(sv, len + 1); 8455 Move(s,SvPVX(sv),len,char); 8456 SvCUR_set(sv, len); 8457 SvPVX(sv)[len] = '\0'; 8458 } 8459 if (!SvPOK(sv)) { 8460 SvPOK_on(sv); /* validate pointer */ 8461 SvTAINT(sv); 8462 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 8463 PTR2UV(sv),SvPVX_const(sv))); 8464 } 8465 } 8466 return SvPVX_mutable(sv); 8467 } 8468 8469 /* 8470 =for apidoc sv_pvbyten_force 8471 8472 The backend for the C<SvPVbytex_force> macro. Always use the macro instead. 8473 8474 =cut 8475 */ 8476 8477 char * 8478 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp) 8479 { 8480 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE; 8481 8482 sv_pvn_force(sv,lp); 8483 sv_utf8_downgrade(sv,0); 8484 *lp = SvCUR(sv); 8485 return SvPVX(sv); 8486 } 8487 8488 /* 8489 =for apidoc sv_pvutf8n_force 8490 8491 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead. 8492 8493 =cut 8494 */ 8495 8496 char * 8497 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) 8498 { 8499 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE; 8500 8501 sv_pvn_force(sv,lp); 8502 sv_utf8_upgrade(sv); 8503 *lp = SvCUR(sv); 8504 return SvPVX(sv); 8505 } 8506 8507 /* 8508 =for apidoc sv_reftype 8509 8510 Returns a string describing what the SV is a reference to. 8511 8512 =cut 8513 */ 8514 8515 const char * 8516 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) 8517 { 8518 PERL_ARGS_ASSERT_SV_REFTYPE; 8519 8520 /* The fact that I don't need to downcast to char * everywhere, only in ?: 8521 inside return suggests a const propagation bug in g++. */ 8522 if (ob && SvOBJECT(sv)) { 8523 char * const name = HvNAME_get(SvSTASH(sv)); 8524 return name ? name : (char *) "__ANON__"; 8525 } 8526 else { 8527 switch (SvTYPE(sv)) { 8528 case SVt_NULL: 8529 case SVt_IV: 8530 case SVt_NV: 8531 case SVt_PV: 8532 case SVt_PVIV: 8533 case SVt_PVNV: 8534 case SVt_PVMG: 8535 if (SvVOK(sv)) 8536 return "VSTRING"; 8537 if (SvROK(sv)) 8538 return "REF"; 8539 else 8540 return "SCALAR"; 8541 8542 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" 8543 /* tied lvalues should appear to be 8544 * scalars for backwards compatitbility */ 8545 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') 8546 ? "SCALAR" : "LVALUE"); 8547 case SVt_PVAV: return "ARRAY"; 8548 case SVt_PVHV: return "HASH"; 8549 case SVt_PVCV: return "CODE"; 8550 case SVt_PVGV: return (char *) (isGV_with_GP(sv) 8551 ? "GLOB" : "SCALAR"); 8552 case SVt_PVFM: return "FORMAT"; 8553 case SVt_PVIO: return "IO"; 8554 case SVt_BIND: return "BIND"; 8555 case SVt_REGEXP: return "REGEXP"; 8556 default: return "UNKNOWN"; 8557 } 8558 } 8559 } 8560 8561 /* 8562 =for apidoc sv_isobject 8563 8564 Returns a boolean indicating whether the SV is an RV pointing to a blessed 8565 object. If the SV is not an RV, or if the object is not blessed, then this 8566 will return false. 8567 8568 =cut 8569 */ 8570 8571 int 8572 Perl_sv_isobject(pTHX_ SV *sv) 8573 { 8574 if (!sv) 8575 return 0; 8576 SvGETMAGIC(sv); 8577 if (!SvROK(sv)) 8578 return 0; 8579 sv = SvRV(sv); 8580 if (!SvOBJECT(sv)) 8581 return 0; 8582 return 1; 8583 } 8584 8585 /* 8586 =for apidoc sv_isa 8587 8588 Returns a boolean indicating whether the SV is blessed into the specified 8589 class. This does not check for subtypes; use C<sv_derived_from> to verify 8590 an inheritance relationship. 8591 8592 =cut 8593 */ 8594 8595 int 8596 Perl_sv_isa(pTHX_ SV *sv, const char *const name) 8597 { 8598 const char *hvname; 8599 8600 PERL_ARGS_ASSERT_SV_ISA; 8601 8602 if (!sv) 8603 return 0; 8604 SvGETMAGIC(sv); 8605 if (!SvROK(sv)) 8606 return 0; 8607 sv = SvRV(sv); 8608 if (!SvOBJECT(sv)) 8609 return 0; 8610 hvname = HvNAME_get(SvSTASH(sv)); 8611 if (!hvname) 8612 return 0; 8613 8614 return strEQ(hvname, name); 8615 } 8616 8617 /* 8618 =for apidoc newSVrv 8619 8620 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then 8621 it will be upgraded to one. If C<classname> is non-null then the new SV will 8622 be blessed in the specified package. The new SV is returned and its 8623 reference count is 1. 8624 8625 =cut 8626 */ 8627 8628 SV* 8629 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) 8630 { 8631 dVAR; 8632 SV *sv; 8633 8634 PERL_ARGS_ASSERT_NEWSVRV; 8635 8636 new_SV(sv); 8637 8638 SV_CHECK_THINKFIRST_COW_DROP(rv); 8639 (void)SvAMAGIC_off(rv); 8640 8641 if (SvTYPE(rv) >= SVt_PVMG) { 8642 const U32 refcnt = SvREFCNT(rv); 8643 SvREFCNT(rv) = 0; 8644 sv_clear(rv); 8645 SvFLAGS(rv) = 0; 8646 SvREFCNT(rv) = refcnt; 8647 8648 sv_upgrade(rv, SVt_IV); 8649 } else if (SvROK(rv)) { 8650 SvREFCNT_dec(SvRV(rv)); 8651 } else { 8652 prepare_SV_for_RV(rv); 8653 } 8654 8655 SvOK_off(rv); 8656 SvRV_set(rv, sv); 8657 SvROK_on(rv); 8658 8659 if (classname) { 8660 HV* const stash = gv_stashpv(classname, GV_ADD); 8661 (void)sv_bless(rv, stash); 8662 } 8663 return sv; 8664 } 8665 8666 /* 8667 =for apidoc sv_setref_pv 8668 8669 Copies a pointer into a new SV, optionally blessing the SV. The C<rv> 8670 argument will be upgraded to an RV. That RV will be modified to point to 8671 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed 8672 into the SV. The C<classname> argument indicates the package for the 8673 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 8674 will have a reference count of 1, and the RV will be returned. 8675 8676 Do not use with other Perl types such as HV, AV, SV, CV, because those 8677 objects will become corrupted by the pointer copy process. 8678 8679 Note that C<sv_setref_pvn> copies the string while this copies the pointer. 8680 8681 =cut 8682 */ 8683 8684 SV* 8685 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) 8686 { 8687 dVAR; 8688 8689 PERL_ARGS_ASSERT_SV_SETREF_PV; 8690 8691 if (!pv) { 8692 sv_setsv(rv, &PL_sv_undef); 8693 SvSETMAGIC(rv); 8694 } 8695 else 8696 sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); 8697 return rv; 8698 } 8699 8700 /* 8701 =for apidoc sv_setref_iv 8702 8703 Copies an integer into a new SV, optionally blessing the SV. The C<rv> 8704 argument will be upgraded to an RV. That RV will be modified to point to 8705 the new SV. The C<classname> argument indicates the package for the 8706 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 8707 will have a reference count of 1, and the RV will be returned. 8708 8709 =cut 8710 */ 8711 8712 SV* 8713 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv) 8714 { 8715 PERL_ARGS_ASSERT_SV_SETREF_IV; 8716 8717 sv_setiv(newSVrv(rv,classname), iv); 8718 return rv; 8719 } 8720 8721 /* 8722 =for apidoc sv_setref_uv 8723 8724 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv> 8725 argument will be upgraded to an RV. That RV will be modified to point to 8726 the new SV. The C<classname> argument indicates the package for the 8727 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 8728 will have a reference count of 1, and the RV will be returned. 8729 8730 =cut 8731 */ 8732 8733 SV* 8734 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv) 8735 { 8736 PERL_ARGS_ASSERT_SV_SETREF_UV; 8737 8738 sv_setuv(newSVrv(rv,classname), uv); 8739 return rv; 8740 } 8741 8742 /* 8743 =for apidoc sv_setref_nv 8744 8745 Copies a double into a new SV, optionally blessing the SV. The C<rv> 8746 argument will be upgraded to an RV. That RV will be modified to point to 8747 the new SV. The C<classname> argument indicates the package for the 8748 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV 8749 will have a reference count of 1, and the RV will be returned. 8750 8751 =cut 8752 */ 8753 8754 SV* 8755 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv) 8756 { 8757 PERL_ARGS_ASSERT_SV_SETREF_NV; 8758 8759 sv_setnv(newSVrv(rv,classname), nv); 8760 return rv; 8761 } 8762 8763 /* 8764 =for apidoc sv_setref_pvn 8765 8766 Copies a string into a new SV, optionally blessing the SV. The length of the 8767 string must be specified with C<n>. The C<rv> argument will be upgraded to 8768 an RV. That RV will be modified to point to the new SV. The C<classname> 8769 argument indicates the package for the blessing. Set C<classname> to 8770 C<NULL> to avoid the blessing. The new SV will have a reference count 8771 of 1, and the RV will be returned. 8772 8773 Note that C<sv_setref_pv> copies the pointer while this copies the string. 8774 8775 =cut 8776 */ 8777 8778 SV* 8779 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname, 8780 const char *const pv, const STRLEN n) 8781 { 8782 PERL_ARGS_ASSERT_SV_SETREF_PVN; 8783 8784 sv_setpvn(newSVrv(rv,classname), pv, n); 8785 return rv; 8786 } 8787 8788 /* 8789 =for apidoc sv_bless 8790 8791 Blesses an SV into a specified package. The SV must be an RV. The package 8792 must be designated by its stash (see C<gv_stashpv()>). The reference count 8793 of the SV is unaffected. 8794 8795 =cut 8796 */ 8797 8798 SV* 8799 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) 8800 { 8801 dVAR; 8802 SV *tmpRef; 8803 8804 PERL_ARGS_ASSERT_SV_BLESS; 8805 8806 if (!SvROK(sv)) 8807 Perl_croak(aTHX_ "Can't bless non-reference value"); 8808 tmpRef = SvRV(sv); 8809 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { 8810 if (SvIsCOW(tmpRef)) 8811 sv_force_normal_flags(tmpRef, 0); 8812 if (SvREADONLY(tmpRef)) 8813 Perl_croak(aTHX_ "%s", PL_no_modify); 8814 if (SvOBJECT(tmpRef)) { 8815 if (SvTYPE(tmpRef) != SVt_PVIO) 8816 --PL_sv_objcount; 8817 SvREFCNT_dec(SvSTASH(tmpRef)); 8818 } 8819 } 8820 SvOBJECT_on(tmpRef); 8821 if (SvTYPE(tmpRef) != SVt_PVIO) 8822 ++PL_sv_objcount; 8823 SvUPGRADE(tmpRef, SVt_PVMG); 8824 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); 8825 8826 if (Gv_AMG(stash)) 8827 SvAMAGIC_on(sv); 8828 else 8829 (void)SvAMAGIC_off(sv); 8830 8831 if(SvSMAGICAL(tmpRef)) 8832 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) 8833 mg_set(tmpRef); 8834 8835 8836 8837 return sv; 8838 } 8839 8840 /* Downgrades a PVGV to a PVMG. 8841 */ 8842 8843 STATIC void 8844 S_sv_unglob(pTHX_ SV *const sv) 8845 { 8846 dVAR; 8847 void *xpvmg; 8848 HV *stash; 8849 SV * const temp = sv_newmortal(); 8850 8851 PERL_ARGS_ASSERT_SV_UNGLOB; 8852 8853 assert(SvTYPE(sv) == SVt_PVGV); 8854 SvFAKE_off(sv); 8855 gv_efullname3(temp, MUTABLE_GV(sv), "*"); 8856 8857 if (GvGP(sv)) { 8858 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) 8859 && HvNAME_get(stash)) 8860 mro_method_changed_in(stash); 8861 gp_free(MUTABLE_GV(sv)); 8862 } 8863 if (GvSTASH(sv)) { 8864 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); 8865 GvSTASH(sv) = NULL; 8866 } 8867 GvMULTI_off(sv); 8868 if (GvNAME_HEK(sv)) { 8869 unshare_hek(GvNAME_HEK(sv)); 8870 } 8871 isGV_with_GP_off(sv); 8872 8873 /* need to keep SvANY(sv) in the right arena */ 8874 xpvmg = new_XPVMG(); 8875 StructCopy(SvANY(sv), xpvmg, XPVMG); 8876 del_XPVGV(SvANY(sv)); 8877 SvANY(sv) = xpvmg; 8878 8879 SvFLAGS(sv) &= ~SVTYPEMASK; 8880 SvFLAGS(sv) |= SVt_PVMG; 8881 8882 /* Intentionally not calling any local SET magic, as this isn't so much a 8883 set operation as merely an internal storage change. */ 8884 sv_setsv_flags(sv, temp, 0); 8885 } 8886 8887 /* 8888 =for apidoc sv_unref_flags 8889 8890 Unsets the RV status of the SV, and decrements the reference count of 8891 whatever was being referenced by the RV. This can almost be thought of 8892 as a reversal of C<newSVrv>. The C<cflags> argument can contain 8893 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented 8894 (otherwise the decrementing is conditional on the reference count being 8895 different from one or the reference being a readonly SV). 8896 See C<SvROK_off>. 8897 8898 =cut 8899 */ 8900 8901 void 8902 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) 8903 { 8904 SV* const target = SvRV(ref); 8905 8906 PERL_ARGS_ASSERT_SV_UNREF_FLAGS; 8907 8908 if (SvWEAKREF(ref)) { 8909 sv_del_backref(target, ref); 8910 SvWEAKREF_off(ref); 8911 SvRV_set(ref, NULL); 8912 return; 8913 } 8914 SvRV_set(ref, NULL); 8915 SvROK_off(ref); 8916 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was 8917 assigned to as BEGIN {$a = \"Foo"} will fail. */ 8918 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) 8919 SvREFCNT_dec(target); 8920 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ 8921 sv_2mortal(target); /* Schedule for freeing later */ 8922 } 8923 8924 /* 8925 =for apidoc sv_untaint 8926 8927 Untaint an SV. Use C<SvTAINTED_off> instead. 8928 =cut 8929 */ 8930 8931 void 8932 Perl_sv_untaint(pTHX_ SV *const sv) 8933 { 8934 PERL_ARGS_ASSERT_SV_UNTAINT; 8935 8936 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 8937 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); 8938 if (mg) 8939 mg->mg_len &= ~1; 8940 } 8941 } 8942 8943 /* 8944 =for apidoc sv_tainted 8945 8946 Test an SV for taintedness. Use C<SvTAINTED> instead. 8947 =cut 8948 */ 8949 8950 bool 8951 Perl_sv_tainted(pTHX_ SV *const sv) 8952 { 8953 PERL_ARGS_ASSERT_SV_TAINTED; 8954 8955 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 8956 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); 8957 if (mg && (mg->mg_len & 1) ) 8958 return TRUE; 8959 } 8960 return FALSE; 8961 } 8962 8963 /* 8964 =for apidoc sv_setpviv 8965 8966 Copies an integer into the given SV, also updating its string value. 8967 Does not handle 'set' magic. See C<sv_setpviv_mg>. 8968 8969 =cut 8970 */ 8971 8972 void 8973 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv) 8974 { 8975 char buf[TYPE_CHARS(UV)]; 8976 char *ebuf; 8977 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); 8978 8979 PERL_ARGS_ASSERT_SV_SETPVIV; 8980 8981 sv_setpvn(sv, ptr, ebuf - ptr); 8982 } 8983 8984 /* 8985 =for apidoc sv_setpviv_mg 8986 8987 Like C<sv_setpviv>, but also handles 'set' magic. 8988 8989 =cut 8990 */ 8991 8992 void 8993 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) 8994 { 8995 PERL_ARGS_ASSERT_SV_SETPVIV_MG; 8996 8997 sv_setpviv(sv, iv); 8998 SvSETMAGIC(sv); 8999 } 9000 9001 #if defined(PERL_IMPLICIT_CONTEXT) 9002 9003 /* pTHX_ magic can't cope with varargs, so this is a no-context 9004 * version of the main function, (which may itself be aliased to us). 9005 * Don't access this version directly. 9006 */ 9007 9008 void 9009 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...) 9010 { 9011 dTHX; 9012 va_list args; 9013 9014 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT; 9015 9016 va_start(args, pat); 9017 sv_vsetpvf(sv, pat, &args); 9018 va_end(args); 9019 } 9020 9021 /* pTHX_ magic can't cope with varargs, so this is a no-context 9022 * version of the main function, (which may itself be aliased to us). 9023 * Don't access this version directly. 9024 */ 9025 9026 void 9027 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) 9028 { 9029 dTHX; 9030 va_list args; 9031 9032 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT; 9033 9034 va_start(args, pat); 9035 sv_vsetpvf_mg(sv, pat, &args); 9036 va_end(args); 9037 } 9038 #endif 9039 9040 /* 9041 =for apidoc sv_setpvf 9042 9043 Works like C<sv_catpvf> but copies the text into the SV instead of 9044 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>. 9045 9046 =cut 9047 */ 9048 9049 void 9050 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...) 9051 { 9052 va_list args; 9053 9054 PERL_ARGS_ASSERT_SV_SETPVF; 9055 9056 va_start(args, pat); 9057 sv_vsetpvf(sv, pat, &args); 9058 va_end(args); 9059 } 9060 9061 /* 9062 =for apidoc sv_vsetpvf 9063 9064 Works like C<sv_vcatpvf> but copies the text into the SV instead of 9065 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>. 9066 9067 Usually used via its frontend C<sv_setpvf>. 9068 9069 =cut 9070 */ 9071 9072 void 9073 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) 9074 { 9075 PERL_ARGS_ASSERT_SV_VSETPVF; 9076 9077 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 9078 } 9079 9080 /* 9081 =for apidoc sv_setpvf_mg 9082 9083 Like C<sv_setpvf>, but also handles 'set' magic. 9084 9085 =cut 9086 */ 9087 9088 void 9089 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) 9090 { 9091 va_list args; 9092 9093 PERL_ARGS_ASSERT_SV_SETPVF_MG; 9094 9095 va_start(args, pat); 9096 sv_vsetpvf_mg(sv, pat, &args); 9097 va_end(args); 9098 } 9099 9100 /* 9101 =for apidoc sv_vsetpvf_mg 9102 9103 Like C<sv_vsetpvf>, but also handles 'set' magic. 9104 9105 Usually used via its frontend C<sv_setpvf_mg>. 9106 9107 =cut 9108 */ 9109 9110 void 9111 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) 9112 { 9113 PERL_ARGS_ASSERT_SV_VSETPVF_MG; 9114 9115 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 9116 SvSETMAGIC(sv); 9117 } 9118 9119 #if defined(PERL_IMPLICIT_CONTEXT) 9120 9121 /* pTHX_ magic can't cope with varargs, so this is a no-context 9122 * version of the main function, (which may itself be aliased to us). 9123 * Don't access this version directly. 9124 */ 9125 9126 void 9127 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) 9128 { 9129 dTHX; 9130 va_list args; 9131 9132 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT; 9133 9134 va_start(args, pat); 9135 sv_vcatpvf(sv, pat, &args); 9136 va_end(args); 9137 } 9138 9139 /* pTHX_ magic can't cope with varargs, so this is a no-context 9140 * version of the main function, (which may itself be aliased to us). 9141 * Don't access this version directly. 9142 */ 9143 9144 void 9145 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) 9146 { 9147 dTHX; 9148 va_list args; 9149 9150 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT; 9151 9152 va_start(args, pat); 9153 sv_vcatpvf_mg(sv, pat, &args); 9154 va_end(args); 9155 } 9156 #endif 9157 9158 /* 9159 =for apidoc sv_catpvf 9160 9161 Processes its arguments like C<sprintf> and appends the formatted 9162 output to an SV. If the appended data contains "wide" characters 9163 (including, but not limited to, SVs with a UTF-8 PV formatted with %s, 9164 and characters >255 formatted with %c), the original SV might get 9165 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See 9166 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be 9167 valid UTF-8; if the original SV was bytes, the pattern should be too. 9168 9169 =cut */ 9170 9171 void 9172 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) 9173 { 9174 va_list args; 9175 9176 PERL_ARGS_ASSERT_SV_CATPVF; 9177 9178 va_start(args, pat); 9179 sv_vcatpvf(sv, pat, &args); 9180 va_end(args); 9181 } 9182 9183 /* 9184 =for apidoc sv_vcatpvf 9185 9186 Processes its arguments like C<vsprintf> and appends the formatted output 9187 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>. 9188 9189 Usually used via its frontend C<sv_catpvf>. 9190 9191 =cut 9192 */ 9193 9194 void 9195 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) 9196 { 9197 PERL_ARGS_ASSERT_SV_VCATPVF; 9198 9199 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 9200 } 9201 9202 /* 9203 =for apidoc sv_catpvf_mg 9204 9205 Like C<sv_catpvf>, but also handles 'set' magic. 9206 9207 =cut 9208 */ 9209 9210 void 9211 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) 9212 { 9213 va_list args; 9214 9215 PERL_ARGS_ASSERT_SV_CATPVF_MG; 9216 9217 va_start(args, pat); 9218 sv_vcatpvf_mg(sv, pat, &args); 9219 va_end(args); 9220 } 9221 9222 /* 9223 =for apidoc sv_vcatpvf_mg 9224 9225 Like C<sv_vcatpvf>, but also handles 'set' magic. 9226 9227 Usually used via its frontend C<sv_catpvf_mg>. 9228 9229 =cut 9230 */ 9231 9232 void 9233 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) 9234 { 9235 PERL_ARGS_ASSERT_SV_VCATPVF_MG; 9236 9237 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 9238 SvSETMAGIC(sv); 9239 } 9240 9241 /* 9242 =for apidoc sv_vsetpvfn 9243 9244 Works like C<sv_vcatpvfn> but copies the text into the SV instead of 9245 appending it. 9246 9247 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>. 9248 9249 =cut 9250 */ 9251 9252 void 9253 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, 9254 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) 9255 { 9256 PERL_ARGS_ASSERT_SV_VSETPVFN; 9257 9258 sv_setpvs(sv, ""); 9259 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); 9260 } 9261 9262 9263 /* 9264 * Warn of missing argument to sprintf, and then return a defined value 9265 * to avoid inappropriate "use of uninit" warnings [perl #71000]. 9266 */ 9267 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ 9268 STATIC SV* 9269 S_vcatpvfn_missing_argument(pTHX) { 9270 if (ckWARN(WARN_MISSING)) { 9271 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", 9272 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); 9273 } 9274 return &PL_sv_no; 9275 } 9276 9277 9278 STATIC I32 9279 S_expect_number(pTHX_ char **const pattern) 9280 { 9281 dVAR; 9282 I32 var = 0; 9283 9284 PERL_ARGS_ASSERT_EXPECT_NUMBER; 9285 9286 switch (**pattern) { 9287 case '1': case '2': case '3': 9288 case '4': case '5': case '6': 9289 case '7': case '8': case '9': 9290 var = *(*pattern)++ - '0'; 9291 while (isDIGIT(**pattern)) { 9292 const I32 tmp = var * 10 + (*(*pattern)++ - '0'); 9293 if (tmp < var) 9294 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn")); 9295 var = tmp; 9296 } 9297 } 9298 return var; 9299 } 9300 9301 STATIC char * 9302 S_F0convert(NV nv, char *const endbuf, STRLEN *const len) 9303 { 9304 const int neg = nv < 0; 9305 UV uv; 9306 9307 PERL_ARGS_ASSERT_F0CONVERT; 9308 9309 if (neg) 9310 nv = -nv; 9311 if (nv < UV_MAX) { 9312 char *p = endbuf; 9313 nv += 0.5; 9314 uv = (UV)nv; 9315 if (uv & 1 && uv == nv) 9316 uv--; /* Round to even */ 9317 do { 9318 const unsigned dig = uv % 10; 9319 *--p = '0' + dig; 9320 } while (uv /= 10); 9321 if (neg) 9322 *--p = '-'; 9323 *len = endbuf - p; 9324 return p; 9325 } 9326 return NULL; 9327 } 9328 9329 9330 /* 9331 =for apidoc sv_vcatpvfn 9332 9333 Processes its arguments like C<vsprintf> and appends the formatted output 9334 to an SV. Uses an array of SVs if the C style variable argument list is 9335 missing (NULL). When running with taint checks enabled, indicates via 9336 C<maybe_tainted> if results are untrustworthy (often due to the use of 9337 locales). 9338 9339 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>. 9340 9341 =cut 9342 */ 9343 9344 9345 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ 9346 vecstr = (U8*)SvPV_const(vecsv,veclen);\ 9347 vec_utf8 = DO_UTF8(vecsv); 9348 9349 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ 9350 9351 void 9352 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, 9353 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) 9354 { 9355 dVAR; 9356 char *p; 9357 char *q; 9358 const char *patend; 9359 STRLEN origlen; 9360 I32 svix = 0; 9361 static const char nullstr[] = "(null)"; 9362 SV *argsv = NULL; 9363 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */ 9364 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */ 9365 SV *nsv = NULL; 9366 /* Times 4: a decimal digit takes more than 3 binary digits. 9367 * NV_DIG: mantissa takes than many decimal digits. 9368 * Plus 32: Playing safe. */ 9369 char ebuf[IV_DIG * 4 + NV_DIG + 32]; 9370 /* large enough for "%#.#f" --chip */ 9371 /* what about long double NVs? --jhi */ 9372 9373 PERL_ARGS_ASSERT_SV_VCATPVFN; 9374 PERL_UNUSED_ARG(maybe_tainted); 9375 9376 /* no matter what, this is a string now */ 9377 (void)SvPV_force(sv, origlen); 9378 9379 /* special-case "", "%s", and "%-p" (SVf - see below) */ 9380 if (patlen == 0) 9381 return; 9382 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { 9383 if (args) { 9384 const char * const s = va_arg(*args, char*); 9385 sv_catpv(sv, s ? s : nullstr); 9386 } 9387 else if (svix < svmax) { 9388 sv_catsv(sv, *svargs); 9389 } 9390 return; 9391 } 9392 if (args && patlen == 3 && pat[0] == '%' && 9393 pat[1] == '-' && pat[2] == 'p') { 9394 argsv = MUTABLE_SV(va_arg(*args, void*)); 9395 sv_catsv(sv, argsv); 9396 return; 9397 } 9398 9399 #ifndef USE_LONG_DOUBLE 9400 /* special-case "%.<number>[gf]" */ 9401 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' 9402 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { 9403 unsigned digits = 0; 9404 const char *pp; 9405 9406 pp = pat + 2; 9407 while (*pp >= '0' && *pp <= '9') 9408 digits = 10 * digits + (*pp++ - '0'); 9409 if (pp - pat == (int)patlen - 1) { 9410 NV nv; 9411 9412 if (svix < svmax) 9413 nv = SvNV(*svargs); 9414 else 9415 return; 9416 if (*pp == 'g') { 9417 /* Add check for digits != 0 because it seems that some 9418 gconverts are buggy in this case, and we don't yet have 9419 a Configure test for this. */ 9420 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { 9421 /* 0, point, slack */ 9422 Gconvert(nv, (int)digits, 0, ebuf); 9423 sv_catpv(sv, ebuf); 9424 if (*ebuf) /* May return an empty string for digits==0 */ 9425 return; 9426 } 9427 } else if (!digits) { 9428 STRLEN l; 9429 9430 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { 9431 sv_catpvn(sv, p, l); 9432 return; 9433 } 9434 } 9435 } 9436 } 9437 #endif /* !USE_LONG_DOUBLE */ 9438 9439 if (!args && svix < svmax && DO_UTF8(*svargs)) 9440 has_utf8 = TRUE; 9441 9442 patend = (char*)pat + patlen; 9443 for (p = (char*)pat; p < patend; p = q) { 9444 bool alt = FALSE; 9445 bool left = FALSE; 9446 bool vectorize = FALSE; 9447 bool vectorarg = FALSE; 9448 bool vec_utf8 = FALSE; 9449 char fill = ' '; 9450 char plus = 0; 9451 char intsize = 0; 9452 STRLEN width = 0; 9453 STRLEN zeros = 0; 9454 bool has_precis = FALSE; 9455 STRLEN precis = 0; 9456 const I32 osvix = svix; 9457 bool is_utf8 = FALSE; /* is this item utf8? */ 9458 #ifdef HAS_LDBL_SPRINTF_BUG 9459 /* This is to try to fix a bug with irix/nonstop-ux/powerux and 9460 with sfio - Allen <allens@cpan.org> */ 9461 bool fix_ldbl_sprintf_bug = FALSE; 9462 #endif 9463 9464 char esignbuf[4]; 9465 U8 utf8buf[UTF8_MAXBYTES+1]; 9466 STRLEN esignlen = 0; 9467 9468 const char *eptr = NULL; 9469 const char *fmtstart; 9470 STRLEN elen = 0; 9471 SV *vecsv = NULL; 9472 const U8 *vecstr = NULL; 9473 STRLEN veclen = 0; 9474 char c = 0; 9475 int i; 9476 unsigned base = 0; 9477 IV iv = 0; 9478 UV uv = 0; 9479 /* we need a long double target in case HAS_LONG_DOUBLE but 9480 not USE_LONG_DOUBLE 9481 */ 9482 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE 9483 long double nv; 9484 #else 9485 NV nv; 9486 #endif 9487 STRLEN have; 9488 STRLEN need; 9489 STRLEN gap; 9490 const char *dotstr = "."; 9491 STRLEN dotstrlen = 1; 9492 I32 efix = 0; /* explicit format parameter index */ 9493 I32 ewix = 0; /* explicit width index */ 9494 I32 epix = 0; /* explicit precision index */ 9495 I32 evix = 0; /* explicit vector index */ 9496 bool asterisk = FALSE; 9497 9498 /* echo everything up to the next format specification */ 9499 for (q = p; q < patend && *q != '%'; ++q) ; 9500 if (q > p) { 9501 if (has_utf8 && !pat_utf8) 9502 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv); 9503 else 9504 sv_catpvn(sv, p, q - p); 9505 p = q; 9506 } 9507 if (q++ >= patend) 9508 break; 9509 9510 fmtstart = q; 9511 9512 /* 9513 We allow format specification elements in this order: 9514 \d+\$ explicit format parameter index 9515 [-+ 0#]+ flags 9516 v|\*(\d+\$)?v vector with optional (optionally specified) arg 9517 0 flag (as above): repeated to allow "v02" 9518 \d+|\*(\d+\$)? width using optional (optionally specified) arg 9519 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg 9520 [hlqLV] size 9521 [%bcdefginopsuxDFOUX] format (mandatory) 9522 */ 9523 9524 if (args) { 9525 /* 9526 As of perl5.9.3, printf format checking is on by default. 9527 Internally, perl uses %p formats to provide an escape to 9528 some extended formatting. This block deals with those 9529 extensions: if it does not match, (char*)q is reset and 9530 the normal format processing code is used. 9531 9532 Currently defined extensions are: 9533 %p include pointer address (standard) 9534 %-p (SVf) include an SV (previously %_) 9535 %-<num>p include an SV with precision <num> 9536 %<num>p reserved for future extensions 9537 9538 Robin Barker 2005-07-14 9539 9540 %1p (VDf) removed. RMB 2007-10-19 9541 */ 9542 char* r = q; 9543 bool sv = FALSE; 9544 STRLEN n = 0; 9545 if (*q == '-') 9546 sv = *q++; 9547 n = expect_number(&q); 9548 if (*q++ == 'p') { 9549 if (sv) { /* SVf */ 9550 if (n) { 9551 precis = n; 9552 has_precis = TRUE; 9553 } 9554 argsv = MUTABLE_SV(va_arg(*args, void*)); 9555 eptr = SvPV_const(argsv, elen); 9556 if (DO_UTF8(argsv)) 9557 is_utf8 = TRUE; 9558 goto string; 9559 } 9560 else if (n) { 9561 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 9562 "internal %%<num>p might conflict with future printf extensions"); 9563 } 9564 } 9565 q = r; 9566 } 9567 9568 if ( (width = expect_number(&q)) ) { 9569 if (*q == '$') { 9570 ++q; 9571 efix = width; 9572 } else { 9573 goto gotwidth; 9574 } 9575 } 9576 9577 /* FLAGS */ 9578 9579 while (*q) { 9580 switch (*q) { 9581 case ' ': 9582 case '+': 9583 if (plus == '+' && *q == ' ') /* '+' over ' ' */ 9584 q++; 9585 else 9586 plus = *q++; 9587 continue; 9588 9589 case '-': 9590 left = TRUE; 9591 q++; 9592 continue; 9593 9594 case '0': 9595 fill = *q++; 9596 continue; 9597 9598 case '#': 9599 alt = TRUE; 9600 q++; 9601 continue; 9602 9603 default: 9604 break; 9605 } 9606 break; 9607 } 9608 9609 tryasterisk: 9610 if (*q == '*') { 9611 q++; 9612 if ( (ewix = expect_number(&q)) ) 9613 if (*q++ != '$') 9614 goto unknown; 9615 asterisk = TRUE; 9616 } 9617 if (*q == 'v') { 9618 q++; 9619 if (vectorize) 9620 goto unknown; 9621 if ((vectorarg = asterisk)) { 9622 evix = ewix; 9623 ewix = 0; 9624 asterisk = FALSE; 9625 } 9626 vectorize = TRUE; 9627 goto tryasterisk; 9628 } 9629 9630 if (!asterisk) 9631 { 9632 if( *q == '0' ) 9633 fill = *q++; 9634 width = expect_number(&q); 9635 } 9636 9637 if (vectorize) { 9638 if (vectorarg) { 9639 if (args) 9640 vecsv = va_arg(*args, SV*); 9641 else if (evix) { 9642 vecsv = (evix > 0 && evix <= svmax) 9643 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); 9644 } else { 9645 vecsv = svix < svmax 9646 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); 9647 } 9648 dotstr = SvPV_const(vecsv, dotstrlen); 9649 /* Keep the DO_UTF8 test *after* the SvPV call, else things go 9650 bad with tied or overloaded values that return UTF8. */ 9651 if (DO_UTF8(vecsv)) 9652 is_utf8 = TRUE; 9653 else if (has_utf8) { 9654 vecsv = sv_mortalcopy(vecsv); 9655 sv_utf8_upgrade(vecsv); 9656 dotstr = SvPV_const(vecsv, dotstrlen); 9657 is_utf8 = TRUE; 9658 } 9659 } 9660 if (args) { 9661 VECTORIZE_ARGS 9662 } 9663 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { 9664 vecsv = svargs[efix ? efix-1 : svix++]; 9665 vecstr = (U8*)SvPV_const(vecsv,veclen); 9666 vec_utf8 = DO_UTF8(vecsv); 9667 9668 /* if this is a version object, we need to convert 9669 * back into v-string notation and then let the 9670 * vectorize happen normally 9671 */ 9672 if (sv_derived_from(vecsv, "version")) { 9673 char *version = savesvpv(vecsv); 9674 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { 9675 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 9676 "vector argument not supported with alpha versions"); 9677 goto unknown; 9678 } 9679 vecsv = sv_newmortal(); 9680 scan_vstring(version, version + veclen, vecsv); 9681 vecstr = (U8*)SvPV_const(vecsv, veclen); 9682 vec_utf8 = DO_UTF8(vecsv); 9683 Safefree(version); 9684 } 9685 } 9686 else { 9687 vecstr = (U8*)""; 9688 veclen = 0; 9689 } 9690 } 9691 9692 if (asterisk) { 9693 if (args) 9694 i = va_arg(*args, int); 9695 else 9696 i = (ewix ? ewix <= svmax : svix < svmax) ? 9697 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; 9698 left |= (i < 0); 9699 width = (i < 0) ? -i : i; 9700 } 9701 gotwidth: 9702 9703 /* PRECISION */ 9704 9705 if (*q == '.') { 9706 q++; 9707 if (*q == '*') { 9708 q++; 9709 if ( ((epix = expect_number(&q))) && (*q++ != '$') ) 9710 goto unknown; 9711 /* XXX: todo, support specified precision parameter */ 9712 if (epix) 9713 goto unknown; 9714 if (args) 9715 i = va_arg(*args, int); 9716 else 9717 i = (ewix ? ewix <= svmax : svix < svmax) 9718 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; 9719 precis = i; 9720 has_precis = !(i < 0); 9721 } 9722 else { 9723 precis = 0; 9724 while (isDIGIT(*q)) 9725 precis = precis * 10 + (*q++ - '0'); 9726 has_precis = TRUE; 9727 } 9728 } 9729 9730 /* SIZE */ 9731 9732 switch (*q) { 9733 #ifdef WIN32 9734 case 'I': /* Ix, I32x, and I64x */ 9735 # ifdef WIN64 9736 if (q[1] == '6' && q[2] == '4') { 9737 q += 3; 9738 intsize = 'q'; 9739 break; 9740 } 9741 # endif 9742 if (q[1] == '3' && q[2] == '2') { 9743 q += 3; 9744 break; 9745 } 9746 # ifdef WIN64 9747 intsize = 'q'; 9748 # endif 9749 q++; 9750 break; 9751 #endif 9752 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) 9753 case 'L': /* Ld */ 9754 /*FALLTHROUGH*/ 9755 #ifdef HAS_QUAD 9756 case 'q': /* qd */ 9757 #endif 9758 intsize = 'q'; 9759 q++; 9760 break; 9761 #endif 9762 case 'l': 9763 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) 9764 if (*(q + 1) == 'l') { /* lld, llf */ 9765 intsize = 'q'; 9766 q += 2; 9767 break; 9768 } 9769 #endif 9770 /*FALLTHROUGH*/ 9771 case 'h': 9772 /*FALLTHROUGH*/ 9773 case 'V': 9774 intsize = *q++; 9775 break; 9776 } 9777 9778 /* CONVERSION */ 9779 9780 if (*q == '%') { 9781 eptr = q++; 9782 elen = 1; 9783 if (vectorize) { 9784 c = '%'; 9785 goto unknown; 9786 } 9787 goto string; 9788 } 9789 9790 if (!vectorize && !args) { 9791 if (efix) { 9792 const I32 i = efix-1; 9793 argsv = (i >= 0 && i < svmax) 9794 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX); 9795 } else { 9796 argsv = (svix >= 0 && svix < svmax) 9797 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); 9798 } 9799 } 9800 9801 switch (c = *q++) { 9802 9803 /* STRINGS */ 9804 9805 case 'c': 9806 if (vectorize) 9807 goto unknown; 9808 uv = (args) ? va_arg(*args, int) : SvIV(argsv); 9809 if ((uv > 255 || 9810 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) 9811 && !IN_BYTES) { 9812 eptr = (char*)utf8buf; 9813 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; 9814 is_utf8 = TRUE; 9815 } 9816 else { 9817 c = (char)uv; 9818 eptr = &c; 9819 elen = 1; 9820 } 9821 goto string; 9822 9823 case 's': 9824 if (vectorize) 9825 goto unknown; 9826 if (args) { 9827 eptr = va_arg(*args, char*); 9828 if (eptr) 9829 elen = strlen(eptr); 9830 else { 9831 eptr = (char *)nullstr; 9832 elen = sizeof nullstr - 1; 9833 } 9834 } 9835 else { 9836 eptr = SvPV_const(argsv, elen); 9837 if (DO_UTF8(argsv)) { 9838 STRLEN old_precis = precis; 9839 if (has_precis && precis < elen) { 9840 STRLEN ulen = sv_len_utf8(argsv); 9841 I32 p = precis > ulen ? ulen : precis; 9842 sv_pos_u2b(argsv, &p, 0); /* sticks at end */ 9843 precis = p; 9844 } 9845 if (width) { /* fudge width (can't fudge elen) */ 9846 if (has_precis && precis < elen) 9847 width += precis - old_precis; 9848 else 9849 width += elen - sv_len_utf8(argsv); 9850 } 9851 is_utf8 = TRUE; 9852 } 9853 } 9854 9855 string: 9856 if (has_precis && precis < elen) 9857 elen = precis; 9858 break; 9859 9860 /* INTEGERS */ 9861 9862 case 'p': 9863 if (alt || vectorize) 9864 goto unknown; 9865 uv = PTR2UV(args ? va_arg(*args, void*) : argsv); 9866 base = 16; 9867 goto integer; 9868 9869 case 'D': 9870 #ifdef IV_IS_QUAD 9871 intsize = 'q'; 9872 #else 9873 intsize = 'l'; 9874 #endif 9875 /*FALLTHROUGH*/ 9876 case 'd': 9877 case 'i': 9878 #if vdNUMBER 9879 format_vd: 9880 #endif 9881 if (vectorize) { 9882 STRLEN ulen; 9883 if (!veclen) 9884 continue; 9885 if (vec_utf8) 9886 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 9887 UTF8_ALLOW_ANYUV); 9888 else { 9889 uv = *vecstr; 9890 ulen = 1; 9891 } 9892 vecstr += ulen; 9893 veclen -= ulen; 9894 if (plus) 9895 esignbuf[esignlen++] = plus; 9896 } 9897 else if (args) { 9898 switch (intsize) { 9899 case 'h': iv = (short)va_arg(*args, int); break; 9900 case 'l': iv = va_arg(*args, long); break; 9901 case 'V': iv = va_arg(*args, IV); break; 9902 default: iv = va_arg(*args, int); break; 9903 case 'q': 9904 #ifdef HAS_QUAD 9905 iv = va_arg(*args, Quad_t); break; 9906 #else 9907 goto unknown; 9908 #endif 9909 } 9910 } 9911 else { 9912 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ 9913 switch (intsize) { 9914 case 'h': iv = (short)tiv; break; 9915 case 'l': iv = (long)tiv; break; 9916 case 'V': 9917 default: iv = tiv; break; 9918 case 'q': 9919 #ifdef HAS_QUAD 9920 iv = (Quad_t)tiv; break; 9921 #else 9922 goto unknown; 9923 #endif 9924 } 9925 } 9926 if ( !vectorize ) /* we already set uv above */ 9927 { 9928 if (iv >= 0) { 9929 uv = iv; 9930 if (plus) 9931 esignbuf[esignlen++] = plus; 9932 } 9933 else { 9934 uv = -iv; 9935 esignbuf[esignlen++] = '-'; 9936 } 9937 } 9938 base = 10; 9939 goto integer; 9940 9941 case 'U': 9942 #ifdef IV_IS_QUAD 9943 intsize = 'q'; 9944 #else 9945 intsize = 'l'; 9946 #endif 9947 /*FALLTHROUGH*/ 9948 case 'u': 9949 base = 10; 9950 goto uns_integer; 9951 9952 case 'B': 9953 case 'b': 9954 base = 2; 9955 goto uns_integer; 9956 9957 case 'O': 9958 #ifdef IV_IS_QUAD 9959 intsize = 'q'; 9960 #else 9961 intsize = 'l'; 9962 #endif 9963 /*FALLTHROUGH*/ 9964 case 'o': 9965 base = 8; 9966 goto uns_integer; 9967 9968 case 'X': 9969 case 'x': 9970 base = 16; 9971 9972 uns_integer: 9973 if (vectorize) { 9974 STRLEN ulen; 9975 vector: 9976 if (!veclen) 9977 continue; 9978 if (vec_utf8) 9979 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 9980 UTF8_ALLOW_ANYUV); 9981 else { 9982 uv = *vecstr; 9983 ulen = 1; 9984 } 9985 vecstr += ulen; 9986 veclen -= ulen; 9987 } 9988 else if (args) { 9989 switch (intsize) { 9990 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; 9991 case 'l': uv = va_arg(*args, unsigned long); break; 9992 case 'V': uv = va_arg(*args, UV); break; 9993 default: uv = va_arg(*args, unsigned); break; 9994 case 'q': 9995 #ifdef HAS_QUAD 9996 uv = va_arg(*args, Uquad_t); break; 9997 #else 9998 goto unknown; 9999 #endif 10000 } 10001 } 10002 else { 10003 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ 10004 switch (intsize) { 10005 case 'h': uv = (unsigned short)tuv; break; 10006 case 'l': uv = (unsigned long)tuv; break; 10007 case 'V': 10008 default: uv = tuv; break; 10009 case 'q': 10010 #ifdef HAS_QUAD 10011 uv = (Uquad_t)tuv; break; 10012 #else 10013 goto unknown; 10014 #endif 10015 } 10016 } 10017 10018 integer: 10019 { 10020 char *ptr = ebuf + sizeof ebuf; 10021 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ 10022 zeros = 0; 10023 10024 switch (base) { 10025 unsigned dig; 10026 case 16: 10027 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); 10028 do { 10029 dig = uv & 15; 10030 *--ptr = p[dig]; 10031 } while (uv >>= 4); 10032 if (tempalt) { 10033 esignbuf[esignlen++] = '0'; 10034 esignbuf[esignlen++] = c; /* 'x' or 'X' */ 10035 } 10036 break; 10037 case 8: 10038 do { 10039 dig = uv & 7; 10040 *--ptr = '0' + dig; 10041 } while (uv >>= 3); 10042 if (alt && *ptr != '0') 10043 *--ptr = '0'; 10044 break; 10045 case 2: 10046 do { 10047 dig = uv & 1; 10048 *--ptr = '0' + dig; 10049 } while (uv >>= 1); 10050 if (tempalt) { 10051 esignbuf[esignlen++] = '0'; 10052 esignbuf[esignlen++] = c; 10053 } 10054 break; 10055 default: /* it had better be ten or less */ 10056 do { 10057 dig = uv % base; 10058 *--ptr = '0' + dig; 10059 } while (uv /= base); 10060 break; 10061 } 10062 elen = (ebuf + sizeof ebuf) - ptr; 10063 eptr = ptr; 10064 if (has_precis) { 10065 if (precis > elen) 10066 zeros = precis - elen; 10067 else if (precis == 0 && elen == 1 && *eptr == '0' 10068 && !(base == 8 && alt)) /* "%#.0o" prints "0" */ 10069 elen = 0; 10070 10071 /* a precision nullifies the 0 flag. */ 10072 if (fill == '0') 10073 fill = ' '; 10074 } 10075 } 10076 break; 10077 10078 /* FLOATING POINT */ 10079 10080 case 'F': 10081 c = 'f'; /* maybe %F isn't supported here */ 10082 /*FALLTHROUGH*/ 10083 case 'e': case 'E': 10084 case 'f': 10085 case 'g': case 'G': 10086 if (vectorize) 10087 goto unknown; 10088 10089 /* This is evil, but floating point is even more evil */ 10090 10091 /* for SV-style calling, we can only get NV 10092 for C-style calling, we assume %f is double; 10093 for simplicity we allow any of %Lf, %llf, %qf for long double 10094 */ 10095 switch (intsize) { 10096 case 'V': 10097 #if defined(USE_LONG_DOUBLE) 10098 intsize = 'q'; 10099 #endif 10100 break; 10101 /* [perl #20339] - we should accept and ignore %lf rather than die */ 10102 case 'l': 10103 /*FALLTHROUGH*/ 10104 default: 10105 #if defined(USE_LONG_DOUBLE) 10106 intsize = args ? 0 : 'q'; 10107 #endif 10108 break; 10109 case 'q': 10110 #if defined(HAS_LONG_DOUBLE) 10111 break; 10112 #else 10113 /*FALLTHROUGH*/ 10114 #endif 10115 case 'h': 10116 goto unknown; 10117 } 10118 10119 /* now we need (long double) if intsize == 'q', else (double) */ 10120 nv = (args) ? 10121 #if LONG_DOUBLESIZE > DOUBLESIZE 10122 intsize == 'q' ? 10123 va_arg(*args, long double) : 10124 va_arg(*args, double) 10125 #else 10126 va_arg(*args, double) 10127 #endif 10128 : SvNV(argsv); 10129 10130 need = 0; 10131 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything 10132 else. frexp() has some unspecified behaviour for those three */ 10133 if (c != 'e' && c != 'E' && (nv * 0) == 0) { 10134 i = PERL_INT_MIN; 10135 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this 10136 will cast our (long double) to (double) */ 10137 (void)Perl_frexp(nv, &i); 10138 if (i == PERL_INT_MIN) 10139 Perl_die(aTHX_ "panic: frexp"); 10140 if (i > 0) 10141 need = BIT_DIGITS(i); 10142 } 10143 need += has_precis ? precis : 6; /* known default */ 10144 10145 if (need < width) 10146 need = width; 10147 10148 #ifdef HAS_LDBL_SPRINTF_BUG 10149 /* This is to try to fix a bug with irix/nonstop-ux/powerux and 10150 with sfio - Allen <allens@cpan.org> */ 10151 10152 # ifdef DBL_MAX 10153 # define MY_DBL_MAX DBL_MAX 10154 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ 10155 # if DOUBLESIZE >= 8 10156 # define MY_DBL_MAX 1.7976931348623157E+308L 10157 # else 10158 # define MY_DBL_MAX 3.40282347E+38L 10159 # endif 10160 # endif 10161 10162 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */ 10163 # define MY_DBL_MAX_BUG 1L 10164 # else 10165 # define MY_DBL_MAX_BUG MY_DBL_MAX 10166 # endif 10167 10168 # ifdef DBL_MIN 10169 # define MY_DBL_MIN DBL_MIN 10170 # else /* XXX guessing! -Allen */ 10171 # if DOUBLESIZE >= 8 10172 # define MY_DBL_MIN 2.2250738585072014E-308L 10173 # else 10174 # define MY_DBL_MIN 1.17549435E-38L 10175 # endif 10176 # endif 10177 10178 if ((intsize == 'q') && (c == 'f') && 10179 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && 10180 (need < DBL_DIG)) { 10181 /* it's going to be short enough that 10182 * long double precision is not needed */ 10183 10184 if ((nv <= 0L) && (nv >= -0L)) 10185 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ 10186 else { 10187 /* would use Perl_fp_class as a double-check but not 10188 * functional on IRIX - see perl.h comments */ 10189 10190 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { 10191 /* It's within the range that a double can represent */ 10192 #if defined(DBL_MAX) && !defined(DBL_MIN) 10193 if ((nv >= ((long double)1/DBL_MAX)) || 10194 (nv <= (-(long double)1/DBL_MAX))) 10195 #endif 10196 fix_ldbl_sprintf_bug = TRUE; 10197 } 10198 } 10199 if (fix_ldbl_sprintf_bug == TRUE) { 10200 double temp; 10201 10202 intsize = 0; 10203 temp = (double)nv; 10204 nv = (NV)temp; 10205 } 10206 } 10207 10208 # undef MY_DBL_MAX 10209 # undef MY_DBL_MAX_BUG 10210 # undef MY_DBL_MIN 10211 10212 #endif /* HAS_LDBL_SPRINTF_BUG */ 10213 10214 need += 20; /* fudge factor */ 10215 if (PL_efloatsize < need) { 10216 Safefree(PL_efloatbuf); 10217 PL_efloatsize = need + 20; /* more fudge */ 10218 Newx(PL_efloatbuf, PL_efloatsize, char); 10219 PL_efloatbuf[0] = '\0'; 10220 } 10221 10222 if ( !(width || left || plus || alt) && fill != '0' 10223 && has_precis && intsize != 'q' ) { /* Shortcuts */ 10224 /* See earlier comment about buggy Gconvert when digits, 10225 aka precis is 0 */ 10226 if ( c == 'g' && precis) { 10227 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); 10228 /* May return an empty string for digits==0 */ 10229 if (*PL_efloatbuf) { 10230 elen = strlen(PL_efloatbuf); 10231 goto float_converted; 10232 } 10233 } else if ( c == 'f' && !precis) { 10234 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) 10235 break; 10236 } 10237 } 10238 { 10239 char *ptr = ebuf + sizeof ebuf; 10240 *--ptr = '\0'; 10241 *--ptr = c; 10242 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ 10243 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) 10244 if (intsize == 'q') { 10245 /* Copy the one or more characters in a long double 10246 * format before the 'base' ([efgEFG]) character to 10247 * the format string. */ 10248 static char const prifldbl[] = PERL_PRIfldbl; 10249 char const *p = prifldbl + sizeof(prifldbl) - 3; 10250 while (p >= prifldbl) { *--ptr = *p--; } 10251 } 10252 #endif 10253 if (has_precis) { 10254 base = precis; 10255 do { *--ptr = '0' + (base % 10); } while (base /= 10); 10256 *--ptr = '.'; 10257 } 10258 if (width) { 10259 base = width; 10260 do { *--ptr = '0' + (base % 10); } while (base /= 10); 10261 } 10262 if (fill == '0') 10263 *--ptr = fill; 10264 if (left) 10265 *--ptr = '-'; 10266 if (plus) 10267 *--ptr = plus; 10268 if (alt) 10269 *--ptr = '#'; 10270 *--ptr = '%'; 10271 10272 /* No taint. Otherwise we are in the strange situation 10273 * where printf() taints but print($float) doesn't. 10274 * --jhi */ 10275 #if defined(HAS_LONG_DOUBLE) 10276 elen = ((intsize == 'q') 10277 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) 10278 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); 10279 #else 10280 elen = my_sprintf(PL_efloatbuf, ptr, nv); 10281 #endif 10282 } 10283 float_converted: 10284 eptr = PL_efloatbuf; 10285 break; 10286 10287 /* SPECIAL */ 10288 10289 case 'n': 10290 if (vectorize) 10291 goto unknown; 10292 i = SvCUR(sv) - origlen; 10293 if (args) { 10294 switch (intsize) { 10295 case 'h': *(va_arg(*args, short*)) = i; break; 10296 default: *(va_arg(*args, int*)) = i; break; 10297 case 'l': *(va_arg(*args, long*)) = i; break; 10298 case 'V': *(va_arg(*args, IV*)) = i; break; 10299 case 'q': 10300 #ifdef HAS_QUAD 10301 *(va_arg(*args, Quad_t*)) = i; break; 10302 #else 10303 goto unknown; 10304 #endif 10305 } 10306 } 10307 else 10308 sv_setuv_mg(argsv, (UV)i); 10309 continue; /* not "break" */ 10310 10311 /* UNKNOWN */ 10312 10313 default: 10314 unknown: 10315 if (!args 10316 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) 10317 && ckWARN(WARN_PRINTF)) 10318 { 10319 SV * const msg = sv_newmortal(); 10320 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", 10321 (PL_op->op_type == OP_PRTF) ? "" : "s"); 10322 if (fmtstart < patend) { 10323 const char * const fmtend = q < patend ? q : patend; 10324 const char * f; 10325 sv_catpvs(msg, "\"%"); 10326 for (f = fmtstart; f < fmtend; f++) { 10327 if (isPRINT(*f)) { 10328 sv_catpvn(msg, f, 1); 10329 } else { 10330 Perl_sv_catpvf(aTHX_ msg, 10331 "\\%03"UVof, (UV)*f & 0xFF); 10332 } 10333 } 10334 sv_catpvs(msg, "\""); 10335 } else { 10336 sv_catpvs(msg, "end of string"); 10337 } 10338 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ 10339 } 10340 10341 /* output mangled stuff ... */ 10342 if (c == '\0') 10343 --q; 10344 eptr = p; 10345 elen = q - p; 10346 10347 /* ... right here, because formatting flags should not apply */ 10348 SvGROW(sv, SvCUR(sv) + elen + 1); 10349 p = SvEND(sv); 10350 Copy(eptr, p, elen, char); 10351 p += elen; 10352 *p = '\0'; 10353 SvCUR_set(sv, p - SvPVX_const(sv)); 10354 svix = osvix; 10355 continue; /* not "break" */ 10356 } 10357 10358 if (is_utf8 != has_utf8) { 10359 if (is_utf8) { 10360 if (SvCUR(sv)) 10361 sv_utf8_upgrade(sv); 10362 } 10363 else { 10364 const STRLEN old_elen = elen; 10365 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); 10366 sv_utf8_upgrade(nsv); 10367 eptr = SvPVX_const(nsv); 10368 elen = SvCUR(nsv); 10369 10370 if (width) { /* fudge width (can't fudge elen) */ 10371 width += elen - old_elen; 10372 } 10373 is_utf8 = TRUE; 10374 } 10375 } 10376 10377 have = esignlen + zeros + elen; 10378 if (have < zeros) 10379 Perl_croak_nocontext("%s", PL_memory_wrap); 10380 10381 need = (have > width ? have : width); 10382 gap = need - have; 10383 10384 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) 10385 Perl_croak_nocontext("%s", PL_memory_wrap); 10386 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); 10387 p = SvEND(sv); 10388 if (esignlen && fill == '0') { 10389 int i; 10390 for (i = 0; i < (int)esignlen; i++) 10391 *p++ = esignbuf[i]; 10392 } 10393 if (gap && !left) { 10394 memset(p, fill, gap); 10395 p += gap; 10396 } 10397 if (esignlen && fill != '0') { 10398 int i; 10399 for (i = 0; i < (int)esignlen; i++) 10400 *p++ = esignbuf[i]; 10401 } 10402 if (zeros) { 10403 int i; 10404 for (i = zeros; i; i--) 10405 *p++ = '0'; 10406 } 10407 if (elen) { 10408 Copy(eptr, p, elen, char); 10409 p += elen; 10410 } 10411 if (gap && left) { 10412 memset(p, ' ', gap); 10413 p += gap; 10414 } 10415 if (vectorize) { 10416 if (veclen) { 10417 Copy(dotstr, p, dotstrlen, char); 10418 p += dotstrlen; 10419 } 10420 else 10421 vectorize = FALSE; /* done iterating over vecstr */ 10422 } 10423 if (is_utf8) 10424 has_utf8 = TRUE; 10425 if (has_utf8) 10426 SvUTF8_on(sv); 10427 *p = '\0'; 10428 SvCUR_set(sv, p - SvPVX_const(sv)); 10429 if (vectorize) { 10430 esignlen = 0; 10431 goto vector; 10432 } 10433 } 10434 } 10435 10436 /* ========================================================================= 10437 10438 =head1 Cloning an interpreter 10439 10440 All the macros and functions in this section are for the private use of 10441 the main function, perl_clone(). 10442 10443 The foo_dup() functions make an exact copy of an existing foo thingy. 10444 During the course of a cloning, a hash table is used to map old addresses 10445 to new addresses. The table is created and manipulated with the 10446 ptr_table_* functions. 10447 10448 =cut 10449 10450 * =========================================================================*/ 10451 10452 10453 #if defined(USE_ITHREADS) 10454 10455 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */ 10456 #ifndef GpREFCNT_inc 10457 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) 10458 #endif 10459 10460 10461 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact 10462 that currently av_dup, gv_dup and hv_dup are the same as sv_dup. 10463 If this changes, please unmerge ss_dup. 10464 Likewise, sv_dup_inc_multiple() relies on this fact. */ 10465 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) 10466 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) 10467 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) 10468 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t))) 10469 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) 10470 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t))) 10471 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) 10472 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t))) 10473 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) 10474 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t))) 10475 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) 10476 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t))) 10477 #define SAVEPV(p) ((p) ? savepv(p) : NULL) 10478 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) 10479 10480 /* clone a parser */ 10481 10482 yy_parser * 10483 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) 10484 { 10485 yy_parser *parser; 10486 10487 PERL_ARGS_ASSERT_PARSER_DUP; 10488 10489 if (!proto) 10490 return NULL; 10491 10492 /* look for it in the table first */ 10493 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); 10494 if (parser) 10495 return parser; 10496 10497 /* create anew and remember what it is */ 10498 Newxz(parser, 1, yy_parser); 10499 ptr_table_store(PL_ptr_table, proto, parser); 10500 10501 parser->yyerrstatus = 0; 10502 parser->yychar = YYEMPTY; /* Cause a token to be read. */ 10503 10504 /* XXX these not yet duped */ 10505 parser->old_parser = NULL; 10506 parser->stack = NULL; 10507 parser->ps = NULL; 10508 parser->stack_size = 0; 10509 /* XXX parser->stack->state = 0; */ 10510 10511 /* XXX eventually, just Copy() most of the parser struct ? */ 10512 10513 parser->lex_brackets = proto->lex_brackets; 10514 parser->lex_casemods = proto->lex_casemods; 10515 parser->lex_brackstack = savepvn(proto->lex_brackstack, 10516 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); 10517 parser->lex_casestack = savepvn(proto->lex_casestack, 10518 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); 10519 parser->lex_defer = proto->lex_defer; 10520 parser->lex_dojoin = proto->lex_dojoin; 10521 parser->lex_expect = proto->lex_expect; 10522 parser->lex_formbrack = proto->lex_formbrack; 10523 parser->lex_inpat = proto->lex_inpat; 10524 parser->lex_inwhat = proto->lex_inwhat; 10525 parser->lex_op = proto->lex_op; 10526 parser->lex_repl = sv_dup_inc(proto->lex_repl, param); 10527 parser->lex_starts = proto->lex_starts; 10528 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param); 10529 parser->multi_close = proto->multi_close; 10530 parser->multi_open = proto->multi_open; 10531 parser->multi_start = proto->multi_start; 10532 parser->multi_end = proto->multi_end; 10533 parser->pending_ident = proto->pending_ident; 10534 parser->preambled = proto->preambled; 10535 parser->sublex_info = proto->sublex_info; /* XXX not quite right */ 10536 parser->linestr = sv_dup_inc(proto->linestr, param); 10537 parser->expect = proto->expect; 10538 parser->copline = proto->copline; 10539 parser->last_lop_op = proto->last_lop_op; 10540 parser->lex_state = proto->lex_state; 10541 parser->rsfp = fp_dup(proto->rsfp, '<', param); 10542 /* rsfp_filters entries have fake IoDIRP() */ 10543 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); 10544 parser->in_my = proto->in_my; 10545 parser->in_my_stash = hv_dup(proto->in_my_stash, param); 10546 parser->error_count = proto->error_count; 10547 10548 10549 parser->linestr = sv_dup_inc(proto->linestr, param); 10550 10551 { 10552 char * const ols = SvPVX(proto->linestr); 10553 char * const ls = SvPVX(parser->linestr); 10554 10555 parser->bufptr = ls + (proto->bufptr >= ols ? 10556 proto->bufptr - ols : 0); 10557 parser->oldbufptr = ls + (proto->oldbufptr >= ols ? 10558 proto->oldbufptr - ols : 0); 10559 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? 10560 proto->oldoldbufptr - ols : 0); 10561 parser->linestart = ls + (proto->linestart >= ols ? 10562 proto->linestart - ols : 0); 10563 parser->last_uni = ls + (proto->last_uni >= ols ? 10564 proto->last_uni - ols : 0); 10565 parser->last_lop = ls + (proto->last_lop >= ols ? 10566 proto->last_lop - ols : 0); 10567 10568 parser->bufend = ls + SvCUR(parser->linestr); 10569 } 10570 10571 Copy(proto->tokenbuf, parser->tokenbuf, 256, char); 10572 10573 10574 #ifdef PERL_MAD 10575 parser->endwhite = proto->endwhite; 10576 parser->faketokens = proto->faketokens; 10577 parser->lasttoke = proto->lasttoke; 10578 parser->nextwhite = proto->nextwhite; 10579 parser->realtokenstart = proto->realtokenstart; 10580 parser->skipwhite = proto->skipwhite; 10581 parser->thisclose = proto->thisclose; 10582 parser->thismad = proto->thismad; 10583 parser->thisopen = proto->thisopen; 10584 parser->thisstuff = proto->thisstuff; 10585 parser->thistoken = proto->thistoken; 10586 parser->thiswhite = proto->thiswhite; 10587 10588 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE); 10589 parser->curforce = proto->curforce; 10590 #else 10591 Copy(proto->nextval, parser->nextval, 5, YYSTYPE); 10592 Copy(proto->nexttype, parser->nexttype, 5, I32); 10593 parser->nexttoke = proto->nexttoke; 10594 #endif 10595 10596 /* XXX should clone saved_curcop here, but we aren't passed 10597 * proto_perl; so do it in perl_clone_using instead */ 10598 10599 return parser; 10600 } 10601 10602 10603 /* duplicate a file handle */ 10604 10605 PerlIO * 10606 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) 10607 { 10608 PerlIO *ret; 10609 10610 PERL_ARGS_ASSERT_FP_DUP; 10611 PERL_UNUSED_ARG(type); 10612 10613 if (!fp) 10614 return (PerlIO*)NULL; 10615 10616 /* look for it in the table first */ 10617 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); 10618 if (ret) 10619 return ret; 10620 10621 /* create anew and remember what it is */ 10622 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); 10623 ptr_table_store(PL_ptr_table, fp, ret); 10624 return ret; 10625 } 10626 10627 /* duplicate a directory handle */ 10628 10629 DIR * 10630 Perl_dirp_dup(pTHX_ DIR *const dp) 10631 { 10632 PERL_UNUSED_CONTEXT; 10633 if (!dp) 10634 return (DIR*)NULL; 10635 /* XXX TODO */ 10636 return dp; 10637 } 10638 10639 /* duplicate a typeglob */ 10640 10641 GP * 10642 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) 10643 { 10644 GP *ret; 10645 10646 PERL_ARGS_ASSERT_GP_DUP; 10647 10648 if (!gp) 10649 return (GP*)NULL; 10650 /* look for it in the table first */ 10651 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); 10652 if (ret) 10653 return ret; 10654 10655 /* create anew and remember what it is */ 10656 Newxz(ret, 1, GP); 10657 ptr_table_store(PL_ptr_table, gp, ret); 10658 10659 /* clone */ 10660 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying 10661 on Newxz() to do this for us. */ 10662 ret->gp_sv = sv_dup_inc(gp->gp_sv, param); 10663 ret->gp_io = io_dup_inc(gp->gp_io, param); 10664 ret->gp_form = cv_dup_inc(gp->gp_form, param); 10665 ret->gp_av = av_dup_inc(gp->gp_av, param); 10666 ret->gp_hv = hv_dup_inc(gp->gp_hv, param); 10667 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ 10668 ret->gp_cv = cv_dup_inc(gp->gp_cv, param); 10669 ret->gp_cvgen = gp->gp_cvgen; 10670 ret->gp_line = gp->gp_line; 10671 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param); 10672 return ret; 10673 } 10674 10675 /* duplicate a chain of magic */ 10676 10677 MAGIC * 10678 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) 10679 { 10680 MAGIC *mgret = NULL; 10681 MAGIC **mgprev_p = &mgret; 10682 10683 PERL_ARGS_ASSERT_MG_DUP; 10684 10685 for (; mg; mg = mg->mg_moremagic) { 10686 MAGIC *nmg; 10687 Newx(nmg, 1, MAGIC); 10688 *mgprev_p = nmg; 10689 mgprev_p = &(nmg->mg_moremagic); 10690 10691 /* There was a comment "XXX copy dynamic vtable?" but as we don't have 10692 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates 10693 from the original commit adding Perl_mg_dup() - revision 4538. 10694 Similarly there is the annotation "XXX random ptr?" next to the 10695 assignment to nmg->mg_ptr. */ 10696 *nmg = *mg; 10697 10698 /* FIXME for plugins 10699 if (nmg->mg_type == PERL_MAGIC_qr) { 10700 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); 10701 } 10702 else 10703 */ 10704 if(nmg->mg_type == PERL_MAGIC_backref) { 10705 /* The backref AV has its reference count deliberately bumped by 10706 1. */ 10707 nmg->mg_obj 10708 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param)); 10709 } 10710 else { 10711 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) 10712 ? sv_dup_inc(nmg->mg_obj, param) 10713 : sv_dup(nmg->mg_obj, param); 10714 } 10715 10716 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { 10717 if (nmg->mg_len > 0) { 10718 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); 10719 if (nmg->mg_type == PERL_MAGIC_overload_table && 10720 AMT_AMAGIC((AMT*)nmg->mg_ptr)) 10721 { 10722 AMT * const namtp = (AMT*)nmg->mg_ptr; 10723 sv_dup_inc_multiple((SV**)(namtp->table), 10724 (SV**)(namtp->table), NofAMmeth, param); 10725 } 10726 } 10727 else if (nmg->mg_len == HEf_SVKEY) 10728 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); 10729 } 10730 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { 10731 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param); 10732 } 10733 } 10734 return mgret; 10735 } 10736 10737 #endif /* USE_ITHREADS */ 10738 10739 /* create a new pointer-mapping table */ 10740 10741 PTR_TBL_t * 10742 Perl_ptr_table_new(pTHX) 10743 { 10744 PTR_TBL_t *tbl; 10745 PERL_UNUSED_CONTEXT; 10746 10747 Newx(tbl, 1, PTR_TBL_t); 10748 tbl->tbl_max = 511; 10749 tbl->tbl_items = 0; 10750 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); 10751 return tbl; 10752 } 10753 10754 #define PTR_TABLE_HASH(ptr) \ 10755 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) 10756 10757 /* 10758 we use the PTE_SVSLOT 'reservation' made above, both here (in the 10759 following define) and at call to new_body_inline made below in 10760 Perl_ptr_table_store() 10761 */ 10762 10763 #define del_pte(p) del_body_type(p, PTE_SVSLOT) 10764 10765 /* map an existing pointer using a table */ 10766 10767 STATIC PTR_TBL_ENT_t * 10768 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) 10769 { 10770 PTR_TBL_ENT_t *tblent; 10771 const UV hash = PTR_TABLE_HASH(sv); 10772 10773 PERL_ARGS_ASSERT_PTR_TABLE_FIND; 10774 10775 tblent = tbl->tbl_ary[hash & tbl->tbl_max]; 10776 for (; tblent; tblent = tblent->next) { 10777 if (tblent->oldval == sv) 10778 return tblent; 10779 } 10780 return NULL; 10781 } 10782 10783 void * 10784 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) 10785 { 10786 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv); 10787 10788 PERL_ARGS_ASSERT_PTR_TABLE_FETCH; 10789 PERL_UNUSED_CONTEXT; 10790 10791 return tblent ? tblent->newval : NULL; 10792 } 10793 10794 /* add a new entry to a pointer-mapping table */ 10795 10796 void 10797 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) 10798 { 10799 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); 10800 10801 PERL_ARGS_ASSERT_PTR_TABLE_STORE; 10802 PERL_UNUSED_CONTEXT; 10803 10804 if (tblent) { 10805 tblent->newval = newsv; 10806 } else { 10807 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; 10808 10809 new_body_inline(tblent, PTE_SVSLOT); 10810 10811 tblent->oldval = oldsv; 10812 tblent->newval = newsv; 10813 tblent->next = tbl->tbl_ary[entry]; 10814 tbl->tbl_ary[entry] = tblent; 10815 tbl->tbl_items++; 10816 if (tblent->next && tbl->tbl_items > tbl->tbl_max) 10817 ptr_table_split(tbl); 10818 } 10819 } 10820 10821 /* double the hash bucket size of an existing ptr table */ 10822 10823 void 10824 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) 10825 { 10826 PTR_TBL_ENT_t **ary = tbl->tbl_ary; 10827 const UV oldsize = tbl->tbl_max + 1; 10828 UV newsize = oldsize * 2; 10829 UV i; 10830 10831 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT; 10832 PERL_UNUSED_CONTEXT; 10833 10834 Renew(ary, newsize, PTR_TBL_ENT_t*); 10835 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); 10836 tbl->tbl_max = --newsize; 10837 tbl->tbl_ary = ary; 10838 for (i=0; i < oldsize; i++, ary++) { 10839 PTR_TBL_ENT_t **curentp, **entp, *ent; 10840 if (!*ary) 10841 continue; 10842 curentp = ary + oldsize; 10843 for (entp = ary, ent = *ary; ent; ent = *entp) { 10844 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { 10845 *entp = ent->next; 10846 ent->next = *curentp; 10847 *curentp = ent; 10848 continue; 10849 } 10850 else 10851 entp = &ent->next; 10852 } 10853 } 10854 } 10855 10856 /* remove all the entries from a ptr table */ 10857 10858 void 10859 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) 10860 { 10861 if (tbl && tbl->tbl_items) { 10862 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; 10863 UV riter = tbl->tbl_max; 10864 10865 do { 10866 PTR_TBL_ENT_t *entry = array[riter]; 10867 10868 while (entry) { 10869 PTR_TBL_ENT_t * const oentry = entry; 10870 entry = entry->next; 10871 del_pte(oentry); 10872 } 10873 } while (riter--); 10874 10875 tbl->tbl_items = 0; 10876 } 10877 } 10878 10879 /* clear and free a ptr table */ 10880 10881 void 10882 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) 10883 { 10884 if (!tbl) { 10885 return; 10886 } 10887 ptr_table_clear(tbl); 10888 Safefree(tbl->tbl_ary); 10889 Safefree(tbl); 10890 } 10891 10892 #if defined(USE_ITHREADS) 10893 10894 void 10895 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param) 10896 { 10897 PERL_ARGS_ASSERT_RVPV_DUP; 10898 10899 if (SvROK(sstr)) { 10900 SvRV_set(dstr, SvWEAKREF(sstr) 10901 ? sv_dup(SvRV_const(sstr), param) 10902 : sv_dup_inc(SvRV_const(sstr), param)); 10903 10904 } 10905 else if (SvPVX_const(sstr)) { 10906 /* Has something there */ 10907 if (SvLEN(sstr)) { 10908 /* Normal PV - clone whole allocated space */ 10909 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1)); 10910 if (SvREADONLY(sstr) && SvFAKE(sstr)) { 10911 /* Not that normal - actually sstr is copy on write. 10912 But we are a true, independant SV, so: */ 10913 SvREADONLY_off(dstr); 10914 SvFAKE_off(dstr); 10915 } 10916 } 10917 else { 10918 /* Special case - not normally malloced for some reason */ 10919 if (isGV_with_GP(sstr)) { 10920 /* Don't need to do anything here. */ 10921 } 10922 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) { 10923 /* A "shared" PV - clone it as "shared" PV */ 10924 SvPV_set(dstr, 10925 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), 10926 param))); 10927 } 10928 else { 10929 /* Some other special case - random pointer */ 10930 SvPV_set(dstr, (char *) SvPVX_const(sstr)); 10931 } 10932 } 10933 } 10934 else { 10935 /* Copy the NULL */ 10936 SvPV_set(dstr, NULL); 10937 } 10938 } 10939 10940 /* duplicate a list of SVs. source and dest may point to the same memory. */ 10941 static SV ** 10942 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, 10943 SSize_t items, CLONE_PARAMS *const param) 10944 { 10945 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE; 10946 10947 while (items-- > 0) { 10948 *dest++ = sv_dup_inc(*source++, param); 10949 } 10950 10951 return dest; 10952 } 10953 10954 /* duplicate an SV of any type (including AV, HV etc) */ 10955 10956 SV * 10957 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 10958 { 10959 dVAR; 10960 SV *dstr; 10961 10962 PERL_ARGS_ASSERT_SV_DUP; 10963 10964 if (!sstr) 10965 return NULL; 10966 if (SvTYPE(sstr) == SVTYPEMASK) { 10967 #ifdef DEBUG_LEAKING_SCALARS_ABORT 10968 abort(); 10969 #endif 10970 return NULL; 10971 } 10972 /* look for it in the table first */ 10973 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr)); 10974 if (dstr) 10975 return dstr; 10976 10977 if(param->flags & CLONEf_JOIN_IN) { 10978 /** We are joining here so we don't want do clone 10979 something that is bad **/ 10980 if (SvTYPE(sstr) == SVt_PVHV) { 10981 const HEK * const hvname = HvNAME_HEK(sstr); 10982 if (hvname) 10983 /** don't clone stashes if they already exist **/ 10984 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0)); 10985 } 10986 } 10987 10988 /* create anew and remember what it is */ 10989 new_SV(dstr); 10990 10991 #ifdef DEBUG_LEAKING_SCALARS 10992 dstr->sv_debug_optype = sstr->sv_debug_optype; 10993 dstr->sv_debug_line = sstr->sv_debug_line; 10994 dstr->sv_debug_inpad = sstr->sv_debug_inpad; 10995 dstr->sv_debug_cloned = 1; 10996 dstr->sv_debug_file = savepv(sstr->sv_debug_file); 10997 #endif 10998 10999 ptr_table_store(PL_ptr_table, sstr, dstr); 11000 11001 /* clone */ 11002 SvFLAGS(dstr) = SvFLAGS(sstr); 11003 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ 11004 SvREFCNT(dstr) = 0; /* must be before any other dups! */ 11005 11006 #ifdef DEBUGGING 11007 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) 11008 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", 11009 (void*)PL_watch_pvx, SvPVX_const(sstr)); 11010 #endif 11011 11012 /* don't clone objects whose class has asked us not to */ 11013 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { 11014 SvFLAGS(dstr) = 0; 11015 return dstr; 11016 } 11017 11018 switch (SvTYPE(sstr)) { 11019 case SVt_NULL: 11020 SvANY(dstr) = NULL; 11021 break; 11022 case SVt_IV: 11023 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 11024 if(SvROK(sstr)) { 11025 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 11026 } else { 11027 SvIV_set(dstr, SvIVX(sstr)); 11028 } 11029 break; 11030 case SVt_NV: 11031 SvANY(dstr) = new_XNV(); 11032 SvNV_set(dstr, SvNVX(sstr)); 11033 break; 11034 /* case SVt_BIND: */ 11035 default: 11036 { 11037 /* These are all the types that need complex bodies allocating. */ 11038 void *new_body; 11039 const svtype sv_type = SvTYPE(sstr); 11040 const struct body_details *const sv_type_details 11041 = bodies_by_type + sv_type; 11042 11043 switch (sv_type) { 11044 default: 11045 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); 11046 break; 11047 11048 case SVt_PVGV: 11049 case SVt_PVIO: 11050 case SVt_PVFM: 11051 case SVt_PVHV: 11052 case SVt_PVAV: 11053 case SVt_PVCV: 11054 case SVt_PVLV: 11055 case SVt_REGEXP: 11056 case SVt_PVMG: 11057 case SVt_PVNV: 11058 case SVt_PVIV: 11059 case SVt_PV: 11060 assert(sv_type_details->body_size); 11061 if (sv_type_details->arena) { 11062 new_body_inline(new_body, sv_type); 11063 new_body 11064 = (void*)((char*)new_body - sv_type_details->offset); 11065 } else { 11066 new_body = new_NOARENA(sv_type_details); 11067 } 11068 } 11069 assert(new_body); 11070 SvANY(dstr) = new_body; 11071 11072 #ifndef PURIFY 11073 Copy(((char*)SvANY(sstr)) + sv_type_details->offset, 11074 ((char*)SvANY(dstr)) + sv_type_details->offset, 11075 sv_type_details->copy, char); 11076 #else 11077 Copy(((char*)SvANY(sstr)), 11078 ((char*)SvANY(dstr)), 11079 sv_type_details->body_size + sv_type_details->offset, char); 11080 #endif 11081 11082 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV 11083 && !isGV_with_GP(dstr)) 11084 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 11085 11086 /* The Copy above means that all the source (unduplicated) pointers 11087 are now in the destination. We can check the flags and the 11088 pointers in either, but it's possible that there's less cache 11089 missing by always going for the destination. 11090 FIXME - instrument and check that assumption */ 11091 if (sv_type >= SVt_PVMG) { 11092 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { 11093 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); 11094 } else if (SvMAGIC(dstr)) 11095 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); 11096 if (SvSTASH(dstr)) 11097 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); 11098 } 11099 11100 /* The cast silences a GCC warning about unhandled types. */ 11101 switch ((int)sv_type) { 11102 case SVt_PV: 11103 break; 11104 case SVt_PVIV: 11105 break; 11106 case SVt_PVNV: 11107 break; 11108 case SVt_PVMG: 11109 break; 11110 case SVt_REGEXP: 11111 /* FIXME for plugins */ 11112 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); 11113 break; 11114 case SVt_PVLV: 11115 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ 11116 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ 11117 LvTARG(dstr) = dstr; 11118 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ 11119 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param)); 11120 else 11121 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); 11122 case SVt_PVGV: 11123 if(isGV_with_GP(sstr)) { 11124 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); 11125 /* Don't call sv_add_backref here as it's going to be 11126 created as part of the magic cloning of the symbol 11127 table--unless this is during a join and the stash 11128 is not actually being cloned. */ 11129 /* Danger Will Robinson - GvGP(dstr) isn't initialised 11130 at the point of this comment. */ 11131 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); 11132 if(param->flags & CLONEf_JOIN_IN) { 11133 const HEK * const hvname 11134 = HvNAME_HEK(GvSTASH(dstr)); 11135 if( hvname 11136 && GvSTASH(dstr) == gv_stashpvn( 11137 HEK_KEY(hvname), HEK_LEN(hvname), 0 11138 ) 11139 ) 11140 Perl_sv_add_backref( 11141 aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr 11142 ); 11143 } 11144 GvGP(dstr) = gp_dup(GvGP(sstr), param); 11145 (void)GpREFCNT_inc(GvGP(dstr)); 11146 } else 11147 Perl_rvpv_dup(aTHX_ dstr, sstr, param); 11148 break; 11149 case SVt_PVIO: 11150 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param); 11151 if (IoOFP(dstr) == IoIFP(sstr)) 11152 IoOFP(dstr) = IoIFP(dstr); 11153 else 11154 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); 11155 /* PL_parser->rsfp_filters entries have fake IoDIRP() */ 11156 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { 11157 /* I have no idea why fake dirp (rsfps) 11158 should be treated differently but otherwise 11159 we end up with leaks -- sky*/ 11160 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param); 11161 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param); 11162 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param); 11163 } else { 11164 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param); 11165 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param); 11166 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param); 11167 if (IoDIRP(dstr)) { 11168 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); 11169 } else { 11170 NOOP; 11171 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ 11172 } 11173 } 11174 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr)); 11175 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr)); 11176 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); 11177 break; 11178 case SVt_PVAV: 11179 /* avoid cloning an empty array */ 11180 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) { 11181 SV **dst_ary, **src_ary; 11182 SSize_t items = AvFILLp((const AV *)sstr) + 1; 11183 11184 src_ary = AvARRAY((const AV *)sstr); 11185 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*); 11186 ptr_table_store(PL_ptr_table, src_ary, dst_ary); 11187 AvARRAY(MUTABLE_AV(dstr)) = dst_ary; 11188 AvALLOC((const AV *)dstr) = dst_ary; 11189 if (AvREAL((const AV *)sstr)) { 11190 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, 11191 param); 11192 } 11193 else { 11194 while (items-- > 0) 11195 *dst_ary++ = sv_dup(*src_ary++, param); 11196 if (!(param->flags & CLONEf_COPY_STACKS) 11197 && AvREIFY(sstr)) 11198 { 11199 av_reify(MUTABLE_AV(dstr)); /* #41138 */ 11200 } 11201 } 11202 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); 11203 while (items-- > 0) { 11204 *dst_ary++ = &PL_sv_undef; 11205 } 11206 } 11207 else { 11208 AvARRAY(MUTABLE_AV(dstr)) = NULL; 11209 AvALLOC((const AV *)dstr) = (SV**)NULL; 11210 AvMAX( (const AV *)dstr) = -1; 11211 AvFILLp((const AV *)dstr) = -1; 11212 } 11213 break; 11214 case SVt_PVHV: 11215 if (HvARRAY((const HV *)sstr)) { 11216 STRLEN i = 0; 11217 const bool sharekeys = !!HvSHAREKEYS(sstr); 11218 XPVHV * const dxhv = (XPVHV*)SvANY(dstr); 11219 XPVHV * const sxhv = (XPVHV*)SvANY(sstr); 11220 char *darray; 11221 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) 11222 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), 11223 char); 11224 HvARRAY(dstr) = (HE**)darray; 11225 while (i <= sxhv->xhv_max) { 11226 const HE * const source = HvARRAY(sstr)[i]; 11227 HvARRAY(dstr)[i] = source 11228 ? he_dup(source, sharekeys, param) : 0; 11229 ++i; 11230 } 11231 if (SvOOK(sstr)) { 11232 HEK *hvname; 11233 const struct xpvhv_aux * const saux = HvAUX(sstr); 11234 struct xpvhv_aux * const daux = HvAUX(dstr); 11235 /* This flag isn't copied. */ 11236 /* SvOOK_on(hv) attacks the IV flags. */ 11237 SvFLAGS(dstr) |= SVf_OOK; 11238 11239 hvname = saux->xhv_name; 11240 daux->xhv_name = hek_dup(hvname, param); 11241 11242 daux->xhv_riter = saux->xhv_riter; 11243 daux->xhv_eiter = saux->xhv_eiter 11244 ? he_dup(saux->xhv_eiter, 11245 (bool)!!HvSHAREKEYS(sstr), param) : 0; 11246 /* backref array needs refcnt=2; see sv_add_backref */ 11247 daux->xhv_backreferences = 11248 saux->xhv_backreferences 11249 ? MUTABLE_AV(SvREFCNT_inc( 11250 sv_dup_inc((const SV *)saux->xhv_backreferences, param))) 11251 : 0; 11252 11253 daux->xhv_mro_meta = saux->xhv_mro_meta 11254 ? mro_meta_dup(saux->xhv_mro_meta, param) 11255 : 0; 11256 11257 /* Record stashes for possible cloning in Perl_clone(). */ 11258 if (hvname) 11259 av_push(param->stashes, dstr); 11260 } 11261 } 11262 else 11263 HvARRAY(MUTABLE_HV(dstr)) = NULL; 11264 break; 11265 case SVt_PVCV: 11266 if (!(param->flags & CLONEf_COPY_STACKS)) { 11267 CvDEPTH(dstr) = 0; 11268 } 11269 case SVt_PVFM: 11270 /* NOTE: not refcounted */ 11271 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param); 11272 OP_REFCNT_LOCK; 11273 if (!CvISXSUB(dstr)) 11274 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); 11275 OP_REFCNT_UNLOCK; 11276 if (CvCONST(dstr) && CvISXSUB(dstr)) { 11277 CvXSUBANY(dstr).any_ptr = 11278 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); 11279 } 11280 /* don't dup if copying back - CvGV isn't refcounted, so the 11281 * duped GV may never be freed. A bit of a hack! DAPM */ 11282 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ? 11283 NULL : gv_dup(CvGV(dstr), param) ; 11284 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); 11285 CvOUTSIDE(dstr) = 11286 CvWEAKOUTSIDE(sstr) 11287 ? cv_dup( CvOUTSIDE(dstr), param) 11288 : cv_dup_inc(CvOUTSIDE(dstr), param); 11289 if (!CvISXSUB(dstr)) 11290 CvFILE(dstr) = SAVEPV(CvFILE(dstr)); 11291 break; 11292 } 11293 } 11294 } 11295 11296 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) 11297 ++PL_sv_objcount; 11298 11299 return dstr; 11300 } 11301 11302 /* duplicate a context */ 11303 11304 PERL_CONTEXT * 11305 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 11306 { 11307 PERL_CONTEXT *ncxs; 11308 11309 PERL_ARGS_ASSERT_CX_DUP; 11310 11311 if (!cxs) 11312 return (PERL_CONTEXT*)NULL; 11313 11314 /* look for it in the table first */ 11315 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); 11316 if (ncxs) 11317 return ncxs; 11318 11319 /* create anew and remember what it is */ 11320 Newx(ncxs, max + 1, PERL_CONTEXT); 11321 ptr_table_store(PL_ptr_table, cxs, ncxs); 11322 Copy(cxs, ncxs, max + 1, PERL_CONTEXT); 11323 11324 while (ix >= 0) { 11325 PERL_CONTEXT * const ncx = &ncxs[ix]; 11326 if (CxTYPE(ncx) == CXt_SUBST) { 11327 Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); 11328 } 11329 else { 11330 switch (CxTYPE(ncx)) { 11331 case CXt_SUB: 11332 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 11333 ? cv_dup_inc(ncx->blk_sub.cv, param) 11334 : cv_dup(ncx->blk_sub.cv,param)); 11335 ncx->blk_sub.argarray = (CxHASARGS(ncx) 11336 ? av_dup_inc(ncx->blk_sub.argarray, 11337 param) 11338 : NULL); 11339 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray, 11340 param); 11341 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, 11342 ncx->blk_sub.oldcomppad); 11343 break; 11344 case CXt_EVAL: 11345 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, 11346 param); 11347 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); 11348 break; 11349 case CXt_LOOP_LAZYSV: 11350 ncx->blk_loop.state_u.lazysv.end 11351 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); 11352 /* We are taking advantage of av_dup_inc and sv_dup_inc 11353 actually being the same function, and order equivalance of 11354 the two unions. 11355 We can assert the later [but only at run time :-(] */ 11356 assert ((void *) &ncx->blk_loop.state_u.ary.ary == 11357 (void *) &ncx->blk_loop.state_u.lazysv.cur); 11358 case CXt_LOOP_FOR: 11359 ncx->blk_loop.state_u.ary.ary 11360 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); 11361 case CXt_LOOP_LAZYIV: 11362 case CXt_LOOP_PLAIN: 11363 if (CxPADLOOP(ncx)) { 11364 ncx->blk_loop.oldcomppad 11365 = (PAD*)ptr_table_fetch(PL_ptr_table, 11366 ncx->blk_loop.oldcomppad); 11367 } else { 11368 ncx->blk_loop.oldcomppad 11369 = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad, 11370 param); 11371 } 11372 break; 11373 case CXt_FORMAT: 11374 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param); 11375 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); 11376 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, 11377 param); 11378 break; 11379 case CXt_BLOCK: 11380 case CXt_NULL: 11381 break; 11382 } 11383 } 11384 --ix; 11385 } 11386 return ncxs; 11387 } 11388 11389 /* duplicate a stack info structure */ 11390 11391 PERL_SI * 11392 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) 11393 { 11394 PERL_SI *nsi; 11395 11396 PERL_ARGS_ASSERT_SI_DUP; 11397 11398 if (!si) 11399 return (PERL_SI*)NULL; 11400 11401 /* look for it in the table first */ 11402 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); 11403 if (nsi) 11404 return nsi; 11405 11406 /* create anew and remember what it is */ 11407 Newxz(nsi, 1, PERL_SI); 11408 ptr_table_store(PL_ptr_table, si, nsi); 11409 11410 nsi->si_stack = av_dup_inc(si->si_stack, param); 11411 nsi->si_cxix = si->si_cxix; 11412 nsi->si_cxmax = si->si_cxmax; 11413 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); 11414 nsi->si_type = si->si_type; 11415 nsi->si_prev = si_dup(si->si_prev, param); 11416 nsi->si_next = si_dup(si->si_next, param); 11417 nsi->si_markoff = si->si_markoff; 11418 11419 return nsi; 11420 } 11421 11422 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32) 11423 #define TOPINT(ss,ix) ((ss)[ix].any_i32) 11424 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long) 11425 #define TOPLONG(ss,ix) ((ss)[ix].any_long) 11426 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) 11427 #define TOPIV(ss,ix) ((ss)[ix].any_iv) 11428 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) 11429 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool) 11430 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) 11431 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr) 11432 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) 11433 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) 11434 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) 11435 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) 11436 11437 /* XXXXX todo */ 11438 #define pv_dup_inc(p) SAVEPV(p) 11439 #define pv_dup(p) SAVEPV(p) 11440 #define svp_dup_inc(p,pp) any_dup(p,pp) 11441 11442 /* map any object to the new equivent - either something in the 11443 * ptr table, or something in the interpreter structure 11444 */ 11445 11446 void * 11447 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) 11448 { 11449 void *ret; 11450 11451 PERL_ARGS_ASSERT_ANY_DUP; 11452 11453 if (!v) 11454 return (void*)NULL; 11455 11456 /* look for it in the table first */ 11457 ret = ptr_table_fetch(PL_ptr_table, v); 11458 if (ret) 11459 return ret; 11460 11461 /* see if it is part of the interpreter structure */ 11462 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) 11463 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); 11464 else { 11465 ret = v; 11466 } 11467 11468 return ret; 11469 } 11470 11471 /* duplicate the save stack */ 11472 11473 ANY * 11474 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 11475 { 11476 dVAR; 11477 ANY * const ss = proto_perl->Isavestack; 11478 const I32 max = proto_perl->Isavestack_max; 11479 I32 ix = proto_perl->Isavestack_ix; 11480 ANY *nss; 11481 const SV *sv; 11482 const GV *gv; 11483 const AV *av; 11484 const HV *hv; 11485 void* ptr; 11486 int intval; 11487 long longval; 11488 GP *gp; 11489 IV iv; 11490 I32 i; 11491 char *c = NULL; 11492 void (*dptr) (void*); 11493 void (*dxptr) (pTHX_ void*); 11494 11495 PERL_ARGS_ASSERT_SS_DUP; 11496 11497 Newxz(nss, max, ANY); 11498 11499 while (ix > 0) { 11500 const I32 type = POPINT(ss,ix); 11501 TOPINT(nss,ix) = type; 11502 switch (type) { 11503 case SAVEt_HELEM: /* hash element */ 11504 sv = (const SV *)POPPTR(ss,ix); 11505 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11506 /* fall through */ 11507 case SAVEt_ITEM: /* normal string */ 11508 case SAVEt_SV: /* scalar reference */ 11509 sv = (const SV *)POPPTR(ss,ix); 11510 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11511 /* fall through */ 11512 case SAVEt_FREESV: 11513 case SAVEt_MORTALIZESV: 11514 sv = (const SV *)POPPTR(ss,ix); 11515 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11516 break; 11517 case SAVEt_SHARED_PVREF: /* char* in shared space */ 11518 c = (char*)POPPTR(ss,ix); 11519 TOPPTR(nss,ix) = savesharedpv(c); 11520 ptr = POPPTR(ss,ix); 11521 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11522 break; 11523 case SAVEt_GENERIC_SVREF: /* generic sv */ 11524 case SAVEt_SVREF: /* scalar reference */ 11525 sv = (const SV *)POPPTR(ss,ix); 11526 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11527 ptr = POPPTR(ss,ix); 11528 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ 11529 break; 11530 case SAVEt_HV: /* hash reference */ 11531 case SAVEt_AV: /* array reference */ 11532 sv = (const SV *) POPPTR(ss,ix); 11533 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11534 /* fall through */ 11535 case SAVEt_COMPPAD: 11536 case SAVEt_NSTAB: 11537 sv = (const SV *) POPPTR(ss,ix); 11538 TOPPTR(nss,ix) = sv_dup(sv, param); 11539 break; 11540 case SAVEt_INT: /* int reference */ 11541 ptr = POPPTR(ss,ix); 11542 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11543 intval = (int)POPINT(ss,ix); 11544 TOPINT(nss,ix) = intval; 11545 break; 11546 case SAVEt_LONG: /* long reference */ 11547 ptr = POPPTR(ss,ix); 11548 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11549 /* fall through */ 11550 case SAVEt_CLEARSV: 11551 longval = (long)POPLONG(ss,ix); 11552 TOPLONG(nss,ix) = longval; 11553 break; 11554 case SAVEt_I32: /* I32 reference */ 11555 case SAVEt_I16: /* I16 reference */ 11556 case SAVEt_I8: /* I8 reference */ 11557 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ 11558 ptr = POPPTR(ss,ix); 11559 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11560 i = POPINT(ss,ix); 11561 TOPINT(nss,ix) = i; 11562 break; 11563 case SAVEt_IV: /* IV reference */ 11564 ptr = POPPTR(ss,ix); 11565 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11566 iv = POPIV(ss,ix); 11567 TOPIV(nss,ix) = iv; 11568 break; 11569 case SAVEt_HPTR: /* HV* reference */ 11570 case SAVEt_APTR: /* AV* reference */ 11571 case SAVEt_SPTR: /* SV* reference */ 11572 ptr = POPPTR(ss,ix); 11573 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11574 sv = (const SV *)POPPTR(ss,ix); 11575 TOPPTR(nss,ix) = sv_dup(sv, param); 11576 break; 11577 case SAVEt_VPTR: /* random* reference */ 11578 ptr = POPPTR(ss,ix); 11579 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11580 ptr = POPPTR(ss,ix); 11581 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11582 break; 11583 case SAVEt_GENERIC_PVREF: /* generic char* */ 11584 case SAVEt_PPTR: /* char* reference */ 11585 ptr = POPPTR(ss,ix); 11586 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11587 c = (char*)POPPTR(ss,ix); 11588 TOPPTR(nss,ix) = pv_dup(c); 11589 break; 11590 case SAVEt_GP: /* scalar reference */ 11591 gp = (GP*)POPPTR(ss,ix); 11592 TOPPTR(nss,ix) = gp = gp_dup(gp, param); 11593 (void)GpREFCNT_inc(gp); 11594 gv = (const GV *)POPPTR(ss,ix); 11595 TOPPTR(nss,ix) = gv_dup_inc(gv, param); 11596 break; 11597 case SAVEt_FREEOP: 11598 ptr = POPPTR(ss,ix); 11599 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { 11600 /* these are assumed to be refcounted properly */ 11601 OP *o; 11602 switch (((OP*)ptr)->op_type) { 11603 case OP_LEAVESUB: 11604 case OP_LEAVESUBLV: 11605 case OP_LEAVEEVAL: 11606 case OP_LEAVE: 11607 case OP_SCOPE: 11608 case OP_LEAVEWRITE: 11609 TOPPTR(nss,ix) = ptr; 11610 o = (OP*)ptr; 11611 OP_REFCNT_LOCK; 11612 (void) OpREFCNT_inc(o); 11613 OP_REFCNT_UNLOCK; 11614 break; 11615 default: 11616 TOPPTR(nss,ix) = NULL; 11617 break; 11618 } 11619 } 11620 else 11621 TOPPTR(nss,ix) = NULL; 11622 break; 11623 case SAVEt_DELETE: 11624 hv = (const HV *)POPPTR(ss,ix); 11625 TOPPTR(nss,ix) = hv_dup_inc(hv, param); 11626 i = POPINT(ss,ix); 11627 TOPINT(nss,ix) = i; 11628 /* Fall through */ 11629 case SAVEt_FREEPV: 11630 c = (char*)POPPTR(ss,ix); 11631 TOPPTR(nss,ix) = pv_dup_inc(c); 11632 break; 11633 case SAVEt_STACK_POS: /* Position on Perl stack */ 11634 i = POPINT(ss,ix); 11635 TOPINT(nss,ix) = i; 11636 break; 11637 case SAVEt_DESTRUCTOR: 11638 ptr = POPPTR(ss,ix); 11639 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ 11640 dptr = POPDPTR(ss,ix); 11641 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), 11642 any_dup(FPTR2DPTR(void *, dptr), 11643 proto_perl)); 11644 break; 11645 case SAVEt_DESTRUCTOR_X: 11646 ptr = POPPTR(ss,ix); 11647 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ 11648 dxptr = POPDXPTR(ss,ix); 11649 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), 11650 any_dup(FPTR2DPTR(void *, dxptr), 11651 proto_perl)); 11652 break; 11653 case SAVEt_REGCONTEXT: 11654 case SAVEt_ALLOC: 11655 i = POPINT(ss,ix); 11656 TOPINT(nss,ix) = i; 11657 ix -= i; 11658 break; 11659 case SAVEt_AELEM: /* array element */ 11660 sv = (const SV *)POPPTR(ss,ix); 11661 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11662 i = POPINT(ss,ix); 11663 TOPINT(nss,ix) = i; 11664 av = (const AV *)POPPTR(ss,ix); 11665 TOPPTR(nss,ix) = av_dup_inc(av, param); 11666 break; 11667 case SAVEt_OP: 11668 ptr = POPPTR(ss,ix); 11669 TOPPTR(nss,ix) = ptr; 11670 break; 11671 case SAVEt_HINTS: 11672 ptr = POPPTR(ss,ix); 11673 if (ptr) { 11674 HINTS_REFCNT_LOCK; 11675 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++; 11676 HINTS_REFCNT_UNLOCK; 11677 } 11678 TOPPTR(nss,ix) = ptr; 11679 i = POPINT(ss,ix); 11680 TOPINT(nss,ix) = i; 11681 if (i & HINT_LOCALIZE_HH) { 11682 hv = (const HV *)POPPTR(ss,ix); 11683 TOPPTR(nss,ix) = hv_dup_inc(hv, param); 11684 } 11685 break; 11686 case SAVEt_PADSV_AND_MORTALIZE: 11687 longval = (long)POPLONG(ss,ix); 11688 TOPLONG(nss,ix) = longval; 11689 ptr = POPPTR(ss,ix); 11690 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11691 sv = (const SV *)POPPTR(ss,ix); 11692 TOPPTR(nss,ix) = sv_dup_inc(sv, param); 11693 break; 11694 case SAVEt_BOOL: 11695 ptr = POPPTR(ss,ix); 11696 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); 11697 longval = (long)POPBOOL(ss,ix); 11698 TOPBOOL(nss,ix) = (bool)longval; 11699 break; 11700 case SAVEt_SET_SVFLAGS: 11701 i = POPINT(ss,ix); 11702 TOPINT(nss,ix) = i; 11703 i = POPINT(ss,ix); 11704 TOPINT(nss,ix) = i; 11705 sv = (const SV *)POPPTR(ss,ix); 11706 TOPPTR(nss,ix) = sv_dup(sv, param); 11707 break; 11708 case SAVEt_RE_STATE: 11709 { 11710 const struct re_save_state *const old_state 11711 = (struct re_save_state *) 11712 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); 11713 struct re_save_state *const new_state 11714 = (struct re_save_state *) 11715 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE); 11716 11717 Copy(old_state, new_state, 1, struct re_save_state); 11718 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; 11719 11720 new_state->re_state_bostr 11721 = pv_dup(old_state->re_state_bostr); 11722 new_state->re_state_reginput 11723 = pv_dup(old_state->re_state_reginput); 11724 new_state->re_state_regeol 11725 = pv_dup(old_state->re_state_regeol); 11726 new_state->re_state_regoffs 11727 = (regexp_paren_pair*) 11728 any_dup(old_state->re_state_regoffs, proto_perl); 11729 new_state->re_state_reglastparen 11730 = (U32*) any_dup(old_state->re_state_reglastparen, 11731 proto_perl); 11732 new_state->re_state_reglastcloseparen 11733 = (U32*)any_dup(old_state->re_state_reglastcloseparen, 11734 proto_perl); 11735 /* XXX This just has to be broken. The old save_re_context 11736 code did SAVEGENERICPV(PL_reg_start_tmp); 11737 PL_reg_start_tmp is char **. 11738 Look above to what the dup code does for 11739 SAVEt_GENERIC_PVREF 11740 It can never have worked. 11741 So this is merely a faithful copy of the exiting bug: */ 11742 new_state->re_state_reg_start_tmp 11743 = (char **) pv_dup((char *) 11744 old_state->re_state_reg_start_tmp); 11745 /* I assume that it only ever "worked" because no-one called 11746 (pseudo)fork while the regexp engine had re-entered itself. 11747 */ 11748 #ifdef PERL_OLD_COPY_ON_WRITE 11749 new_state->re_state_nrs 11750 = sv_dup(old_state->re_state_nrs, param); 11751 #endif 11752 new_state->re_state_reg_magic 11753 = (MAGIC*) any_dup(old_state->re_state_reg_magic, 11754 proto_perl); 11755 new_state->re_state_reg_oldcurpm 11756 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm, 11757 proto_perl); 11758 new_state->re_state_reg_curpm 11759 = (PMOP*) any_dup(old_state->re_state_reg_curpm, 11760 proto_perl); 11761 new_state->re_state_reg_oldsaved 11762 = pv_dup(old_state->re_state_reg_oldsaved); 11763 new_state->re_state_reg_poscache 11764 = pv_dup(old_state->re_state_reg_poscache); 11765 new_state->re_state_reg_starttry 11766 = pv_dup(old_state->re_state_reg_starttry); 11767 break; 11768 } 11769 case SAVEt_COMPILE_WARNINGS: 11770 ptr = POPPTR(ss,ix); 11771 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); 11772 break; 11773 case SAVEt_PARSER: 11774 ptr = POPPTR(ss,ix); 11775 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); 11776 break; 11777 default: 11778 Perl_croak(aTHX_ 11779 "panic: ss_dup inconsistency (%"IVdf")", (IV) type); 11780 } 11781 } 11782 11783 return nss; 11784 } 11785 11786 11787 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE 11788 * flag to the result. This is done for each stash before cloning starts, 11789 * so we know which stashes want their objects cloned */ 11790 11791 static void 11792 do_mark_cloneable_stash(pTHX_ SV *const sv) 11793 { 11794 const HEK * const hvname = HvNAME_HEK((const HV *)sv); 11795 if (hvname) { 11796 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); 11797 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ 11798 if (cloner && GvCV(cloner)) { 11799 dSP; 11800 UV status; 11801 11802 ENTER; 11803 SAVETMPS; 11804 PUSHMARK(SP); 11805 mXPUSHs(newSVhek(hvname)); 11806 PUTBACK; 11807 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); 11808 SPAGAIN; 11809 status = POPu; 11810 PUTBACK; 11811 FREETMPS; 11812 LEAVE; 11813 if (status) 11814 SvFLAGS(sv) &= ~SVphv_CLONEABLE; 11815 } 11816 } 11817 } 11818 11819 11820 11821 /* 11822 =for apidoc perl_clone 11823 11824 Create and return a new interpreter by cloning the current one. 11825 11826 perl_clone takes these flags as parameters: 11827 11828 CLONEf_COPY_STACKS - is used to, well, copy the stacks also, 11829 without it we only clone the data and zero the stacks, 11830 with it we copy the stacks and the new perl interpreter is 11831 ready to run at the exact same point as the previous one. 11832 The pseudo-fork code uses COPY_STACKS while the 11833 threads->create doesn't. 11834 11835 CLONEf_KEEP_PTR_TABLE 11836 perl_clone keeps a ptr_table with the pointer of the old 11837 variable as a key and the new variable as a value, 11838 this allows it to check if something has been cloned and not 11839 clone it again but rather just use the value and increase the 11840 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill 11841 the ptr_table using the function 11842 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>, 11843 reason to keep it around is if you want to dup some of your own 11844 variable who are outside the graph perl scans, example of this 11845 code is in threads.xs create 11846 11847 CLONEf_CLONE_HOST 11848 This is a win32 thing, it is ignored on unix, it tells perls 11849 win32host code (which is c++) to clone itself, this is needed on 11850 win32 if you want to run two threads at the same time, 11851 if you just want to do some stuff in a separate perl interpreter 11852 and then throw it away and return to the original one, 11853 you don't need to do anything. 11854 11855 =cut 11856 */ 11857 11858 /* XXX the above needs expanding by someone who actually understands it ! */ 11859 EXTERN_C PerlInterpreter * 11860 perl_clone_host(PerlInterpreter* proto_perl, UV flags); 11861 11862 PerlInterpreter * 11863 perl_clone(PerlInterpreter *proto_perl, UV flags) 11864 { 11865 dVAR; 11866 #ifdef PERL_IMPLICIT_SYS 11867 11868 PERL_ARGS_ASSERT_PERL_CLONE; 11869 11870 /* perlhost.h so we need to call into it 11871 to clone the host, CPerlHost should have a c interface, sky */ 11872 11873 if (flags & CLONEf_CLONE_HOST) { 11874 return perl_clone_host(proto_perl,flags); 11875 } 11876 return perl_clone_using(proto_perl, flags, 11877 proto_perl->IMem, 11878 proto_perl->IMemShared, 11879 proto_perl->IMemParse, 11880 proto_perl->IEnv, 11881 proto_perl->IStdIO, 11882 proto_perl->ILIO, 11883 proto_perl->IDir, 11884 proto_perl->ISock, 11885 proto_perl->IProc); 11886 } 11887 11888 PerlInterpreter * 11889 perl_clone_using(PerlInterpreter *proto_perl, UV flags, 11890 struct IPerlMem* ipM, struct IPerlMem* ipMS, 11891 struct IPerlMem* ipMP, struct IPerlEnv* ipE, 11892 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, 11893 struct IPerlDir* ipD, struct IPerlSock* ipS, 11894 struct IPerlProc* ipP) 11895 { 11896 /* XXX many of the string copies here can be optimized if they're 11897 * constants; they need to be allocated as common memory and just 11898 * their pointers copied. */ 11899 11900 IV i; 11901 CLONE_PARAMS clone_params; 11902 CLONE_PARAMS* const param = &clone_params; 11903 11904 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); 11905 11906 PERL_ARGS_ASSERT_PERL_CLONE_USING; 11907 #else /* !PERL_IMPLICIT_SYS */ 11908 IV i; 11909 CLONE_PARAMS clone_params; 11910 CLONE_PARAMS* param = &clone_params; 11911 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); 11912 11913 PERL_ARGS_ASSERT_PERL_CLONE; 11914 #endif /* PERL_IMPLICIT_SYS */ 11915 11916 /* for each stash, determine whether its objects should be cloned */ 11917 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); 11918 PERL_SET_THX(my_perl); 11919 11920 #ifdef DEBUGGING 11921 PoisonNew(my_perl, 1, PerlInterpreter); 11922 PL_op = NULL; 11923 PL_curcop = NULL; 11924 PL_markstack = 0; 11925 PL_scopestack = 0; 11926 PL_scopestack_name = 0; 11927 PL_savestack = 0; 11928 PL_savestack_ix = 0; 11929 PL_savestack_max = -1; 11930 PL_sig_pending = 0; 11931 PL_parser = NULL; 11932 Zero(&PL_debug_pad, 1, struct perl_debug_pad); 11933 # ifdef DEBUG_LEAKING_SCALARS 11934 PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000; 11935 # endif 11936 #else /* !DEBUGGING */ 11937 Zero(my_perl, 1, PerlInterpreter); 11938 #endif /* DEBUGGING */ 11939 11940 #ifdef PERL_IMPLICIT_SYS 11941 /* host pointers */ 11942 PL_Mem = ipM; 11943 PL_MemShared = ipMS; 11944 PL_MemParse = ipMP; 11945 PL_Env = ipE; 11946 PL_StdIO = ipStd; 11947 PL_LIO = ipLIO; 11948 PL_Dir = ipD; 11949 PL_Sock = ipS; 11950 PL_Proc = ipP; 11951 #endif /* PERL_IMPLICIT_SYS */ 11952 11953 param->flags = flags; 11954 param->proto_perl = proto_perl; 11955 11956 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); 11957 11958 PL_body_arenas = NULL; 11959 Zero(&PL_body_roots, 1, PL_body_roots); 11960 11961 PL_nice_chunk = NULL; 11962 PL_nice_chunk_size = 0; 11963 PL_sv_count = 0; 11964 PL_sv_objcount = 0; 11965 PL_sv_root = NULL; 11966 PL_sv_arenaroot = NULL; 11967 11968 PL_debug = proto_perl->Idebug; 11969 11970 PL_hash_seed = proto_perl->Ihash_seed; 11971 PL_rehash_seed = proto_perl->Irehash_seed; 11972 11973 #ifdef USE_REENTRANT_API 11974 /* XXX: things like -Dm will segfault here in perlio, but doing 11975 * PERL_SET_CONTEXT(proto_perl); 11976 * breaks too many other things 11977 */ 11978 Perl_reentrant_init(aTHX); 11979 #endif 11980 11981 /* create SV map for pointer relocation */ 11982 PL_ptr_table = ptr_table_new(); 11983 11984 /* initialize these special pointers as early as possible */ 11985 SvANY(&PL_sv_undef) = NULL; 11986 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; 11987 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; 11988 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); 11989 11990 SvANY(&PL_sv_no) = new_XPVNV(); 11991 SvREFCNT(&PL_sv_no) = (~(U32)0)/2; 11992 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK 11993 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; 11994 SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); 11995 SvCUR_set(&PL_sv_no, 0); 11996 SvLEN_set(&PL_sv_no, 1); 11997 SvIV_set(&PL_sv_no, 0); 11998 SvNV_set(&PL_sv_no, 0); 11999 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); 12000 12001 SvANY(&PL_sv_yes) = new_XPVNV(); 12002 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; 12003 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK 12004 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; 12005 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); 12006 SvCUR_set(&PL_sv_yes, 1); 12007 SvLEN_set(&PL_sv_yes, 2); 12008 SvIV_set(&PL_sv_yes, 1); 12009 SvNV_set(&PL_sv_yes, 1); 12010 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); 12011 12012 /* dbargs array probably holds garbage */ 12013 PL_dbargs = NULL; 12014 12015 /* create (a non-shared!) shared string table */ 12016 PL_strtab = newHV(); 12017 HvSHAREKEYS_off(PL_strtab); 12018 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); 12019 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); 12020 12021 PL_compiling = proto_perl->Icompiling; 12022 12023 /* These two PVs will be free'd special way so must set them same way op.c does */ 12024 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); 12025 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); 12026 12027 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); 12028 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); 12029 12030 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); 12031 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 12032 if (PL_compiling.cop_hints_hash) { 12033 HINTS_REFCNT_LOCK; 12034 PL_compiling.cop_hints_hash->refcounted_he_refcnt++; 12035 HINTS_REFCNT_UNLOCK; 12036 } 12037 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); 12038 #ifdef PERL_DEBUG_READONLY_OPS 12039 PL_slabs = NULL; 12040 PL_slab_count = 0; 12041 #endif 12042 12043 /* pseudo environmental stuff */ 12044 PL_origargc = proto_perl->Iorigargc; 12045 PL_origargv = proto_perl->Iorigargv; 12046 12047 param->stashes = newAV(); /* Setup array of objects to call clone on */ 12048 12049 /* Set tainting stuff before PerlIO_debug can possibly get called */ 12050 PL_tainting = proto_perl->Itainting; 12051 PL_taint_warn = proto_perl->Itaint_warn; 12052 12053 #ifdef PERLIO_LAYERS 12054 /* Clone PerlIO tables as soon as we can handle general xx_dup() */ 12055 PerlIO_clone(aTHX_ proto_perl, param); 12056 #endif 12057 12058 PL_envgv = gv_dup(proto_perl->Ienvgv, param); 12059 PL_incgv = gv_dup(proto_perl->Iincgv, param); 12060 PL_hintgv = gv_dup(proto_perl->Ihintgv, param); 12061 PL_origfilename = SAVEPV(proto_perl->Iorigfilename); 12062 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); 12063 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); 12064 12065 /* switches */ 12066 PL_minus_c = proto_perl->Iminus_c; 12067 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); 12068 PL_localpatches = proto_perl->Ilocalpatches; 12069 PL_splitstr = proto_perl->Isplitstr; 12070 PL_minus_n = proto_perl->Iminus_n; 12071 PL_minus_p = proto_perl->Iminus_p; 12072 PL_minus_l = proto_perl->Iminus_l; 12073 PL_minus_a = proto_perl->Iminus_a; 12074 PL_minus_E = proto_perl->Iminus_E; 12075 PL_minus_F = proto_perl->Iminus_F; 12076 PL_doswitches = proto_perl->Idoswitches; 12077 PL_dowarn = proto_perl->Idowarn; 12078 PL_doextract = proto_perl->Idoextract; 12079 PL_sawampersand = proto_perl->Isawampersand; 12080 PL_unsafe = proto_perl->Iunsafe; 12081 PL_inplace = SAVEPV(proto_perl->Iinplace); 12082 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); 12083 PL_perldb = proto_perl->Iperldb; 12084 PL_perl_destruct_level = proto_perl->Iperl_destruct_level; 12085 PL_exit_flags = proto_perl->Iexit_flags; 12086 12087 /* magical thingies */ 12088 /* XXX time(&PL_basetime) when asked for? */ 12089 PL_basetime = proto_perl->Ibasetime; 12090 PL_formfeed = sv_dup(proto_perl->Iformfeed, param); 12091 12092 PL_maxsysfd = proto_perl->Imaxsysfd; 12093 PL_statusvalue = proto_perl->Istatusvalue; 12094 #ifdef VMS 12095 PL_statusvalue_vms = proto_perl->Istatusvalue_vms; 12096 #else 12097 PL_statusvalue_posix = proto_perl->Istatusvalue_posix; 12098 #endif 12099 PL_encoding = sv_dup(proto_perl->Iencoding, param); 12100 12101 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ 12102 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ 12103 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ 12104 12105 12106 /* RE engine related */ 12107 Zero(&PL_reg_state, 1, struct re_save_state); 12108 PL_reginterp_cnt = 0; 12109 PL_regmatch_slab = NULL; 12110 12111 /* Clone the regex array */ 12112 /* ORANGE FIXME for plugins, probably in the SV dup code. 12113 newSViv(PTR2IV(CALLREGDUPE( 12114 INT2PTR(REGEXP *, SvIVX(regex)), param)))) 12115 */ 12116 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); 12117 PL_regex_pad = AvARRAY(PL_regex_padav); 12118 12119 /* shortcuts to various I/O objects */ 12120 PL_ofsgv = gv_dup(proto_perl->Iofsgv, param); 12121 PL_stdingv = gv_dup(proto_perl->Istdingv, param); 12122 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); 12123 PL_defgv = gv_dup(proto_perl->Idefgv, param); 12124 PL_argvgv = gv_dup(proto_perl->Iargvgv, param); 12125 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); 12126 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); 12127 12128 /* shortcuts to regexp stuff */ 12129 PL_replgv = gv_dup(proto_perl->Ireplgv, param); 12130 12131 /* shortcuts to misc objects */ 12132 PL_errgv = gv_dup(proto_perl->Ierrgv, param); 12133 12134 /* shortcuts to debugging objects */ 12135 PL_DBgv = gv_dup(proto_perl->IDBgv, param); 12136 PL_DBline = gv_dup(proto_perl->IDBline, param); 12137 PL_DBsub = gv_dup(proto_perl->IDBsub, param); 12138 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); 12139 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); 12140 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); 12141 12142 /* symbol tables */ 12143 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); 12144 PL_curstash = hv_dup(proto_perl->Icurstash, param); 12145 PL_debstash = hv_dup(proto_perl->Idebstash, param); 12146 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); 12147 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); 12148 12149 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); 12150 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); 12151 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); 12152 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); 12153 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); 12154 PL_endav = av_dup_inc(proto_perl->Iendav, param); 12155 PL_checkav = av_dup_inc(proto_perl->Icheckav, param); 12156 PL_initav = av_dup_inc(proto_perl->Iinitav, param); 12157 12158 PL_sub_generation = proto_perl->Isub_generation; 12159 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); 12160 12161 /* funky return mechanisms */ 12162 PL_forkprocess = proto_perl->Iforkprocess; 12163 12164 /* subprocess state */ 12165 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); 12166 12167 /* internal state */ 12168 PL_maxo = proto_perl->Imaxo; 12169 if (proto_perl->Iop_mask) 12170 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); 12171 else 12172 PL_op_mask = NULL; 12173 /* PL_asserting = proto_perl->Iasserting; */ 12174 12175 /* current interpreter roots */ 12176 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); 12177 OP_REFCNT_LOCK; 12178 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); 12179 OP_REFCNT_UNLOCK; 12180 PL_main_start = proto_perl->Imain_start; 12181 PL_eval_root = proto_perl->Ieval_root; 12182 PL_eval_start = proto_perl->Ieval_start; 12183 12184 /* runtime control stuff */ 12185 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); 12186 12187 PL_filemode = proto_perl->Ifilemode; 12188 PL_lastfd = proto_perl->Ilastfd; 12189 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ 12190 PL_Argv = NULL; 12191 PL_Cmd = NULL; 12192 PL_gensym = proto_perl->Igensym; 12193 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); 12194 PL_laststatval = proto_perl->Ilaststatval; 12195 PL_laststype = proto_perl->Ilaststype; 12196 PL_mess_sv = NULL; 12197 12198 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); 12199 12200 /* interpreter atexit processing */ 12201 PL_exitlistlen = proto_perl->Iexitlistlen; 12202 if (PL_exitlistlen) { 12203 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); 12204 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); 12205 } 12206 else 12207 PL_exitlist = (PerlExitListEntry*)NULL; 12208 12209 PL_my_cxt_size = proto_perl->Imy_cxt_size; 12210 if (PL_my_cxt_size) { 12211 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 12212 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); 12213 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 12214 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 12215 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); 12216 #endif 12217 } 12218 else { 12219 PL_my_cxt_list = (void**)NULL; 12220 #ifdef PERL_GLOBAL_STRUCT_PRIVATE 12221 PL_my_cxt_keys = (const char**)NULL; 12222 #endif 12223 } 12224 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); 12225 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); 12226 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); 12227 12228 PL_profiledata = NULL; 12229 12230 PL_compcv = cv_dup(proto_perl->Icompcv, param); 12231 12232 PAD_CLONE_VARS(proto_perl, param); 12233 12234 #ifdef HAVE_INTERP_INTERN 12235 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); 12236 #endif 12237 12238 /* more statics moved here */ 12239 PL_generation = proto_perl->Igeneration; 12240 PL_DBcv = cv_dup(proto_perl->IDBcv, param); 12241 12242 PL_in_clean_objs = proto_perl->Iin_clean_objs; 12243 PL_in_clean_all = proto_perl->Iin_clean_all; 12244 12245 PL_uid = proto_perl->Iuid; 12246 PL_euid = proto_perl->Ieuid; 12247 PL_gid = proto_perl->Igid; 12248 PL_egid = proto_perl->Iegid; 12249 PL_nomemok = proto_perl->Inomemok; 12250 PL_an = proto_perl->Ian; 12251 PL_evalseq = proto_perl->Ievalseq; 12252 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ 12253 PL_origalen = proto_perl->Iorigalen; 12254 #ifdef PERL_USES_PL_PIDSTATUS 12255 PL_pidstatus = newHV(); /* XXX flag for cloning? */ 12256 #endif 12257 PL_osname = SAVEPV(proto_perl->Iosname); 12258 PL_sighandlerp = proto_perl->Isighandlerp; 12259 12260 PL_runops = proto_perl->Irunops; 12261 12262 PL_parser = parser_dup(proto_perl->Iparser, param); 12263 12264 /* XXX this only works if the saved cop has already been cloned */ 12265 if (proto_perl->Iparser) { 12266 PL_parser->saved_curcop = (COP*)any_dup( 12267 proto_perl->Iparser->saved_curcop, 12268 proto_perl); 12269 } 12270 12271 PL_subline = proto_perl->Isubline; 12272 PL_subname = sv_dup_inc(proto_perl->Isubname, param); 12273 12274 #ifdef FCRYPT 12275 PL_cryptseen = proto_perl->Icryptseen; 12276 #endif 12277 12278 PL_hints = proto_perl->Ihints; 12279 12280 PL_amagic_generation = proto_perl->Iamagic_generation; 12281 12282 #ifdef USE_LOCALE_COLLATE 12283 PL_collation_ix = proto_perl->Icollation_ix; 12284 PL_collation_name = SAVEPV(proto_perl->Icollation_name); 12285 PL_collation_standard = proto_perl->Icollation_standard; 12286 PL_collxfrm_base = proto_perl->Icollxfrm_base; 12287 PL_collxfrm_mult = proto_perl->Icollxfrm_mult; 12288 #endif /* USE_LOCALE_COLLATE */ 12289 12290 #ifdef USE_LOCALE_NUMERIC 12291 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); 12292 PL_numeric_standard = proto_perl->Inumeric_standard; 12293 PL_numeric_local = proto_perl->Inumeric_local; 12294 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); 12295 #endif /* !USE_LOCALE_NUMERIC */ 12296 12297 /* utf8 character classes */ 12298 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); 12299 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param); 12300 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); 12301 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); 12302 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param); 12303 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); 12304 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); 12305 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param); 12306 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param); 12307 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param); 12308 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); 12309 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); 12310 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); 12311 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param); 12312 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); 12313 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param); 12314 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param); 12315 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param); 12316 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param); 12317 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param); 12318 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param); 12319 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param); 12320 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param); 12321 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); 12322 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); 12323 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); 12324 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); 12325 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); 12326 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); 12327 12328 /* Did the locale setup indicate UTF-8? */ 12329 PL_utf8locale = proto_perl->Iutf8locale; 12330 /* Unicode features (see perlrun/-C) */ 12331 PL_unicode = proto_perl->Iunicode; 12332 12333 /* Pre-5.8 signals control */ 12334 PL_signals = proto_perl->Isignals; 12335 12336 /* times() ticks per second */ 12337 PL_clocktick = proto_perl->Iclocktick; 12338 12339 /* Recursion stopper for PerlIO_find_layer */ 12340 PL_in_load_module = proto_perl->Iin_load_module; 12341 12342 /* sort() routine */ 12343 PL_sort_RealCmp = proto_perl->Isort_RealCmp; 12344 12345 /* Not really needed/useful since the reenrant_retint is "volatile", 12346 * but do it for consistency's sake. */ 12347 PL_reentrant_retint = proto_perl->Ireentrant_retint; 12348 12349 /* Hooks to shared SVs and locks. */ 12350 PL_sharehook = proto_perl->Isharehook; 12351 PL_lockhook = proto_perl->Ilockhook; 12352 PL_unlockhook = proto_perl->Iunlockhook; 12353 PL_threadhook = proto_perl->Ithreadhook; 12354 PL_destroyhook = proto_perl->Idestroyhook; 12355 12356 #ifdef THREADS_HAVE_PIDS 12357 PL_ppid = proto_perl->Ippid; 12358 #endif 12359 12360 /* swatch cache */ 12361 PL_last_swash_hv = NULL; /* reinits on demand */ 12362 PL_last_swash_klen = 0; 12363 PL_last_swash_key[0]= '\0'; 12364 PL_last_swash_tmps = (U8*)NULL; 12365 PL_last_swash_slen = 0; 12366 12367 PL_glob_index = proto_perl->Iglob_index; 12368 PL_srand_called = proto_perl->Isrand_called; 12369 12370 if (proto_perl->Ipsig_pend) { 12371 Newxz(PL_psig_pend, SIG_SIZE, int); 12372 } 12373 else { 12374 PL_psig_pend = (int*)NULL; 12375 } 12376 12377 if (proto_perl->Ipsig_name) { 12378 Newx(PL_psig_name, 2 * SIG_SIZE, SV*); 12379 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, 12380 param); 12381 PL_psig_ptr = PL_psig_name + SIG_SIZE; 12382 } 12383 else { 12384 PL_psig_ptr = (SV**)NULL; 12385 PL_psig_name = (SV**)NULL; 12386 } 12387 12388 /* intrpvar.h stuff */ 12389 12390 if (flags & CLONEf_COPY_STACKS) { 12391 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ 12392 PL_tmps_ix = proto_perl->Itmps_ix; 12393 PL_tmps_max = proto_perl->Itmps_max; 12394 PL_tmps_floor = proto_perl->Itmps_floor; 12395 Newx(PL_tmps_stack, PL_tmps_max, SV*); 12396 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, 12397 PL_tmps_ix+1, param); 12398 12399 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ 12400 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; 12401 Newxz(PL_markstack, i, I32); 12402 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max 12403 - proto_perl->Imarkstack); 12404 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr 12405 - proto_perl->Imarkstack); 12406 Copy(proto_perl->Imarkstack, PL_markstack, 12407 PL_markstack_ptr - PL_markstack + 1, I32); 12408 12409 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] 12410 * NOTE: unlike the others! */ 12411 PL_scopestack_ix = proto_perl->Iscopestack_ix; 12412 PL_scopestack_max = proto_perl->Iscopestack_max; 12413 Newxz(PL_scopestack, PL_scopestack_max, I32); 12414 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); 12415 12416 #ifdef DEBUGGING 12417 Newxz(PL_scopestack_name, PL_scopestack_max, const char *); 12418 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); 12419 #endif 12420 /* NOTE: si_dup() looks at PL_markstack */ 12421 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); 12422 12423 /* PL_curstack = PL_curstackinfo->si_stack; */ 12424 PL_curstack = av_dup(proto_perl->Icurstack, param); 12425 PL_mainstack = av_dup(proto_perl->Imainstack, param); 12426 12427 /* next PUSHs() etc. set *(PL_stack_sp+1) */ 12428 PL_stack_base = AvARRAY(PL_curstack); 12429 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp 12430 - proto_perl->Istack_base); 12431 PL_stack_max = PL_stack_base + AvMAX(PL_curstack); 12432 12433 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] 12434 * NOTE: unlike the others! */ 12435 PL_savestack_ix = proto_perl->Isavestack_ix; 12436 PL_savestack_max = proto_perl->Isavestack_max; 12437 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ 12438 PL_savestack = ss_dup(proto_perl, param); 12439 } 12440 else { 12441 init_stacks(); 12442 ENTER; /* perl_destruct() wants to LEAVE; */ 12443 12444 /* although we're not duplicating the tmps stack, we should still 12445 * add entries for any SVs on the tmps stack that got cloned by a 12446 * non-refcount means (eg a temp in @_); otherwise they will be 12447 * orphaned 12448 */ 12449 for (i = 0; i<= proto_perl->Itmps_ix; i++) { 12450 SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, 12451 proto_perl->Itmps_stack[i])); 12452 if (nsv && !SvREFCNT(nsv)) { 12453 PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv)); 12454 } 12455 } 12456 } 12457 12458 PL_start_env = proto_perl->Istart_env; /* XXXXXX */ 12459 PL_top_env = &PL_start_env; 12460 12461 PL_op = proto_perl->Iop; 12462 12463 PL_Sv = NULL; 12464 PL_Xpv = (XPV*)NULL; 12465 my_perl->Ina = proto_perl->Ina; 12466 12467 PL_statbuf = proto_perl->Istatbuf; 12468 PL_statcache = proto_perl->Istatcache; 12469 PL_statgv = gv_dup(proto_perl->Istatgv, param); 12470 PL_statname = sv_dup_inc(proto_perl->Istatname, param); 12471 #ifdef HAS_TIMES 12472 PL_timesbuf = proto_perl->Itimesbuf; 12473 #endif 12474 12475 PL_tainted = proto_perl->Itainted; 12476 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ 12477 PL_rs = sv_dup_inc(proto_perl->Irs, param); 12478 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); 12479 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); 12480 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ 12481 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); 12482 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); 12483 PL_formtarget = sv_dup(proto_perl->Iformtarget, param); 12484 12485 PL_restartop = proto_perl->Irestartop; 12486 PL_in_eval = proto_perl->Iin_eval; 12487 PL_delaymagic = proto_perl->Idelaymagic; 12488 PL_dirty = proto_perl->Idirty; 12489 PL_localizing = proto_perl->Ilocalizing; 12490 12491 PL_errors = sv_dup_inc(proto_perl->Ierrors, param); 12492 PL_hv_fetch_ent_mh = NULL; 12493 PL_modcount = proto_perl->Imodcount; 12494 PL_lastgotoprobe = NULL; 12495 PL_dumpindent = proto_perl->Idumpindent; 12496 12497 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); 12498 PL_sortstash = hv_dup(proto_perl->Isortstash, param); 12499 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param); 12500 PL_secondgv = gv_dup(proto_perl->Isecondgv, param); 12501 PL_efloatbuf = NULL; /* reinits on demand */ 12502 PL_efloatsize = 0; /* reinits on demand */ 12503 12504 /* regex stuff */ 12505 12506 PL_screamfirst = NULL; 12507 PL_screamnext = NULL; 12508 PL_maxscream = -1; /* reinits on demand */ 12509 PL_lastscream = NULL; 12510 12511 12512 PL_regdummy = proto_perl->Iregdummy; 12513 PL_colorset = 0; /* reinits PL_colors[] */ 12514 /*PL_colors[6] = {0,0,0,0,0,0};*/ 12515 12516 12517 12518 /* Pluggable optimizer */ 12519 PL_peepp = proto_perl->Ipeepp; 12520 /* op_free() hook */ 12521 PL_opfreehook = proto_perl->Iopfreehook; 12522 12523 PL_stashcache = newHV(); 12524 12525 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, 12526 proto_perl->Iwatchaddr); 12527 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; 12528 if (PL_debug && PL_watchaddr) { 12529 PerlIO_printf(Perl_debug_log, 12530 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n", 12531 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), 12532 PTR2UV(PL_watchok)); 12533 } 12534 12535 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); 12536 12537 /* Call the ->CLONE method, if it exists, for each of the stashes 12538 identified by sv_dup() above. 12539 */ 12540 while(av_len(param->stashes) != -1) { 12541 HV* const stash = MUTABLE_HV(av_shift(param->stashes)); 12542 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); 12543 if (cloner && GvCV(cloner)) { 12544 dSP; 12545 ENTER; 12546 SAVETMPS; 12547 PUSHMARK(SP); 12548 mXPUSHs(newSVhek(HvNAME_HEK(stash))); 12549 PUTBACK; 12550 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); 12551 FREETMPS; 12552 LEAVE; 12553 } 12554 } 12555 12556 if (!(flags & CLONEf_KEEP_PTR_TABLE)) { 12557 ptr_table_free(PL_ptr_table); 12558 PL_ptr_table = NULL; 12559 } 12560 12561 12562 SvREFCNT_dec(param->stashes); 12563 12564 /* orphaned? eg threads->new inside BEGIN or use */ 12565 if (PL_compcv && ! SvREFCNT(PL_compcv)) { 12566 SvREFCNT_inc_simple_void(PL_compcv); 12567 SAVEFREESV(PL_compcv); 12568 } 12569 12570 return my_perl; 12571 } 12572 12573 #endif /* USE_ITHREADS */ 12574 12575 /* 12576 =head1 Unicode Support 12577 12578 =for apidoc sv_recode_to_utf8 12579 12580 The encoding is assumed to be an Encode object, on entry the PV 12581 of the sv is assumed to be octets in that encoding, and the sv 12582 will be converted into Unicode (and UTF-8). 12583 12584 If the sv already is UTF-8 (or if it is not POK), or if the encoding 12585 is not a reference, nothing is done to the sv. If the encoding is not 12586 an C<Encode::XS> Encoding object, bad things will happen. 12587 (See F<lib/encoding.pm> and L<Encode>). 12588 12589 The PV of the sv is returned. 12590 12591 =cut */ 12592 12593 char * 12594 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) 12595 { 12596 dVAR; 12597 12598 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; 12599 12600 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { 12601 SV *uni; 12602 STRLEN len; 12603 const char *s; 12604 dSP; 12605 ENTER; 12606 SAVETMPS; 12607 save_re_context(); 12608 PUSHMARK(sp); 12609 EXTEND(SP, 3); 12610 XPUSHs(encoding); 12611 XPUSHs(sv); 12612 /* 12613 NI-S 2002/07/09 12614 Passing sv_yes is wrong - it needs to be or'ed set of constants 12615 for Encode::XS, while UTf-8 decode (currently) assumes a true value means 12616 remove converted chars from source. 12617 12618 Both will default the value - let them. 12619 12620 XPUSHs(&PL_sv_yes); 12621 */ 12622 PUTBACK; 12623 call_method("decode", G_SCALAR); 12624 SPAGAIN; 12625 uni = POPs; 12626 PUTBACK; 12627 s = SvPV_const(uni, len); 12628 if (s != SvPVX_const(sv)) { 12629 SvGROW(sv, len + 1); 12630 Move(s, SvPVX(sv), len + 1, char); 12631 SvCUR_set(sv, len); 12632 } 12633 FREETMPS; 12634 LEAVE; 12635 SvUTF8_on(sv); 12636 return SvPVX(sv); 12637 } 12638 return SvPOKp(sv) ? SvPVX(sv) : NULL; 12639 } 12640 12641 /* 12642 =for apidoc sv_cat_decode 12643 12644 The encoding is assumed to be an Encode object, the PV of the ssv is 12645 assumed to be octets in that encoding and decoding the input starts 12646 from the position which (PV + *offset) pointed to. The dsv will be 12647 concatenated the decoded UTF-8 string from ssv. Decoding will terminate 12648 when the string tstr appears in decoding output or the input ends on 12649 the PV of the ssv. The value which the offset points will be modified 12650 to the last input position on the ssv. 12651 12652 Returns TRUE if the terminator was found, else returns FALSE. 12653 12654 =cut */ 12655 12656 bool 12657 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, 12658 SV *ssv, int *offset, char *tstr, int tlen) 12659 { 12660 dVAR; 12661 bool ret = FALSE; 12662 12663 PERL_ARGS_ASSERT_SV_CAT_DECODE; 12664 12665 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { 12666 SV *offsv; 12667 dSP; 12668 ENTER; 12669 SAVETMPS; 12670 save_re_context(); 12671 PUSHMARK(sp); 12672 EXTEND(SP, 6); 12673 XPUSHs(encoding); 12674 XPUSHs(dsv); 12675 XPUSHs(ssv); 12676 offsv = newSViv(*offset); 12677 mXPUSHs(offsv); 12678 mXPUSHp(tstr, tlen); 12679 PUTBACK; 12680 call_method("cat_decode", G_SCALAR); 12681 SPAGAIN; 12682 ret = SvTRUE(TOPs); 12683 *offset = SvIV(offsv); 12684 PUTBACK; 12685 FREETMPS; 12686 LEAVE; 12687 } 12688 else 12689 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); 12690 return ret; 12691 12692 } 12693 12694 /* --------------------------------------------------------------------- 12695 * 12696 * support functions for report_uninit() 12697 */ 12698 12699 /* the maxiumum size of array or hash where we will scan looking 12700 * for the undefined element that triggered the warning */ 12701 12702 #define FUV_MAX_SEARCH_SIZE 1000 12703 12704 /* Look for an entry in the hash whose value has the same SV as val; 12705 * If so, return a mortal copy of the key. */ 12706 12707 STATIC SV* 12708 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) 12709 { 12710 dVAR; 12711 register HE **array; 12712 I32 i; 12713 12714 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; 12715 12716 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || 12717 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) 12718 return NULL; 12719 12720 array = HvARRAY(hv); 12721 12722 for (i=HvMAX(hv); i>0; i--) { 12723 register HE *entry; 12724 for (entry = array[i]; entry; entry = HeNEXT(entry)) { 12725 if (HeVAL(entry) != val) 12726 continue; 12727 if ( HeVAL(entry) == &PL_sv_undef || 12728 HeVAL(entry) == &PL_sv_placeholder) 12729 continue; 12730 if (!HeKEY(entry)) 12731 return NULL; 12732 if (HeKLEN(entry) == HEf_SVKEY) 12733 return sv_mortalcopy(HeKEY_sv(entry)); 12734 return sv_2mortal(newSVhek(HeKEY_hek(entry))); 12735 } 12736 } 12737 return NULL; 12738 } 12739 12740 /* Look for an entry in the array whose value has the same SV as val; 12741 * If so, return the index, otherwise return -1. */ 12742 12743 STATIC I32 12744 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) 12745 { 12746 dVAR; 12747 12748 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; 12749 12750 if (!av || SvMAGICAL(av) || !AvARRAY(av) || 12751 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) 12752 return -1; 12753 12754 if (val != &PL_sv_undef) { 12755 SV ** const svp = AvARRAY(av); 12756 I32 i; 12757 12758 for (i=AvFILLp(av); i>=0; i--) 12759 if (svp[i] == val) 12760 return i; 12761 } 12762 return -1; 12763 } 12764 12765 /* S_varname(): return the name of a variable, optionally with a subscript. 12766 * If gv is non-zero, use the name of that global, along with gvtype (one 12767 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset 12768 * targ. Depending on the value of the subscript_type flag, return: 12769 */ 12770 12771 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ 12772 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ 12773 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ 12774 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ 12775 12776 STATIC SV* 12777 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, 12778 const SV *const keyname, I32 aindex, int subscript_type) 12779 { 12780 12781 SV * const name = sv_newmortal(); 12782 if (gv) { 12783 char buffer[2]; 12784 buffer[0] = gvtype; 12785 buffer[1] = 0; 12786 12787 /* as gv_fullname4(), but add literal '^' for $^FOO names */ 12788 12789 gv_fullname4(name, gv, buffer, 0); 12790 12791 if ((unsigned int)SvPVX(name)[1] <= 26) { 12792 buffer[0] = '^'; 12793 buffer[1] = SvPVX(name)[1] + 'A' - 1; 12794 12795 /* Swap the 1 unprintable control character for the 2 byte pretty 12796 version - ie substr($name, 1, 1) = $buffer; */ 12797 sv_insert(name, 1, 1, buffer, 2); 12798 } 12799 } 12800 else { 12801 CV * const cv = find_runcv(NULL); 12802 SV *sv; 12803 AV *av; 12804 12805 if (!cv || !CvPADLIST(cv)) 12806 return NULL; 12807 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE))); 12808 sv = *av_fetch(av, targ, FALSE); 12809 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv)); 12810 } 12811 12812 if (subscript_type == FUV_SUBSCRIPT_HASH) { 12813 SV * const sv = newSV(0); 12814 *SvPVX(name) = '$'; 12815 Perl_sv_catpvf(aTHX_ name, "{%s}", 12816 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); 12817 SvREFCNT_dec(sv); 12818 } 12819 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { 12820 *SvPVX(name) = '$'; 12821 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); 12822 } 12823 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { 12824 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ 12825 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); 12826 } 12827 12828 return name; 12829 } 12830 12831 12832 /* 12833 =for apidoc find_uninit_var 12834 12835 Find the name of the undefined variable (if any) that caused the operator o 12836 to issue a "Use of uninitialized value" warning. 12837 If match is true, only return a name if it's value matches uninit_sv. 12838 So roughly speaking, if a unary operator (such as OP_COS) generates a 12839 warning, then following the direct child of the op may yield an 12840 OP_PADSV or OP_GV that gives the name of the undefined variable. On the 12841 other hand, with OP_ADD there are two branches to follow, so we only print 12842 the variable name if we get an exact match. 12843 12844 The name is returned as a mortal SV. 12845 12846 Assumes that PL_op is the op that originally triggered the error, and that 12847 PL_comppad/PL_curpad points to the currently executing pad. 12848 12849 =cut 12850 */ 12851 12852 STATIC SV * 12853 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, 12854 bool match) 12855 { 12856 dVAR; 12857 SV *sv; 12858 const GV *gv; 12859 const OP *o, *o2, *kid; 12860 12861 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || 12862 uninit_sv == &PL_sv_placeholder))) 12863 return NULL; 12864 12865 switch (obase->op_type) { 12866 12867 case OP_RV2AV: 12868 case OP_RV2HV: 12869 case OP_PADAV: 12870 case OP_PADHV: 12871 { 12872 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); 12873 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); 12874 I32 index = 0; 12875 SV *keysv = NULL; 12876 int subscript_type = FUV_SUBSCRIPT_WITHIN; 12877 12878 if (pad) { /* @lex, %lex */ 12879 sv = PAD_SVl(obase->op_targ); 12880 gv = NULL; 12881 } 12882 else { 12883 if (cUNOPx(obase)->op_first->op_type == OP_GV) { 12884 /* @global, %global */ 12885 gv = cGVOPx_gv(cUNOPx(obase)->op_first); 12886 if (!gv) 12887 break; 12888 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); 12889 } 12890 else /* @{expr}, %{expr} */ 12891 return find_uninit_var(cUNOPx(obase)->op_first, 12892 uninit_sv, match); 12893 } 12894 12895 /* attempt to find a match within the aggregate */ 12896 if (hash) { 12897 keysv = find_hash_subscript((const HV*)sv, uninit_sv); 12898 if (keysv) 12899 subscript_type = FUV_SUBSCRIPT_HASH; 12900 } 12901 else { 12902 index = find_array_subscript((const AV *)sv, uninit_sv); 12903 if (index >= 0) 12904 subscript_type = FUV_SUBSCRIPT_ARRAY; 12905 } 12906 12907 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) 12908 break; 12909 12910 return varname(gv, hash ? '%' : '@', obase->op_targ, 12911 keysv, index, subscript_type); 12912 } 12913 12914 case OP_PADSV: 12915 if (match && PAD_SVl(obase->op_targ) != uninit_sv) 12916 break; 12917 return varname(NULL, '$', obase->op_targ, 12918 NULL, 0, FUV_SUBSCRIPT_NONE); 12919 12920 case OP_GVSV: 12921 gv = cGVOPx_gv(obase); 12922 if (!gv || (match && GvSV(gv) != uninit_sv)) 12923 break; 12924 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); 12925 12926 case OP_AELEMFAST: 12927 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ 12928 if (match) { 12929 SV **svp; 12930 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); 12931 if (!av || SvRMAGICAL(av)) 12932 break; 12933 svp = av_fetch(av, (I32)obase->op_private, FALSE); 12934 if (!svp || *svp != uninit_sv) 12935 break; 12936 } 12937 return varname(NULL, '$', obase->op_targ, 12938 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); 12939 } 12940 else { 12941 gv = cGVOPx_gv(obase); 12942 if (!gv) 12943 break; 12944 if (match) { 12945 SV **svp; 12946 AV *const av = GvAV(gv); 12947 if (!av || SvRMAGICAL(av)) 12948 break; 12949 svp = av_fetch(av, (I32)obase->op_private, FALSE); 12950 if (!svp || *svp != uninit_sv) 12951 break; 12952 } 12953 return varname(gv, '$', 0, 12954 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); 12955 } 12956 break; 12957 12958 case OP_EXISTS: 12959 o = cUNOPx(obase)->op_first; 12960 if (!o || o->op_type != OP_NULL || 12961 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) 12962 break; 12963 return find_uninit_var(cBINOPo->op_last, uninit_sv, match); 12964 12965 case OP_AELEM: 12966 case OP_HELEM: 12967 if (PL_op == obase) 12968 /* $a[uninit_expr] or $h{uninit_expr} */ 12969 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); 12970 12971 gv = NULL; 12972 o = cBINOPx(obase)->op_first; 12973 kid = cBINOPx(obase)->op_last; 12974 12975 /* get the av or hv, and optionally the gv */ 12976 sv = NULL; 12977 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { 12978 sv = PAD_SV(o->op_targ); 12979 } 12980 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) 12981 && cUNOPo->op_first->op_type == OP_GV) 12982 { 12983 gv = cGVOPx_gv(cUNOPo->op_first); 12984 if (!gv) 12985 break; 12986 sv = o->op_type 12987 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); 12988 } 12989 if (!sv) 12990 break; 12991 12992 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { 12993 /* index is constant */ 12994 if (match) { 12995 if (SvMAGICAL(sv)) 12996 break; 12997 if (obase->op_type == OP_HELEM) { 12998 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0); 12999 if (!he || HeVAL(he) != uninit_sv) 13000 break; 13001 } 13002 else { 13003 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE); 13004 if (!svp || *svp != uninit_sv) 13005 break; 13006 } 13007 } 13008 if (obase->op_type == OP_HELEM) 13009 return varname(gv, '%', o->op_targ, 13010 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); 13011 else 13012 return varname(gv, '@', o->op_targ, NULL, 13013 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); 13014 } 13015 else { 13016 /* index is an expression; 13017 * attempt to find a match within the aggregate */ 13018 if (obase->op_type == OP_HELEM) { 13019 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); 13020 if (keysv) 13021 return varname(gv, '%', o->op_targ, 13022 keysv, 0, FUV_SUBSCRIPT_HASH); 13023 } 13024 else { 13025 const I32 index 13026 = find_array_subscript((const AV *)sv, uninit_sv); 13027 if (index >= 0) 13028 return varname(gv, '@', o->op_targ, 13029 NULL, index, FUV_SUBSCRIPT_ARRAY); 13030 } 13031 if (match) 13032 break; 13033 return varname(gv, 13034 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) 13035 ? '@' : '%', 13036 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); 13037 } 13038 break; 13039 13040 case OP_AASSIGN: 13041 /* only examine RHS */ 13042 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); 13043 13044 case OP_OPEN: 13045 o = cUNOPx(obase)->op_first; 13046 if (o->op_type == OP_PUSHMARK) 13047 o = o->op_sibling; 13048 13049 if (!o->op_sibling) { 13050 /* one-arg version of open is highly magical */ 13051 13052 if (o->op_type == OP_GV) { /* open FOO; */ 13053 gv = cGVOPx_gv(o); 13054 if (match && GvSV(gv) != uninit_sv) 13055 break; 13056 return varname(gv, '$', 0, 13057 NULL, 0, FUV_SUBSCRIPT_NONE); 13058 } 13059 /* other possibilities not handled are: 13060 * open $x; or open my $x; should return '${*$x}' 13061 * open expr; should return '$'.expr ideally 13062 */ 13063 break; 13064 } 13065 goto do_op; 13066 13067 /* ops where $_ may be an implicit arg */ 13068 case OP_TRANS: 13069 case OP_SUBST: 13070 case OP_MATCH: 13071 if ( !(obase->op_flags & OPf_STACKED)) { 13072 if (uninit_sv == ((obase->op_private & OPpTARGET_MY) 13073 ? PAD_SVl(obase->op_targ) 13074 : DEFSV)) 13075 { 13076 sv = sv_newmortal(); 13077 sv_setpvs(sv, "$_"); 13078 return sv; 13079 } 13080 } 13081 goto do_op; 13082 13083 case OP_PRTF: 13084 case OP_PRINT: 13085 case OP_SAY: 13086 match = 1; /* print etc can return undef on defined args */ 13087 /* skip filehandle as it can't produce 'undef' warning */ 13088 o = cUNOPx(obase)->op_first; 13089 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) 13090 o = o->op_sibling->op_sibling; 13091 goto do_op2; 13092 13093 13094 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ 13095 case OP_RV2SV: 13096 case OP_CUSTOM: /* XS or custom code could trigger random warnings */ 13097 13098 /* the following ops are capable of returning PL_sv_undef even for 13099 * defined arg(s) */ 13100 13101 case OP_BACKTICK: 13102 case OP_PIPE_OP: 13103 case OP_FILENO: 13104 case OP_BINMODE: 13105 case OP_TIED: 13106 case OP_GETC: 13107 case OP_SYSREAD: 13108 case OP_SEND: 13109 case OP_IOCTL: 13110 case OP_SOCKET: 13111 case OP_SOCKPAIR: 13112 case OP_BIND: 13113 case OP_CONNECT: 13114 case OP_LISTEN: 13115 case OP_ACCEPT: 13116 case OP_SHUTDOWN: 13117 case OP_SSOCKOPT: 13118 case OP_GETPEERNAME: 13119 case OP_FTRREAD: 13120 case OP_FTRWRITE: 13121 case OP_FTREXEC: 13122 case OP_FTROWNED: 13123 case OP_FTEREAD: 13124 case OP_FTEWRITE: 13125 case OP_FTEEXEC: 13126 case OP_FTEOWNED: 13127 case OP_FTIS: 13128 case OP_FTZERO: 13129 case OP_FTSIZE: 13130 case OP_FTFILE: 13131 case OP_FTDIR: 13132 case OP_FTLINK: 13133 case OP_FTPIPE: 13134 case OP_FTSOCK: 13135 case OP_FTBLK: 13136 case OP_FTCHR: 13137 case OP_FTTTY: 13138 case OP_FTSUID: 13139 case OP_FTSGID: 13140 case OP_FTSVTX: 13141 case OP_FTTEXT: 13142 case OP_FTBINARY: 13143 case OP_FTMTIME: 13144 case OP_FTATIME: 13145 case OP_FTCTIME: 13146 case OP_READLINK: 13147 case OP_OPEN_DIR: 13148 case OP_READDIR: 13149 case OP_TELLDIR: 13150 case OP_SEEKDIR: 13151 case OP_REWINDDIR: 13152 case OP_CLOSEDIR: 13153 case OP_GMTIME: 13154 case OP_ALARM: 13155 case OP_SEMGET: 13156 case OP_GETLOGIN: 13157 case OP_UNDEF: 13158 case OP_SUBSTR: 13159 case OP_AEACH: 13160 case OP_EACH: 13161 case OP_SORT: 13162 case OP_CALLER: 13163 case OP_DOFILE: 13164 case OP_PROTOTYPE: 13165 case OP_NCMP: 13166 case OP_SMARTMATCH: 13167 case OP_UNPACK: 13168 case OP_SYSOPEN: 13169 case OP_SYSSEEK: 13170 match = 1; 13171 goto do_op; 13172 13173 case OP_ENTERSUB: 13174 case OP_GOTO: 13175 /* XXX tmp hack: these two may call an XS sub, and currently 13176 XS subs don't have a SUB entry on the context stack, so CV and 13177 pad determination goes wrong, and BAD things happen. So, just 13178 don't try to determine the value under those circumstances. 13179 Need a better fix at dome point. DAPM 11/2007 */ 13180 break; 13181 13182 case OP_FLIP: 13183 case OP_FLOP: 13184 { 13185 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); 13186 if (gv && GvSV(gv) == uninit_sv) 13187 return newSVpvs_flags("$.", SVs_TEMP); 13188 goto do_op; 13189 } 13190 13191 case OP_POS: 13192 /* def-ness of rval pos() is independent of the def-ness of its arg */ 13193 if ( !(obase->op_flags & OPf_MOD)) 13194 break; 13195 13196 case OP_SCHOMP: 13197 case OP_CHOMP: 13198 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) 13199 return newSVpvs_flags("${$/}", SVs_TEMP); 13200 /*FALLTHROUGH*/ 13201 13202 default: 13203 do_op: 13204 if (!(obase->op_flags & OPf_KIDS)) 13205 break; 13206 o = cUNOPx(obase)->op_first; 13207 13208 do_op2: 13209 if (!o) 13210 break; 13211 13212 /* if all except one arg are constant, or have no side-effects, 13213 * or are optimized away, then it's unambiguous */ 13214 o2 = NULL; 13215 for (kid=o; kid; kid = kid->op_sibling) { 13216 if (kid) { 13217 const OPCODE type = kid->op_type; 13218 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) 13219 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) 13220 || (type == OP_PUSHMARK) 13221 ) 13222 continue; 13223 } 13224 if (o2) { /* more than one found */ 13225 o2 = NULL; 13226 break; 13227 } 13228 o2 = kid; 13229 } 13230 if (o2) 13231 return find_uninit_var(o2, uninit_sv, match); 13232 13233 /* scan all args */ 13234 while (o) { 13235 sv = find_uninit_var(o, uninit_sv, 1); 13236 if (sv) 13237 return sv; 13238 o = o->op_sibling; 13239 } 13240 break; 13241 } 13242 return NULL; 13243 } 13244 13245 13246 /* 13247 =for apidoc report_uninit 13248 13249 Print appropriate "Use of uninitialized variable" warning 13250 13251 =cut 13252 */ 13253 13254 void 13255 Perl_report_uninit(pTHX_ const SV *uninit_sv) 13256 { 13257 dVAR; 13258 if (PL_op) { 13259 SV* varname = NULL; 13260 if (uninit_sv) { 13261 varname = find_uninit_var(PL_op, uninit_sv,0); 13262 if (varname) 13263 sv_insert(varname, 0, 0, " ", 1); 13264 } 13265 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, 13266 varname ? SvPV_nolen_const(varname) : "", 13267 " in ", OP_DESC(PL_op)); 13268 } 13269 else 13270 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, 13271 "", "", ""); 13272 } 13273 13274 /* 13275 * Local variables: 13276 * c-indentation-style: bsd 13277 * c-basic-offset: 4 13278 * indent-tabs-mode: t 13279 * End: 13280 * 13281 * ex: set ts=8 sts=4 sw=4 noet: 13282 */ 13283