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