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