sv.c

   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_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 #ifdef DEBUG_LEAKING_SCALARS
 170 #  ifdef NETWARE
 171 #    define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
 172 #  else
 173 #    define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
 174 #  endif
 175 #else
 176 #  define FREE_SV_DEBUG_FILE(sv)
 177 #endif
 178
 179 #define plant_SV(p) \
 180     STMT_START {                                        \
 181         FREE_SV_DEBUG_FILE(p);                          \
 182         SvANY(p) = (void *)PL_sv_root;                  \
 183         SvFLAGS(p) = SVTYPEMASK;                        \
 184         PL_sv_root = (p);                               \
 185         --PL_sv_count;                                  \
 186     } STMT_END
 187
 188 /* sv_mutex must be held while calling uproot_SV() */
 189 #define uproot_SV(p) \
 190     STMT_START {                                        \
 191         (p) = PL_sv_root;                               \
 192         PL_sv_root = (SV*)SvANY(p);                     \
 193         ++PL_sv_count;                                  \
 194     } STMT_END
 195
 196
 197 /* make some more SVs by adding another arena */
 198
 199 /* sv_mutex must be held while calling more_sv() */
 200 STATIC SV*
 201 S_more_sv(pTHX)
 202 {
 203     SV* sv;
 204
 205     if (PL_nice_chunk) {
 206         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 207         PL_nice_chunk = Nullch;
 208         PL_nice_chunk_size = 0;
 209     }
 210     else {
 211         char *chunk;                /* must use New here to match call to */
 212         New(704,chunk,PERL_ARENA_SIZE,char);   /* Safefree() in sv_free_arenas()     */
 213         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 214     }
 215     uproot_SV(sv);
 216     return sv;
 217 }
 218
 219 /* new_SV(): return a new, empty SV head */
 220
 221 #ifdef DEBUG_LEAKING_SCALARS
 222 /* provide a real function for a debugger to play with */
 223 STATIC SV*
 224 S_new_SV(pTHX)
 225 {
 226     SV* sv;
 227
 228     LOCK_SV_MUTEX;
 229     if (PL_sv_root)
 230         uproot_SV(sv);
 231     else
 232         sv = S_more_sv(aTHX);
 233     UNLOCK_SV_MUTEX;
 234     SvANY(sv) = 0;
 235     SvREFCNT(sv) = 1;
 236     SvFLAGS(sv) = 0;
 237     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 238     sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
 239         (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
 240     sv->sv_debug_inpad = 0;
 241     sv->sv_debug_cloned = 0;
 242 #  ifdef NETWARE
 243     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 244 #  else
 245     sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
 246 #  endif
 247
 248     return sv;
 249 }
 250 #  define new_SV(p) (p)=S_new_SV(aTHX)
 251
 252 #else
 253 #  define new_SV(p) \
 254     STMT_START {                                        \
 255         LOCK_SV_MUTEX;                                  \
 256         if (PL_sv_root)                                 \
 257             uproot_SV(p);                               \
 258         else                                            \
 259             (p) = S_more_sv(aTHX);                      \
 260         UNLOCK_SV_MUTEX;                                \
 261         SvANY(p) = 0;                                   \
 262         SvREFCNT(p) = 1;                                \
 263         SvFLAGS(p) = 0;                                 \
 264     } STMT_END
 265 #endif
 266
 267
 268 /* del_SV(): return an empty SV head to the free list */
 269
 270 #ifdef DEBUGGING
 271
 272 #define del_SV(p) \
 273     STMT_START {                                        \
 274         LOCK_SV_MUTEX;                                  \
 275         if (DEBUG_D_TEST)                               \
 276             del_sv(p);                                  \
 277         else                                            \
 278             plant_SV(p);                                \
 279         UNLOCK_SV_MUTEX;                                \
 280     } STMT_END
 281
 282 STATIC void
 283 S_del_sv(pTHX_ SV *p)
 284 {
 285     if (DEBUG_D_TEST) {
 286         SV* sva;
 287         bool ok = 0;
 288         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 289             SV *sv = sva + 1;
 290             SV *svend = &sva[SvREFCNT(sva)];
 291             if (p >= sv && p < svend) {
 292                 ok = 1;
 293                 break;
 294             }
 295         }
 296         if (!ok) {
 297             if (ckWARN_d(WARN_INTERNAL))
 298                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 299                             "Attempt to free non-arena SV: 0x%"UVxf
 300                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 301             return;
 302         }
 303     }
 304     plant_SV(p);
 305 }
 306
 307 #else /* ! DEBUGGING */
 308
 309 #define del_SV(p)   plant_SV(p)
 310
 311 #endif /* DEBUGGING */
 312
 313
 314 /*
 315 =head1 SV Manipulation Functions
 316
 317 =for apidoc sv_add_arena
 318
 319 Given a chunk of memory, link it to the head of the list of arenas,
 320 and split it into a list of free SVs.
 321
 322 =cut
 323 */
 324
 325 void
 326 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 327 {
 328     SV* sva = (SV*)ptr;
 329     register SV* sv;
 330     register SV* svend;
 331
 332     /* The first SV in an arena isn't an SV. */
 333     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 334     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 335     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 336
 337     PL_sv_arenaroot = sva;
 338     PL_sv_root = sva + 1;
 339
 340     svend = &sva[SvREFCNT(sva) - 1];
 341     sv = sva + 1;
 342     while (sv < svend) {
 343         SvANY(sv) = (void *)(SV*)(sv + 1);
 344 #ifdef DEBUGGING
 345         SvREFCNT(sv) = 0;
 346 #endif
 347         /* Must always set typemask because it's awlays checked in on cleanup
 348            when the arenas are walked looking for objects.  */
 349         SvFLAGS(sv) = SVTYPEMASK;
 350         sv++;
 351     }
 352     SvANY(sv) = 0;
 353 #ifdef DEBUGGING
 354     SvREFCNT(sv) = 0;
 355 #endif
 356     SvFLAGS(sv) = SVTYPEMASK;
 357 }
 358
 359 /* visit(): call the named function for each non-free SV in the arenas
 360  * whose flags field matches the flags/mask args. */
 361
 362 STATIC I32
 363 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
 364 {
 365     SV* sva;
 366     I32 visited = 0;
 367
 368     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 369         register SV * const svend = &sva[SvREFCNT(sva)];
 370         register SV* sv;
 371         for (sv = sva + 1; sv < svend; ++sv) {
 372             if (SvTYPE(sv) != SVTYPEMASK
 373                     && (sv->sv_flags & mask) == flags
 374                     && SvREFCNT(sv))
 375             {
 376                 (FCALL)(aTHX_ sv);
 377                 ++visited;
 378             }
 379         }
 380     }
 381     return visited;
 382 }
 383
 384 #ifdef DEBUGGING
 385
 386 /* called by sv_report_used() for each live SV */
 387
 388 static void
 389 do_report_used(pTHX_ SV *sv)
 390 {
 391     if (SvTYPE(sv) != SVTYPEMASK) {
 392         PerlIO_printf(Perl_debug_log, "****\n");
 393         sv_dump(sv);
 394     }
 395 }
 396 #endif
 397
 398 /*
 399 =for apidoc sv_report_used
 400
 401 Dump the contents of all SVs not yet freed. (Debugging aid).
 402
 403 =cut
 404 */
 405
 406 void
 407 Perl_sv_report_used(pTHX)
 408 {
 409 #ifdef DEBUGGING
 410     visit(do_report_used, 0, 0);
 411 #endif
 412 }
 413
 414 /* called by sv_clean_objs() for each live SV */
 415
 416 static void
 417 do_clean_objs(pTHX_ SV *sv)
 418 {
 419     SV* rv;
 420
 421     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
 422         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
 423         if (SvWEAKREF(sv)) {
 424             sv_del_backref(sv);
 425             SvWEAKREF_off(sv);
 426             SvRV_set(sv, NULL);
 427         } else {
 428             SvROK_off(sv);
 429             SvRV_set(sv, NULL);
 430             SvREFCNT_dec(rv);
 431         }
 432     }
 433
 434     /* XXX Might want to check arrays, etc. */
 435 }
 436
 437 /* called by sv_clean_objs() for each live SV */
 438
 439 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 440 static void
 441 do_clean_named_objs(pTHX_ SV *sv)
 442 {
 443     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
 444         if ( SvOBJECT(GvSV(sv)) ||
 445              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 446              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 447              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
 448              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 449         {
 450             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 451             SvFLAGS(sv) |= SVf_BREAK;
 452             SvREFCNT_dec(sv);
 453         }
 454     }
 455 }
 456 #endif
 457
 458 /*
 459 =for apidoc sv_clean_objs
 460
 461 Attempt to destroy all objects not yet freed
 462
 463 =cut
 464 */
 465
 466 void
 467 Perl_sv_clean_objs(pTHX)
 468 {
 469     PL_in_clean_objs = TRUE;
 470     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 471 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 472     /* some barnacles may yet remain, clinging to typeglobs */
 473     visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
 474 #endif
 475     PL_in_clean_objs = FALSE;
 476 }
 477
 478 /* called by sv_clean_all() for each live SV */
 479
 480 static void
 481 do_clean_all(pTHX_ SV *sv)
 482 {
 483     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 484     SvFLAGS(sv) |= SVf_BREAK;
 485     if (PL_comppad == (AV*)sv) {
 486         PL_comppad = Nullav;
 487         PL_curpad = Null(SV**);
 488     }
 489     SvREFCNT_dec(sv);
 490 }
 491
 492 /*
 493 =for apidoc sv_clean_all
 494
 495 Decrement the refcnt of each remaining SV, possibly triggering a
 496 cleanup. This function may have to be called multiple times to free
 497 SVs which are in complex self-referential hierarchies.
 498
 499 =cut
 500 */
 501
 502 I32
 503 Perl_sv_clean_all(pTHX)
 504 {
 505     I32 cleaned;
 506     PL_in_clean_all = TRUE;
 507     cleaned = visit(do_clean_all, 0,0);
 508     PL_in_clean_all = FALSE;
 509     return cleaned;
 510 }
 511
 512 /*
 513 =for apidoc sv_free_arenas
 514
 515 Deallocate the memory used by all arenas. Note that all the individual SV
 516 heads and bodies within the arenas must already have been freed.
 517
 518 =cut
 519 */
 520
 521 void
 522 Perl_sv_free_arenas(pTHX)
 523 {
 524     SV* sva;
 525     SV* svanext;
 526     void *arena, *arenanext;
 527
 528     /* Free arenas here, but be careful about fake ones.  (We assume
 529        contiguity of the fake ones with the corresponding real ones.) */
 530
 531     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 532         svanext = (SV*) SvANY(sva);
 533         while (svanext && SvFAKE(svanext))
 534             svanext = (SV*) SvANY(svanext);
 535
 536         if (!SvFAKE(sva))
 537             Safefree((void *)sva);
 538     }
 539
 540     for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
 541         arenanext = *(void **)arena;
 542         Safefree(arena);
 543     }
 544     PL_xnv_arenaroot = 0;
 545     PL_xnv_root = 0;
 546
 547     for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
 548         arenanext = *(void **)arena;
 549         Safefree(arena);
 550     }
 551     PL_xpv_arenaroot = 0;
 552     PL_xpv_root = 0;
 553
 554     for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) {
 555         arenanext = *(void **)arena;
 556         Safefree(arena);
 557     }
 558     PL_xpviv_arenaroot = 0;
 559     PL_xpviv_root = 0;
 560
 561     for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) {
 562         arenanext = *(void **)arena;
 563         Safefree(arena);
 564     }
 565     PL_xpvnv_arenaroot = 0;
 566     PL_xpvnv_root = 0;
 567
 568     for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) {
 569         arenanext = *(void **)arena;
 570         Safefree(arena);
 571     }
 572     PL_xpvcv_arenaroot = 0;
 573     PL_xpvcv_root = 0;
 574
 575     for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) {
 576         arenanext = *(void **)arena;
 577         Safefree(arena);
 578     }
 579     PL_xpvav_arenaroot = 0;
 580     PL_xpvav_root = 0;
 581
 582     for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) {
 583         arenanext = *(void **)arena;
 584         Safefree(arena);
 585     }
 586     PL_xpvhv_arenaroot = 0;
 587     PL_xpvhv_root = 0;
 588
 589     for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) {
 590         arenanext = *(void **)arena;
 591         Safefree(arena);
 592     }
 593     PL_xpvmg_arenaroot = 0;
 594     PL_xpvmg_root = 0;
 595
 596     for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) {
 597         arenanext = *(void **)arena;
 598         Safefree(arena);
 599     }
 600     PL_xpvgv_arenaroot = 0;
 601     PL_xpvgv_root = 0;
 602
 603     for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) {
 604         arenanext = *(void **)arena;
 605         Safefree(arena);
 606     }
 607     PL_xpvlv_arenaroot = 0;
 608     PL_xpvlv_root = 0;
 609
 610     for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) {
 611         arenanext = *(void **)arena;
 612         Safefree(arena);
 613     }
 614     PL_xpvbm_arenaroot = 0;
 615     PL_xpvbm_root = 0;
 616
 617     {
 618         HE *he;
 619         HE *he_next;
 620         for (he = PL_he_arenaroot; he; he = he_next) {
 621             he_next = HeNEXT(he);
 622             Safefree(he);
 623         }
 624     }
 625     PL_he_arenaroot = 0;
 626     PL_he_root = 0;
 627
 628 #if defined(USE_ITHREADS)
 629     {
 630         struct ptr_tbl_ent *pte;
 631         struct ptr_tbl_ent *pte_next;
 632         for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
 633             pte_next = pte->next;
 634             Safefree(pte);
 635         }
 636     }
 637     PL_pte_arenaroot = 0;
 638     PL_pte_root = 0;
 639 #endif
 640
 641     if (PL_nice_chunk)
 642         Safefree(PL_nice_chunk);
 643     PL_nice_chunk = Nullch;
 644     PL_nice_chunk_size = 0;
 645     PL_sv_arenaroot = 0;
 646     PL_sv_root = 0;
 647 }
 648
 649 /* ---------------------------------------------------------------------
 650  *
 651  * support functions for report_uninit()
 652  */
 653
 654 /* the maxiumum size of array or hash where we will scan looking
 655  * for the undefined element that triggered the warning */
 656
 657 #define FUV_MAX_SEARCH_SIZE 1000
 658
 659 /* Look for an entry in the hash whose value has the same SV as val;
 660  * If so, return a mortal copy of the key. */
 661
 662 STATIC SV*
 663 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
 664 {
 665     dVAR;
 666     register HE **array;
 667     I32 i;
 668
 669     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
 670                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
 671         return Nullsv;
 672
 673     array = HvARRAY(hv);
 674
 675     for (i=HvMAX(hv); i>0; i--) {
 676         register HE *entry;
 677         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
 678             if (HeVAL(entry) != val)
 679                 continue;
 680             if (    HeVAL(entry) == &PL_sv_undef ||
 681                     HeVAL(entry) == &PL_sv_placeholder)
 682                 continue;
 683             if (!HeKEY(entry))
 684                 return Nullsv;
 685             if (HeKLEN(entry) == HEf_SVKEY)
 686                 return sv_mortalcopy(HeKEY_sv(entry));
 687             return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
 688         }
 689     }
 690     return Nullsv;
 691 }
 692
 693 /* Look for an entry in the array whose value has the same SV as val;
 694  * If so, return the index, otherwise return -1. */
 695
 696 STATIC I32
 697 S_find_array_subscript(pTHX_ AV *av, SV* val)
 698 {
 699     SV** svp;
 700     I32 i;
 701     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
 702                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
 703         return -1;
 704
 705     svp = AvARRAY(av);
 706     for (i=AvFILLp(av); i>=0; i--) {
 707         if (svp[i] == val && svp[i] != &PL_sv_undef)
 708             return i;
 709     }
 710     return -1;
 711 }
 712
 713 /* S_varname(): return the name of a variable, optionally with a subscript.
 714  * If gv is non-zero, use the name of that global, along with gvtype (one
 715  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
 716  * targ.  Depending on the value of the subscript_type flag, return:
 717  */
 718
 719 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
 720 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
 721 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
 722 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
 723
 724 STATIC SV*
 725 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
 726         SV* keyname, I32 aindex, int subscript_type)
 727 {
 728     AV *av;
 729     SV *sv;
 730
 731     SV * const name = sv_newmortal();
 732     if (gv) {
 733
 734         /* simulate gv_fullname4(), but add literal '^' for $^FOO names
 735          * XXX get rid of all this if gv_fullnameX() ever supports this
 736          * directly */
 737
 738         const char *p;
 739         HV *hv = GvSTASH(gv);
 740         sv_setpv(name, gvtype);
 741         if (!hv)
 742             p = "???";
 743         else if (!(p=HvNAME_get(hv)))
 744             p = "__ANON__";
 745         if (strNE(p, "main")) {
 746             sv_catpv(name,p);
 747             sv_catpvn(name,"::", 2);
 748         }
 749         if (GvNAMELEN(gv)>= 1 &&
 750             ((unsigned int)*GvNAME(gv)) <= 26)
 751         { /* handle $^FOO */
 752             Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
 753             sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
 754         }
 755         else
 756             sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
 757     }
 758     else {
 759         U32 u;
 760         CV *cv = find_runcv(&u);
 761         if (!cv || !CvPADLIST(cv))
 762             return Nullsv;;
 763         av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
 764         sv = *av_fetch(av, targ, FALSE);
 765         /* SvLEN in a pad name is not to be trusted */
 766         sv_setpv(name, SvPV_nolen(sv));
 767     }
 768
 769     if (subscript_type == FUV_SUBSCRIPT_HASH) {
 770         *SvPVX(name) = '$';
 771         sv = NEWSV(0,0);
 772         Perl_sv_catpvf(aTHX_ name, "{%s}",
 773             pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
 774         SvREFCNT_dec(sv);
 775     }
 776     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
 777         *SvPVX(name) = '$';
 778         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
 779     }
 780     else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
 781         sv_insert(name, 0, 0,  "within ", 7);
 782
 783     return name;
 784 }
 785
 786
 787 /*
 788 =for apidoc find_uninit_var
 789
 790 Find the name of the undefined variable (if any) that caused the operator o
 791 to issue a "Use of uninitialized value" warning.
 792 If match is true, only return a name if it's value matches uninit_sv.
 793 So roughly speaking, if a unary operator (such as OP_COS) generates a
 794 warning, then following the direct child of the op may yield an
 795 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
 796 other hand, with OP_ADD there are two branches to follow, so we only print
 797 the variable name if we get an exact match.
 798
 799 The name is returned as a mortal SV.
 800
 801 Assumes that PL_op is the op that originally triggered the error, and that
 802 PL_comppad/PL_curpad points to the currently executing pad.
 803
 804 =cut
 805 */
 806
 807 STATIC SV *
 808 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
 809 {
 810     dVAR;
 811     SV *sv;
 812     AV *av;
 813     SV **svp;
 814     GV *gv;
 815     OP *o, *o2, *kid;
 816
 817     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
 818                             uninit_sv == &PL_sv_placeholder)))
 819         return Nullsv;
 820
 821     switch (obase->op_type) {
 822
 823     case OP_RV2AV:
 824     case OP_RV2HV:
 825     case OP_PADAV:
 826     case OP_PADHV:
 827       {
 828         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
 829         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
 830         I32 index = 0;
 831         SV *keysv = Nullsv;
 832         int subscript_type = FUV_SUBSCRIPT_WITHIN;
 833
 834         if (pad) { /* @lex, %lex */
 835             sv = PAD_SVl(obase->op_targ);
 836             gv = Nullgv;
 837         }
 838         else {
 839             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
 840             /* @global, %global */
 841                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
 842                 if (!gv)
 843                     break;
 844                 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
 845             }
 846             else /* @{expr}, %{expr} */
 847                 return find_uninit_var(cUNOPx(obase)->op_first,
 848                                                     uninit_sv, match);
 849         }
 850
 851         /* attempt to find a match within the aggregate */
 852         if (hash) {
 853             keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
 854             if (keysv)
 855                 subscript_type = FUV_SUBSCRIPT_HASH;
 856         }
 857         else {
 858             index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
 859             if (index >= 0)
 860                 subscript_type = FUV_SUBSCRIPT_ARRAY;
 861         }
 862
 863         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
 864             break;
 865
 866         return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
 867                                     keysv, index, subscript_type);
 868       }
 869
 870     case OP_PADSV:
 871         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
 872             break;
 873         return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
 874                                     Nullsv, 0, FUV_SUBSCRIPT_NONE);
 875
 876     case OP_GVSV:
 877         gv = cGVOPx_gv(obase);
 878         if (!gv || (match && GvSV(gv) != uninit_sv))
 879             break;
 880         return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
 881
 882     case OP_AELEMFAST:
 883         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
 884             if (match) {
 885                 av = (AV*)PAD_SV(obase->op_targ);
 886                 if (!av || SvRMAGICAL(av))
 887                     break;
 888                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
 889                 if (!svp || *svp != uninit_sv)
 890                     break;
 891             }
 892             return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
 893                     Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
 894         }
 895         else {
 896             gv = cGVOPx_gv(obase);
 897             if (!gv)
 898                 break;
 899             if (match) {
 900                 av = GvAV(gv);
 901                 if (!av || SvRMAGICAL(av))
 902                     break;
 903                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
 904                 if (!svp || *svp != uninit_sv)
 905                     break;
 906             }
 907             return S_varname(aTHX_ gv, "$", 0,
 908                     Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
 909         }
 910         break;
 911
 912     case OP_EXISTS:
 913         o = cUNOPx(obase)->op_first;
 914         if (!o || o->op_type != OP_NULL ||
 915                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
 916             break;
 917         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
 918
 919     case OP_AELEM:
 920     case OP_HELEM:
 921         if (PL_op == obase)
 922             /* $a[uninit_expr] or $h{uninit_expr} */
 923             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
 924
 925         gv = Nullgv;
 926         o = cBINOPx(obase)->op_first;
 927         kid = cBINOPx(obase)->op_last;
 928
 929         /* get the av or hv, and optionally the gv */
 930         sv = Nullsv;
 931         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
 932             sv = PAD_SV(o->op_targ);
 933         }
 934         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
 935                 && cUNOPo->op_first->op_type == OP_GV)
 936         {
 937             gv = cGVOPx_gv(cUNOPo->op_first);
 938             if (!gv)
 939                 break;
 940             sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
 941         }
 942         if (!sv)
 943             break;
 944
 945         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
 946             /* index is constant */
 947             if (match) {
 948                 if (SvMAGICAL(sv))
 949                     break;
 950                 if (obase->op_type == OP_HELEM) {
 951                     HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
 952                     if (!he || HeVAL(he) != uninit_sv)
 953                         break;
 954                 }
 955                 else {
 956                     svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
 957                     if (!svp || *svp != uninit_sv)
 958                         break;
 959                 }
 960             }
 961             if (obase->op_type == OP_HELEM)
 962                 return S_varname(aTHX_ gv, "%", o->op_targ,
 963                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
 964             else
 965                 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
 966                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
 967             ;
 968         }
 969         else  {
 970             /* index is an expression;
 971              * attempt to find a match within the aggregate */
 972             if (obase->op_type == OP_HELEM) {
 973                 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
 974                 if (keysv)
 975                     return S_varname(aTHX_ gv, "%", o->op_targ,
 976                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
 977             }
 978             else {
 979                 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
 980                 if (index >= 0)
 981                     return S_varname(aTHX_ gv, "@", o->op_targ,
 982                                         Nullsv, index, FUV_SUBSCRIPT_ARRAY);
 983             }
 984             if (match)
 985                 break;
 986             return S_varname(aTHX_ gv,
 987                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
 988                 ? "@" : "%",
 989                 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
 990         }
 991
 992         break;
 993
 994     case OP_AASSIGN:
 995         /* only examine RHS */
 996         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
 997
 998     case OP_OPEN:
 999         o = cUNOPx(obase)->op_first;
1000         if (o->op_type == OP_PUSHMARK)
1001             o = o->op_sibling;
1002
1003         if (!o->op_sibling) {
1004             /* one-arg version of open is highly magical */
1005
1006             if (o->op_type == OP_GV) { /* open FOO; */
1007                 gv = cGVOPx_gv(o);
1008                 if (match && GvSV(gv) != uninit_sv)
1009                     break;
1010                 return S_varname(aTHX_ gv, "$", 0,
1011                             Nullsv, 0, FUV_SUBSCRIPT_NONE);
1012             }
1013             /* other possibilities not handled are:
1014              * open $x; or open my $x;  should return '${*$x}'
1015              * open expr;               should return '$'.expr ideally
1016              */
1017              break;
1018         }
1019         goto do_op;
1020
1021     /* ops where $_ may be an implicit arg */
1022     case OP_TRANS:
1023     case OP_SUBST:
1024     case OP_MATCH:
1025         if ( !(obase->op_flags & OPf_STACKED)) {
1026             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1027                                  ? PAD_SVl(obase->op_targ)
1028                                  : DEFSV))
1029             {
1030                 sv = sv_newmortal();
1031                 sv_setpv(sv, "$_");
1032                 return sv;
1033             }
1034         }
1035         goto do_op;
1036
1037     case OP_PRTF:
1038     case OP_PRINT:
1039         /* skip filehandle as it can't produce 'undef' warning  */
1040         o = cUNOPx(obase)->op_first;
1041         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1042             o = o->op_sibling->op_sibling;
1043         goto do_op2;
1044
1045
1046     case OP_RV2SV:
1047     case OP_CUSTOM:
1048     case OP_ENTERSUB:
1049         match = 1; /* XS or custom code could trigger random warnings */
1050         goto do_op;
1051
1052     case OP_SCHOMP:
1053     case OP_CHOMP:
1054         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1055             return sv_2mortal(newSVpv("${$/}", 0));
1056         /* FALL THROUGH */
1057
1058     default:
1059     do_op:
1060         if (!(obase->op_flags & OPf_KIDS))
1061             break;
1062         o = cUNOPx(obase)->op_first;
1063
1064     do_op2:
1065         if (!o)
1066             break;
1067
1068         /* if all except one arg are constant, or have no side-effects,
1069          * or are optimized away, then it's unambiguous */
1070         o2 = Nullop;
1071         for (kid=o; kid; kid = kid->op_sibling) {
1072             if (kid &&
1073                 (    (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1074                   || (kid->op_type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
1075                   || (kid->op_type == OP_PUSHMARK)
1076                 )
1077             )
1078                 continue;
1079             if (o2) { /* more than one found */
1080                 o2 = Nullop;
1081                 break;
1082             }
1083             o2 = kid;
1084         }
1085         if (o2)
1086             return find_uninit_var(o2, uninit_sv, match);
1087
1088         /* scan all args */
1089         while (o) {
1090             sv = find_uninit_var(o, uninit_sv, 1);
1091             if (sv)
1092                 return sv;
1093             o = o->op_sibling;
1094         }
1095         break;
1096     }
1097     return Nullsv;
1098 }
1099
1100
1101 /*
1102 =for apidoc report_uninit
1103
1104 Print appropriate "Use of uninitialized variable" warning
1105
1106 =cut
1107 */
1108
1109 void
1110 Perl_report_uninit(pTHX_ SV* uninit_sv)
1111 {
1112     if (PL_op) {
1113         SV* varname = Nullsv;
1114         if (uninit_sv) {
1115             varname = find_uninit_var(PL_op, uninit_sv,0);
1116             if (varname)
1117                 sv_insert(varname, 0, 0, " ", 1);
1118         }
1119         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1120                 varname ? SvPV_nolen(varname) : "",
1121                 " in ", OP_DESC(PL_op));
1122     }
1123     else
1124         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1125                     "", "", "");
1126 }
1127
1128 /* allocate another arena's worth of NV bodies */
1129
1130 STATIC void
1131 S_more_xnv(pTHX)
1132 {
1133     NV* xnv;
1134     NV* xnvend;
1135     void *ptr;
1136     New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV);
1137     *((void **) ptr) = (void *)PL_xnv_arenaroot;
1138     PL_xnv_arenaroot = ptr;
1139
1140     xnv = (NV*) ptr;
1141     xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
1142     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1143     PL_xnv_root = xnv;
1144     while (xnv < xnvend) {
1145         *(NV**)xnv = (NV*)(xnv + 1);
1146         xnv++;
1147     }
1148     *(NV**)xnv = 0;
1149 }
1150
1151 /* allocate another arena's worth of struct xpv */
1152
1153 STATIC void
1154 S_more_xpv(pTHX)
1155 {
1156     xpv_allocated* xpv;
1157     xpv_allocated* xpvend;
1158     New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated);
1159     *((xpv_allocated**)xpv) = PL_xpv_arenaroot;
1160     PL_xpv_arenaroot = xpv;
1161
1162     xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1];
1163     PL_xpv_root = ++xpv;
1164     while (xpv < xpvend) {
1165         *((xpv_allocated**)xpv) = xpv + 1;
1166         xpv++;
1167     }
1168     *((xpv_allocated**)xpv) = 0;
1169 }
1170
1171 /* allocate another arena's worth of struct xpviv */
1172
1173 STATIC void
1174 S_more_xpviv(pTHX)
1175 {
1176     xpviv_allocated* xpviv;
1177     xpviv_allocated* xpvivend;
1178     New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated);
1179     *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot;
1180     PL_xpviv_arenaroot = xpviv;
1181
1182     xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1];
1183     PL_xpviv_root = ++xpviv;
1184     while (xpviv < xpvivend) {
1185         *((xpviv_allocated**)xpviv) = xpviv + 1;
1186         xpviv++;
1187     }
1188     *((xpviv_allocated**)xpviv) = 0;
1189 }
1190
1191 /* allocate another arena's worth of struct xpvnv */
1192
1193 STATIC void
1194 S_more_xpvnv(pTHX)
1195 {
1196     XPVNV* xpvnv;
1197     XPVNV* xpvnvend;
1198     New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
1199     *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot;
1200     PL_xpvnv_arenaroot = xpvnv;
1201
1202     xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
1203     PL_xpvnv_root = ++xpvnv;
1204     while (xpvnv < xpvnvend) {
1205         *((XPVNV**)xpvnv) = xpvnv + 1;
1206         xpvnv++;
1207     }
1208     *((XPVNV**)xpvnv) = 0;
1209 }
1210
1211 /* allocate another arena's worth of struct xpvcv */
1212
1213 STATIC void
1214 S_more_xpvcv(pTHX)
1215 {
1216     XPVCV* xpvcv;
1217     XPVCV* xpvcvend;
1218     New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
1219     *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot;
1220     PL_xpvcv_arenaroot = xpvcv;
1221
1222     xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
1223     PL_xpvcv_root = ++xpvcv;
1224     while (xpvcv < xpvcvend) {
1225         *((XPVCV**)xpvcv) = xpvcv + 1;
1226         xpvcv++;
1227     }
1228     *((XPVCV**)xpvcv) = 0;
1229 }
1230
1231 /* allocate another arena's worth of struct xpvav */
1232
1233 STATIC void
1234 S_more_xpvav(pTHX)
1235 {
1236     xpvav_allocated* xpvav;
1237      xpvav_allocated* xpvavend;
1238     New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated),
1239         xpvav_allocated);
1240     *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot;
1241     PL_xpvav_arenaroot = xpvav;
1242
1243     xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1];
1244     PL_xpvav_root = ++xpvav;
1245     while (xpvav < xpvavend) {
1246         *((xpvav_allocated**)xpvav) = xpvav + 1;
1247         xpvav++;
1248     }
1249     *((xpvav_allocated**)xpvav) = 0;
1250 }
1251
1252 /* allocate another arena's worth of struct xpvhv */
1253
1254 STATIC void
1255 S_more_xpvhv(pTHX)
1256 {
1257     xpvhv_allocated* xpvhv;
1258     xpvhv_allocated* xpvhvend;
1259     New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated),
1260         xpvhv_allocated);
1261     *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot;
1262     PL_xpvhv_arenaroot = xpvhv;
1263
1264     xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1];
1265     PL_xpvhv_root = ++xpvhv;
1266     while (xpvhv < xpvhvend) {
1267         *((xpvhv_allocated**)xpvhv) = xpvhv + 1;
1268         xpvhv++;
1269     }
1270     *((xpvhv_allocated**)xpvhv) = 0;
1271 }
1272
1273 /* allocate another arena's worth of struct xpvmg */
1274
1275 STATIC void
1276 S_more_xpvmg(pTHX)
1277 {
1278     XPVMG* xpvmg;
1279     XPVMG* xpvmgend;
1280     New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
1281     *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot;
1282     PL_xpvmg_arenaroot = xpvmg;
1283
1284     xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
1285     PL_xpvmg_root = ++xpvmg;
1286     while (xpvmg < xpvmgend) {
1287         *((XPVMG**)xpvmg) = xpvmg + 1;
1288         xpvmg++;
1289     }
1290     *((XPVMG**)xpvmg) = 0;
1291 }
1292
1293 /* allocate another arena's worth of struct xpvgv */
1294
1295 STATIC void
1296 S_more_xpvgv(pTHX)
1297 {
1298     XPVGV* xpvgv;
1299     XPVGV* xpvgvend;
1300     New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
1301     *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
1302     PL_xpvgv_arenaroot = xpvgv;
1303
1304     xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
1305     PL_xpvgv_root = ++xpvgv;
1306     while (xpvgv < xpvgvend) {
1307         *((XPVGV**)xpvgv) = xpvgv + 1;
1308         xpvgv++;
1309     }
1310     *((XPVGV**)xpvgv) = 0;
1311 }
1312
1313 /* allocate another arena's worth of struct xpvlv */
1314
1315 STATIC void
1316 S_more_xpvlv(pTHX)
1317 {
1318     XPVLV* xpvlv;
1319     XPVLV* xpvlvend;
1320     New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
1321     *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot;
1322     PL_xpvlv_arenaroot = xpvlv;
1323
1324     xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
1325     PL_xpvlv_root = ++xpvlv;
1326     while (xpvlv < xpvlvend) {
1327         *((XPVLV**)xpvlv) = xpvlv + 1;
1328         xpvlv++;
1329     }
1330     *((XPVLV**)xpvlv) = 0;
1331 }
1332
1333 /* allocate another arena's worth of struct xpvbm */
1334
1335 STATIC void
1336 S_more_xpvbm(pTHX)
1337 {
1338     XPVBM* xpvbm;
1339     XPVBM* xpvbmend;
1340     New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
1341     *((XPVBM**)xpvbm) = PL_xpvbm_arenaroot;
1342     PL_xpvbm_arenaroot = xpvbm;
1343
1344     xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
1345     PL_xpvbm_root = ++xpvbm;
1346     while (xpvbm < xpvbmend) {
1347         *((XPVBM**)xpvbm) = xpvbm + 1;
1348         xpvbm++;
1349     }
1350     *((XPVBM**)xpvbm) = 0;
1351 }
1352
1353 /* grab a new NV body from the free list, allocating more if necessary */
1354
1355 STATIC XPVNV*
1356 S_new_xnv(pTHX)
1357 {
1358     NV* xnv;
1359     LOCK_SV_MUTEX;
1360     if (!PL_xnv_root)
1361         S_more_xnv(aTHX);
1362     xnv = PL_xnv_root;
1363     PL_xnv_root = *(NV**)xnv;
1364     UNLOCK_SV_MUTEX;
1365     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1366 }
1367
1368 /* return an NV body to the free list */
1369
1370 STATIC void
1371 S_del_xnv(pTHX_ XPVNV *p)
1372 {
1373     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1374     LOCK_SV_MUTEX;
1375     *(NV**)xnv = PL_xnv_root;
1376     PL_xnv_root = xnv;
1377     UNLOCK_SV_MUTEX;
1378 }
1379
1380 /* grab a new struct xpv from the free list, allocating more if necessary */
1381
1382 STATIC XPV*
1383 S_new_xpv(pTHX)
1384 {
1385     xpv_allocated* xpv;
1386     LOCK_SV_MUTEX;
1387     if (!PL_xpv_root)
1388         S_more_xpv(aTHX);
1389     xpv = PL_xpv_root;
1390     PL_xpv_root = *(xpv_allocated**)xpv;
1391     UNLOCK_SV_MUTEX;
1392     /* If xpv_allocated is the same structure as XPV then the two OFFSETs
1393        sum to zero, and the pointer is unchanged. If the allocated structure
1394        is smaller (no initial IV actually allocated) then the net effect is
1395        to subtract the size of the IV from the pointer, to return a new pointer
1396        as if an initial IV were actually allocated.  */
1397     return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur)
1398                   + STRUCT_OFFSET(xpv_allocated, xpv_cur));
1399 }
1400
1401 /* return a struct xpv to the free list */
1402
1403 STATIC void
1404 S_del_xpv(pTHX_ XPV *p)
1405 {
1406     xpv_allocated* xpv
1407         = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur)
1408                            - STRUCT_OFFSET(xpv_allocated, xpv_cur));
1409     LOCK_SV_MUTEX;
1410     *(xpv_allocated**)xpv = PL_xpv_root;
1411     PL_xpv_root = xpv;
1412     UNLOCK_SV_MUTEX;
1413 }
1414
1415 /* grab a new struct xpviv from the free list, allocating more if necessary */
1416
1417 STATIC XPVIV*
1418 S_new_xpviv(pTHX)
1419 {
1420     xpviv_allocated* xpviv;
1421     LOCK_SV_MUTEX;
1422     if (!PL_xpviv_root)
1423         S_more_xpviv(aTHX);
1424     xpviv = PL_xpviv_root;
1425     PL_xpviv_root = *(xpviv_allocated**)xpviv;
1426     UNLOCK_SV_MUTEX;
1427     /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs
1428        sum to zero, and the pointer is unchanged. If the allocated structure
1429        is smaller (no initial IV actually allocated) then the net effect is
1430        to subtract the size of the IV from the pointer, to return a new pointer
1431        as if an initial IV were actually allocated.  */
1432     return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur)
1433                   + STRUCT_OFFSET(xpviv_allocated, xpv_cur));
1434 }
1435
1436 /* return a struct xpviv to the free list */
1437
1438 STATIC void
1439 S_del_xpviv(pTHX_ XPVIV *p)
1440 {
1441     xpviv_allocated* xpviv
1442         = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur)
1443                            - STRUCT_OFFSET(xpviv_allocated, xpv_cur));
1444     LOCK_SV_MUTEX;
1445     *(xpviv_allocated**)xpviv = PL_xpviv_root;
1446     PL_xpviv_root = xpviv;
1447     UNLOCK_SV_MUTEX;
1448 }
1449
1450 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1451
1452 STATIC XPVNV*
1453 S_new_xpvnv(pTHX)
1454 {
1455     XPVNV* xpvnv;
1456     LOCK_SV_MUTEX;
1457     if (!PL_xpvnv_root)
1458         S_more_xpvnv(aTHX);
1459     xpvnv = PL_xpvnv_root;
1460     PL_xpvnv_root = *(XPVNV**)xpvnv;
1461     UNLOCK_SV_MUTEX;
1462     return xpvnv;
1463 }
1464
1465 /* return a struct xpvnv to the free list */
1466
1467 STATIC void
1468 S_del_xpvnv(pTHX_ XPVNV *p)
1469 {
1470     LOCK_SV_MUTEX;
1471     *(XPVNV**)p = PL_xpvnv_root;
1472     PL_xpvnv_root = p;
1473     UNLOCK_SV_MUTEX;
1474 }
1475
1476 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1477
1478 STATIC XPVCV*
1479 S_new_xpvcv(pTHX)
1480 {
1481     XPVCV* xpvcv;
1482     LOCK_SV_MUTEX;
1483     if (!PL_xpvcv_root)
1484         S_more_xpvcv(aTHX);
1485     xpvcv = PL_xpvcv_root;
1486     PL_xpvcv_root = *(XPVCV**)xpvcv;
1487     UNLOCK_SV_MUTEX;
1488     return xpvcv;
1489 }
1490
1491 /* return a struct xpvcv to the free list */
1492
1493 STATIC void
1494 S_del_xpvcv(pTHX_ XPVCV *p)
1495 {
1496     LOCK_SV_MUTEX;
1497     *(XPVCV**)p = PL_xpvcv_root;
1498     PL_xpvcv_root = p;
1499     UNLOCK_SV_MUTEX;
1500 }
1501
1502 /* grab a new struct xpvav from the free list, allocating more if necessary */
1503
1504 STATIC XPVAV*
1505 S_new_xpvav(pTHX)
1506 {
1507     xpvav_allocated* xpvav;
1508     LOCK_SV_MUTEX;
1509     if (!PL_xpvav_root)
1510         S_more_xpvav(aTHX);
1511     xpvav = PL_xpvav_root;
1512     PL_xpvav_root = *(xpvav_allocated**)xpvav;
1513     UNLOCK_SV_MUTEX;
1514     return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill)
1515                     + STRUCT_OFFSET(xpvav_allocated, xav_fill));
1516 }
1517
1518 /* return a struct xpvav to the free list */
1519
1520 STATIC void
1521 S_del_xpvav(pTHX_ XPVAV *p)
1522 {
1523     xpvav_allocated* xpvav
1524         = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill)
1525                              - STRUCT_OFFSET(xpvav_allocated, xav_fill));
1526     LOCK_SV_MUTEX;
1527     *(xpvav_allocated**)xpvav = PL_xpvav_root;
1528     PL_xpvav_root = xpvav;
1529     UNLOCK_SV_MUTEX;
1530 }
1531
1532 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1533
1534 STATIC XPVHV*
1535 S_new_xpvhv(pTHX)
1536 {
1537     xpvhv_allocated* xpvhv;
1538     LOCK_SV_MUTEX;
1539     if (!PL_xpvhv_root)
1540         S_more_xpvhv(aTHX);
1541     xpvhv = PL_xpvhv_root;
1542     PL_xpvhv_root = *(xpvhv_allocated**)xpvhv;
1543     UNLOCK_SV_MUTEX;
1544     return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill)
1545                     + STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
1546 }
1547
1548 /* return a struct xpvhv to the free list */
1549
1550 STATIC void
1551 S_del_xpvhv(pTHX_ XPVHV *p)
1552 {
1553     xpvhv_allocated* xpvhv
1554         = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill)
1555                              - STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
1556     LOCK_SV_MUTEX;
1557     *(xpvhv_allocated**)xpvhv = PL_xpvhv_root;
1558     PL_xpvhv_root = xpvhv;
1559     UNLOCK_SV_MUTEX;
1560 }
1561
1562 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1563
1564 STATIC XPVMG*
1565 S_new_xpvmg(pTHX)
1566 {
1567     XPVMG* xpvmg;
1568     LOCK_SV_MUTEX;
1569     if (!PL_xpvmg_root)
1570         S_more_xpvmg(aTHX);
1571     xpvmg = PL_xpvmg_root;
1572     PL_xpvmg_root = *(XPVMG**)xpvmg;
1573     UNLOCK_SV_MUTEX;
1574     return xpvmg;
1575 }
1576
1577 /* return a struct xpvmg to the free list */
1578
1579 STATIC void
1580 S_del_xpvmg(pTHX_ XPVMG *p)
1581 {
1582     LOCK_SV_MUTEX;
1583     *(XPVMG**)p = PL_xpvmg_root;
1584     PL_xpvmg_root = p;
1585     UNLOCK_SV_MUTEX;
1586 }
1587
1588 /* grab a new struct xpvgv from the free list, allocating more if necessary */
1589
1590 STATIC XPVGV*
1591 S_new_xpvgv(pTHX)
1592 {
1593     XPVGV* xpvgv;
1594     LOCK_SV_MUTEX;
1595     if (!PL_xpvgv_root)
1596         S_more_xpvgv(aTHX);
1597     xpvgv = PL_xpvgv_root;
1598     PL_xpvgv_root = *(XPVGV**)xpvgv;
1599     UNLOCK_SV_MUTEX;
1600     return xpvgv;
1601 }
1602
1603 /* return a struct xpvgv to the free list */
1604
1605 STATIC void
1606 S_del_xpvgv(pTHX_ XPVGV *p)
1607 {
1608     LOCK_SV_MUTEX;
1609     *(XPVGV**)p = PL_xpvgv_root;
1610     PL_xpvgv_root = p;
1611     UNLOCK_SV_MUTEX;
1612 }
1613
1614 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1615
1616 STATIC XPVLV*
1617 S_new_xpvlv(pTHX)
1618 {
1619     XPVLV* xpvlv;
1620     LOCK_SV_MUTEX;
1621     if (!PL_xpvlv_root)
1622         S_more_xpvlv(aTHX);
1623     xpvlv = PL_xpvlv_root;
1624     PL_xpvlv_root = *(XPVLV**)xpvlv;
1625     UNLOCK_SV_MUTEX;
1626     return xpvlv;
1627 }
1628
1629 /* return a struct xpvlv to the free list */
1630
1631 STATIC void
1632 S_del_xpvlv(pTHX_ XPVLV *p)
1633 {
1634     LOCK_SV_MUTEX;
1635     *(XPVLV**)p = PL_xpvlv_root;
1636     PL_xpvlv_root = p;
1637     UNLOCK_SV_MUTEX;
1638 }
1639
1640 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1641
1642 STATIC XPVBM*
1643 S_new_xpvbm(pTHX)
1644 {
1645     XPVBM* xpvbm;
1646     LOCK_SV_MUTEX;
1647     if (!PL_xpvbm_root)
1648         S_more_xpvbm(aTHX);
1649     xpvbm = PL_xpvbm_root;
1650     PL_xpvbm_root = *(XPVBM**)xpvbm;
1651     UNLOCK_SV_MUTEX;
1652     return xpvbm;
1653 }
1654
1655 /* return a struct xpvbm to the free list */
1656
1657 STATIC void
1658 S_del_xpvbm(pTHX_ XPVBM *p)
1659 {
1660     LOCK_SV_MUTEX;
1661     *(XPVBM**)p = PL_xpvbm_root;
1662     PL_xpvbm_root = p;
1663     UNLOCK_SV_MUTEX;
1664 }
1665
1666 #define my_safemalloc(s)        (void*)safemalloc(s)
1667 #define my_safefree(p)  safefree((char*)p)
1668
1669 #ifdef PURIFY
1670
1671 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1672 #define del_XNV(p)      my_safefree(p)
1673
1674 #define new_XPV()       my_safemalloc(sizeof(XPV))
1675 #define del_XPV(p)      my_safefree(p)
1676
1677 #define new_XPVIV()     my_safemalloc(sizeof(XPVIV))
1678 #define del_XPVIV(p)    my_safefree(p)
1679
1680 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1681 #define del_XPVNV(p)    my_safefree(p)
1682
1683 #define new_XPVCV()     my_safemalloc(sizeof(XPVCV))
1684 #define del_XPVCV(p)    my_safefree(p)
1685
1686 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1687 #define del_XPVAV(p)    my_safefree(p)
1688
1689 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1690 #define del_XPVHV(p)    my_safefree(p)
1691
1692 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1693 #define del_XPVMG(p)    my_safefree(p)
1694
1695 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1696 #define del_XPVGV(p)    my_safefree(p)
1697
1698 #define new_XPVLV()     my_safemalloc(sizeof(XPVLV))
1699 #define del_XPVLV(p)    my_safefree(p)
1700
1701 #define new_XPVBM()     my_safemalloc(sizeof(XPVBM))
1702 #define del_XPVBM(p)    my_safefree(p)
1703
1704 #else /* !PURIFY */
1705
1706 #define new_XNV()       (void*)new_xnv()
1707 #define del_XNV(p)      del_xnv((XPVNV*) p)
1708
1709 #define new_XPV()       (void*)new_xpv()
1710 #define del_XPV(p)      del_xpv((XPV *)p)
1711
1712 #define new_XPVIV()     (void*)new_xpviv()
1713 #define del_XPVIV(p)    del_xpviv((XPVIV *)p)
1714
1715 #define new_XPVNV()     (void*)new_xpvnv()
1716 #define del_XPVNV(p)    del_xpvnv((XPVNV *)p)
1717
1718 #define new_XPVCV()     (void*)new_xpvcv()
1719 #define del_XPVCV(p)    del_xpvcv((XPVCV *)p)
1720
1721 #define new_XPVAV()     (void*)new_xpvav()
1722 #define del_XPVAV(p)    del_xpvav((XPVAV *)p)
1723
1724 #define new_XPVHV()     (void*)new_xpvhv()
1725 #define del_XPVHV(p)    del_xpvhv((XPVHV *)p)
1726
1727 #define new_XPVMG()     (void*)new_xpvmg()
1728 #define del_XPVMG(p)    del_xpvmg((XPVMG *)p)
1729
1730 #define new_XPVGV()     (void*)new_xpvgv()
1731 #define del_XPVGV(p)    del_xpvgv((XPVGV *)p)
1732
1733 #define new_XPVLV()     (void*)new_xpvlv()
1734 #define del_XPVLV(p)    del_xpvlv((XPVLV *)p)
1735
1736 #define new_XPVBM()     (void*)new_xpvbm()
1737 #define del_XPVBM(p)    del_xpvbm((XPVBM *)p)
1738
1739 #endif /* PURIFY */
1740
1741 #define new_XPVFM()     my_safemalloc(sizeof(XPVFM))
1742 #define del_XPVFM(p)    my_safefree(p)
1743
1744 #define new_XPVIO()     my_safemalloc(sizeof(XPVIO))
1745 #define del_XPVIO(p)    my_safefree(p)
1746
1747 /*
1748 =for apidoc sv_upgrade
1749
1750 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1751 SV, then copies across as much information as possible from the old body.
1752 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1753
1754 =cut
1755 */
1756
1757 bool
1758 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1759 {
1760
1761     char*       pv;
1762     U32         cur;
1763     U32         len;
1764     IV          iv;
1765     NV          nv;
1766     MAGIC*      magic;
1767     HV*         stash;
1768
1769     if (mt != SVt_PV && SvIsCOW(sv)) {
1770         sv_force_normal_flags(sv, 0);
1771     }
1772
1773     if (SvTYPE(sv) == mt)
1774         return TRUE;
1775
1776     pv = NULL;
1777     cur = 0;
1778     len = 0;
1779     iv = 0;
1780     nv = 0.0;
1781     magic = NULL;
1782     stash = Nullhv;
1783
1784     switch (SvTYPE(sv)) {
1785     case SVt_NULL:
1786         break;
1787     case SVt_IV:
1788         iv      = SvIVX(sv);
1789         if (mt == SVt_NV)
1790             mt = SVt_PVNV;
1791         else if (mt < SVt_PVIV)
1792             mt = SVt_PVIV;
1793         break;
1794     case SVt_NV:
1795         nv      = SvNVX(sv);
1796         del_XNV(SvANY(sv));
1797         if (mt < SVt_PVNV)
1798             mt = SVt_PVNV;
1799         break;
1800     case SVt_RV:
1801         pv      = (char*)SvRV(sv);
1802         break;
1803     case SVt_PV:
1804         pv      = SvPVX(sv);
1805         cur     = SvCUR(sv);
1806         len     = SvLEN(sv);
1807         del_XPV(SvANY(sv));
1808         if (mt <= SVt_IV)
1809             mt = SVt_PVIV;
1810         else if (mt == SVt_NV)
1811             mt = SVt_PVNV;
1812         break;
1813     case SVt_PVIV:
1814         pv      = SvPVX(sv);
1815         cur     = SvCUR(sv);
1816         len     = SvLEN(sv);
1817         iv      = SvIVX(sv);
1818         del_XPVIV(SvANY(sv));
1819         break;
1820     case SVt_PVNV:
1821         pv      = SvPVX(sv);
1822         cur     = SvCUR(sv);
1823         len     = SvLEN(sv);
1824         iv      = SvIVX(sv);
1825         nv      = SvNVX(sv);
1826         del_XPVNV(SvANY(sv));
1827         break;
1828     case SVt_PVMG:
1829         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1830            there's no way that it can be safely upgraded, because perl.c
1831            expects to Safefree(SvANY(PL_mess_sv))  */
1832         assert(sv != PL_mess_sv);
1833         /* This flag bit is used to mean other things in other scalar types.
1834            Given that it only has meaning inside the pad, it shouldn't be set
1835            on anything that can get upgraded.  */
1836         assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1837         pv      = SvPVX(sv);
1838         cur     = SvCUR(sv);
1839         len     = SvLEN(sv);
1840         iv      = SvIVX(sv);
1841         nv      = SvNVX(sv);
1842         magic   = SvMAGIC(sv);
1843         stash   = SvSTASH(sv);
1844         del_XPVMG(SvANY(sv));
1845         break;
1846     default:
1847         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1848     }
1849
1850     SvFLAGS(sv) &= ~SVTYPEMASK;
1851     SvFLAGS(sv) |= mt;
1852
1853     switch (mt) {
1854     case SVt_NULL:
1855         Perl_croak(aTHX_ "Can't upgrade to undef");
1856     case SVt_IV:
1857         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1858         SvIV_set(sv, iv);
1859         break;
1860     case SVt_NV:
1861         SvANY(sv) = new_XNV();
1862         SvNV_set(sv, nv);
1863         break;
1864     case SVt_RV:
1865         SvANY(sv) = &sv->sv_u.svu_rv;
1866         SvRV_set(sv, (SV*)pv);
1867         break;
1868     case SVt_PVHV:
1869         SvANY(sv) = new_XPVHV();
1870         ((XPVHV*) SvANY(sv))->xhv_aux = 0;
1871         HvFILL(sv)      = 0;
1872         HvMAX(sv)       = 0;
1873         HvTOTALKEYS(sv) = 0;
1874
1875         /* Fall through...  */
1876         if (0) {
1877         case SVt_PVAV:
1878             SvANY(sv) = new_XPVAV();
1879             AvMAX(sv)   = -1;
1880             AvFILLp(sv) = -1;
1881             AvALLOC(sv) = 0;
1882             AvARYLEN(sv)= 0;
1883             AvREAL_only(sv);
1884         }
1885         /* to here.  */
1886         /* XXX? Only SVt_NULL is ever upgraded to AV or HV?  */
1887         assert(!pv);
1888         /* FIXME. Should be able to remove all this if()... if the above
1889            assertion is genuinely always true.  */
1890         if(SvOOK(sv)) {
1891             pv -= iv;
1892             SvFLAGS(sv) &= ~SVf_OOK;
1893         }
1894         Safefree(pv);
1895         SvPV_set(sv, (char*)0);
1896         SvMAGIC_set(sv, magic);
1897         SvSTASH_set(sv, stash);
1898         break;
1899
1900     case SVt_PVIO:
1901         SvANY(sv) = new_XPVIO();
1902         Zero(SvANY(sv), 1, XPVIO);
1903         IoPAGE_LEN(sv)  = 60;
1904         goto set_magic_common;
1905     case SVt_PVFM:
1906         SvANY(sv) = new_XPVFM();
1907         Zero(SvANY(sv), 1, XPVFM);
1908         goto set_magic_common;
1909     case SVt_PVBM:
1910         SvANY(sv) = new_XPVBM();
1911         BmRARE(sv)      = 0;
1912         BmUSEFUL(sv)    = 0;
1913         BmPREVIOUS(sv)  = 0;
1914         goto set_magic_common;
1915     case SVt_PVGV:
1916         SvANY(sv) = new_XPVGV();
1917         GvGP(sv)        = 0;
1918         GvNAME(sv)      = 0;
1919         GvNAMELEN(sv)   = 0;
1920         GvSTASH(sv)     = 0;
1921         GvFLAGS(sv)     = 0;
1922         goto set_magic_common;
1923     case SVt_PVCV:
1924         SvANY(sv) = new_XPVCV();
1925         Zero(SvANY(sv), 1, XPVCV);
1926         goto set_magic_common;
1927     case SVt_PVLV:
1928         SvANY(sv) = new_XPVLV();
1929         LvTARGOFF(sv)   = 0;
1930         LvTARGLEN(sv)   = 0;
1931         LvTARG(sv)      = 0;
1932         LvTYPE(sv)      = 0;
1933         GvGP(sv)        = 0;
1934         GvNAME(sv)      = 0;
1935         GvNAMELEN(sv)   = 0;
1936         GvSTASH(sv)     = 0;
1937         GvFLAGS(sv)     = 0;
1938         /* Fall through.  */
1939         if (0) {
1940         case SVt_PVMG:
1941             SvANY(sv) = new_XPVMG();
1942         }
1943     set_magic_common:
1944         SvMAGIC_set(sv, magic);
1945         SvSTASH_set(sv, stash);
1946         /* Fall through.  */
1947         if (0) {
1948         case SVt_PVNV:
1949             SvANY(sv) = new_XPVNV();
1950         }
1951         SvNV_set(sv, nv);
1952         /* Fall through.  */
1953         if (0) {
1954         case SVt_PVIV:
1955             SvANY(sv) = new_XPVIV();
1956             if (SvNIOK(sv))
1957                 (void)SvIOK_on(sv);
1958             SvNOK_off(sv);
1959         }
1960         SvIV_set(sv, iv);
1961         /* Fall through.  */
1962         if (0) {
1963         case SVt_PV:
1964             SvANY(sv) = new_XPV();
1965         }
1966         SvPV_set(sv, pv);
1967         SvCUR_set(sv, cur);
1968         SvLEN_set(sv, len);
1969         break;
1970     }
1971     return TRUE;
1972 }
1973
1974 /*
1975 =for apidoc sv_backoff
1976
1977 Remove any string offset. You should normally use the C<SvOOK_off> macro
1978 wrapper instead.
1979
1980 =cut
1981 */
1982
1983 int
1984 Perl_sv_backoff(pTHX_ register SV *sv)
1985 {
1986     assert(SvOOK(sv));
1987     if (SvIVX(sv)) {
1988         char *s = SvPVX(sv);
1989         SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1990         SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1991         SvIV_set(sv, 0);
1992         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1993     }
1994     SvFLAGS(sv) &= ~SVf_OOK;
1995     return 0;
1996 }
1997
1998 /*
1999 =for apidoc sv_grow
2000
2001 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
2002 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
2003 Use the C<SvGROW> wrapper instead.
2004
2005 =cut
2006 */
2007
2008 char *
2009 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2010 {
2011     register char *s;
2012
2013 #ifdef HAS_64K_LIMIT
2014     if (newlen >= 0x10000) {
2015         PerlIO_printf(Perl_debug_log,
2016                       "Allocation too large: %"UVxf"\n", (UV)newlen);
2017         my_exit(1);
2018     }
2019 #endif /* HAS_64K_LIMIT */
2020     if (SvROK(sv))
2021         sv_unref(sv);
2022     if (SvTYPE(sv) < SVt_PV) {
2023         sv_upgrade(sv, SVt_PV);
2024         s = SvPVX(sv);
2025     }
2026     else if (SvOOK(sv)) {       /* pv is offset? */
2027         sv_backoff(sv);
2028         s = SvPVX(sv);
2029         if (newlen > SvLEN(sv))
2030             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2031 #ifdef HAS_64K_LIMIT
2032         if (newlen >= 0x10000)
2033             newlen = 0xFFFF;
2034 #endif
2035     }
2036     else
2037         s = SvPVX(sv);
2038
2039     if (newlen > SvLEN(sv)) {           /* need more room? */
2040         if (SvLEN(sv) && s) {
2041 #ifdef MYMALLOC
2042             const STRLEN l = malloced_size((void*)SvPVX(sv));
2043             if (newlen <= l) {
2044                 SvLEN_set(sv, l);
2045                 return s;
2046             } else
2047 #endif
2048             Renew(s,newlen,char);
2049         }
2050         else {
2051             New(703, s, newlen, char);
2052             if (SvPVX(sv) && SvCUR(sv)) {
2053                 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2054             }
2055         }
2056         SvPV_set(sv, s);
2057         SvLEN_set(sv, newlen);
2058     }
2059     return s;
2060 }
2061
2062 /*
2063 =for apidoc sv_setiv
2064
2065 Copies an integer into the given SV, upgrading first if necessary.
2066 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
2067
2068 =cut
2069 */
2070
2071 void
2072 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2073 {
2074     SV_CHECK_THINKFIRST_COW_DROP(sv);
2075     switch (SvTYPE(sv)) {
2076     case SVt_NULL:
2077         sv_upgrade(sv, SVt_IV);
2078         break;
2079     case SVt_NV:
2080         sv_upgrade(sv, SVt_PVNV);
2081         break;
2082     case SVt_RV:
2083     case SVt_PV:
2084         sv_upgrade(sv, SVt_PVIV);
2085         break;
2086
2087     case SVt_PVGV:
2088     case SVt_PVAV:
2089     case SVt_PVHV:
2090     case SVt_PVCV:
2091     case SVt_PVFM:
2092     case SVt_PVIO:
2093         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2094                    OP_DESC(PL_op));
2095     }
2096     (void)SvIOK_only(sv);                       /* validate number */
2097     SvIV_set(sv, i);
2098     SvTAINT(sv);
2099 }
2100
2101 /*
2102 =for apidoc sv_setiv_mg
2103
2104 Like C<sv_setiv>, but also handles 'set' magic.
2105
2106 =cut
2107 */
2108
2109 void
2110 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2111 {
2112     sv_setiv(sv,i);
2113     SvSETMAGIC(sv);
2114 }
2115
2116 /*
2117 =for apidoc sv_setuv
2118
2119 Copies an unsigned integer into the given SV, upgrading first if necessary.
2120 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
2121
2122 =cut
2123 */
2124
2125 void
2126 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2127 {
2128     /* With these two if statements:
2129        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
2130
2131        without
2132        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
2133
2134        If you wish to remove them, please benchmark to see what the effect is
2135     */
2136     if (u <= (UV)IV_MAX) {
2137        sv_setiv(sv, (IV)u);
2138        return;
2139     }
2140     sv_setiv(sv, 0);
2141     SvIsUV_on(sv);
2142     SvUV_set(sv, u);
2143 }
2144
2145 /*
2146 =for apidoc sv_setuv_mg
2147
2148 Like C<sv_setuv>, but also handles 'set' magic.
2149
2150 =cut
2151 */
2152
2153 void
2154 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2155 {
2156     /* With these two if statements:
2157        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
2158
2159        without
2160        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
2161
2162        If you wish to remove them, please benchmark to see what the effect is
2163     */
2164     if (u <= (UV)IV_MAX) {
2165        sv_setiv(sv, (IV)u);
2166     } else {
2167        sv_setiv(sv, 0);
2168        SvIsUV_on(sv);
2169        sv_setuv(sv,u);
2170     }
2171     SvSETMAGIC(sv);
2172 }
2173
2174 /*
2175 =for apidoc sv_setnv
2176
2177 Copies a double into the given SV, upgrading first if necessary.
2178 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
2179
2180 =cut
2181 */
2182
2183 void
2184 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2185 {
2186     SV_CHECK_THINKFIRST_COW_DROP(sv);
2187     switch (SvTYPE(sv)) {
2188     case SVt_NULL:
2189     case SVt_IV:
2190         sv_upgrade(sv, SVt_NV);
2191         break;
2192     case SVt_RV:
2193     case SVt_PV:
2194     case SVt_PVIV:
2195         sv_upgrade(sv, SVt_PVNV);
2196         break;
2197
2198     case SVt_PVGV:
2199     case SVt_PVAV:
2200     case SVt_PVHV:
2201     case SVt_PVCV:
2202     case SVt_PVFM:
2203     case SVt_PVIO:
2204         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2205                    OP_NAME(PL_op));
2206     }
2207     SvNV_set(sv, num);
2208     (void)SvNOK_only(sv);                       /* validate number */
2209     SvTAINT(sv);
2210 }
2211
2212 /*
2213 =for apidoc sv_setnv_mg
2214
2215 Like C<sv_setnv>, but also handles 'set' magic.
2216
2217 =cut
2218 */
2219
2220 void
2221 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2222 {
2223     sv_setnv(sv,num);
2224     SvSETMAGIC(sv);
2225 }
2226
2227 /* Print an "isn't numeric" warning, using a cleaned-up,
2228  * printable version of the offending string
2229  */
2230
2231 STATIC void
2232 S_not_a_number(pTHX_ SV *sv)
2233 {
2234      SV *dsv;
2235      char tmpbuf[64];
2236      char *pv;
2237
2238      if (DO_UTF8(sv)) {
2239           dsv = sv_2mortal(newSVpv("", 0));
2240           pv = sv_uni_display(dsv, sv, 10, 0);
2241      } else {
2242           char *d = tmpbuf;
2243           char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2244           /* each *s can expand to 4 chars + "...\0",
2245              i.e. need room for 8 chars */
2246
2247           char *s, *end;
2248           for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2249                int ch = *s & 0xFF;
2250                if (ch & 128 && !isPRINT_LC(ch)) {
2251                     *d++ = 'M';
2252                     *d++ = '-';
2253                     ch &= 127;
2254                }
2255                if (ch == '\n') {
2256                     *d++ = '\\';
2257                     *d++ = 'n';
2258                }
2259                else if (ch == '\r') {
2260                     *d++ = '\\';
2261                     *d++ = 'r';
2262                }
2263                else if (ch == '\f') {
2264                     *d++ = '\\';
2265                     *d++ = 'f';
2266                }
2267                else if (ch == '\\') {
2268                     *d++ = '\\';
2269                     *d++ = '\\';
2270                }
2271                else if (ch == '\0') {
2272                     *d++ = '\\';
2273                     *d++ = '0';
2274                }
2275                else if (isPRINT_LC(ch))
2276                     *d++ = ch;
2277                else {
2278                     *d++ = '^';
2279                     *d++ = toCTRL(ch);
2280                }
2281           }
2282           if (s < end) {
2283                *d++ = '.';
2284                *d++ = '.';
2285                *d++ = '.';
2286           }
2287           *d = '\0';
2288           pv = tmpbuf;
2289     }
2290
2291     if (PL_op)
2292         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2293                     "Argument \"%s\" isn't numeric in %s", pv,
2294                     OP_DESC(PL_op));
2295     else
2296         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2297                     "Argument \"%s\" isn't numeric", pv);
2298 }
2299
2300 /*
2301 =for apidoc looks_like_number
2302
2303 Test if the content of an SV looks like a number (or is a number).
2304 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2305 non-numeric warning), even if your atof() doesn't grok them.
2306
2307 =cut
2308 */
2309
2310 I32
2311 Perl_looks_like_number(pTHX_ SV *sv)
2312 {
2313     register const char *sbegin;
2314     STRLEN len;
2315
2316     if (SvPOK(sv)) {
2317         sbegin = SvPVX(sv);
2318         len = SvCUR(sv);
2319     }
2320     else if (SvPOKp(sv))
2321         sbegin = SvPV(sv, len);
2322     else
2323         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2324     return grok_number(sbegin, len, NULL);
2325 }
2326
2327 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2328    until proven guilty, assume that things are not that bad... */
2329
2330 /*
2331    NV_PRESERVES_UV:
2332
2333    As 64 bit platforms often have an NV that doesn't preserve all bits of
2334    an IV (an assumption perl has been based on to date) it becomes necessary
2335    to remove the assumption that the NV always carries enough precision to
2336    recreate the IV whenever needed, and that the NV is the canonical form.
2337    Instead, IV/UV and NV need to be given equal rights. So as to not lose
2338    precision as a side effect of conversion (which would lead to insanity
2339    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2340    1) to distinguish between IV/UV/NV slots that have cached a valid
2341       conversion where precision was lost and IV/UV/NV slots that have a
2342       valid conversion which has lost no precision
2343    2) to ensure that if a numeric conversion to one form is requested that
2344       would lose precision, the precise conversion (or differently
2345       imprecise conversion) is also performed and cached, to prevent
2346       requests for different numeric formats on the same SV causing
2347       lossy conversion chains. (lossless conversion chains are perfectly
2348       acceptable (still))
2349
2350
2351    flags are used:
2352    SvIOKp is true if the IV slot contains a valid value
2353    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
2354    SvNOKp is true if the NV slot contains a valid value
2355    SvNOK  is true only if the NV value is accurate
2356
2357    so
2358    while converting from PV to NV, check to see if converting that NV to an
2359    IV(or UV) would lose accuracy over a direct conversion from PV to
2360    IV(or UV). If it would, cache both conversions, return NV, but mark
2361    SV as IOK NOKp (ie not NOK).
2362
2363    While converting from PV to IV, check to see if converting that IV to an
2364    NV would lose accuracy over a direct conversion from PV to NV. If it
2365    would, cache both conversions, flag similarly.
2366
2367    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2368    correctly because if IV & NV were set NV *always* overruled.
2369    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2370    changes - now IV and NV together means that the two are interchangeable:
2371    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2372
2373    The benefit of this is that operations such as pp_add know that if
2374    SvIOK is true for both left and right operands, then integer addition
2375    can be used instead of floating point (for cases where the result won't
2376    overflow). Before, floating point was always used, which could lead to
2377    loss of precision compared with integer addition.
2378
2379    * making IV and NV equal status should make maths accurate on 64 bit
2380      platforms
2381    * may speed up maths somewhat if pp_add and friends start to use
2382      integers when possible instead of fp. (Hopefully the overhead in
2383      looking for SvIOK and checking for overflow will not outweigh the
2384      fp to integer speedup)
2385    * will slow down integer operations (callers of SvIV) on "inaccurate"
2386      values, as the change from SvIOK to SvIOKp will cause a call into
2387      sv_2iv each time rather than a macro access direct to the IV slot
2388    * should speed up number->string conversion on integers as IV is
2389      favoured when IV and NV are equally accurate
2390
2391    ####################################################################
2392    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2393    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2394    On the other hand, SvUOK is true iff UV.
2395    ####################################################################
2396
2397    Your mileage will vary depending your CPU's relative fp to integer
2398    performance ratio.
2399 */
2400
2401 #ifndef NV_PRESERVES_UV
2402 #  define IS_NUMBER_UNDERFLOW_IV 1
2403 #  define IS_NUMBER_UNDERFLOW_UV 2
2404 #  define IS_NUMBER_IV_AND_UV    2
2405 #  define IS_NUMBER_OVERFLOW_IV  4
2406 #  define IS_NUMBER_OVERFLOW_UV  5
2407
2408 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2409
2410 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2411 STATIC int
2412 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2413 {
2414     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2415     if (SvNVX(sv) < (NV)IV_MIN) {
2416         (void)SvIOKp_on(sv);
2417         (void)SvNOK_on(sv);
2418         SvIV_set(sv, IV_MIN);
2419         return IS_NUMBER_UNDERFLOW_IV;
2420     }
2421     if (SvNVX(sv) > (NV)UV_MAX) {
2422         (void)SvIOKp_on(sv);
2423         (void)SvNOK_on(sv);
2424         SvIsUV_on(sv);
2425         SvUV_set(sv, UV_MAX);
2426         return IS_NUMBER_OVERFLOW_UV;
2427     }
2428     (void)SvIOKp_on(sv);
2429     (void)SvNOK_on(sv);
2430     /* Can't use strtol etc to convert this string.  (See truth table in
2431        sv_2iv  */
2432     if (SvNVX(sv) <= (UV)IV_MAX) {
2433         SvIV_set(sv, I_V(SvNVX(sv)));
2434         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2435             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2436         } else {
2437             /* Integer is imprecise. NOK, IOKp */
2438         }
2439         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2440     }
2441     SvIsUV_on(sv);
2442     SvUV_set(sv, U_V(SvNVX(sv)));
2443     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2444         if (SvUVX(sv) == UV_MAX) {
2445             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2446                possibly be preserved by NV. Hence, it must be overflow.
2447                NOK, IOKp */
2448             return IS_NUMBER_OVERFLOW_UV;
2449         }
2450         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2451     } else {
2452         /* Integer is imprecise. NOK, IOKp */
2453     }
2454     return IS_NUMBER_OVERFLOW_IV;
2455 }
2456 #endif /* !NV_PRESERVES_UV*/
2457
2458 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2459  * this function provided for binary compatibility only
2460  */
2461
2462 IV
2463 Perl_sv_2iv(pTHX_ register SV *sv)
2464 {
2465     return sv_2iv_flags(sv, SV_GMAGIC);
2466 }
2467
2468 /*
2469 =for apidoc sv_2iv_flags
2470
2471 Return the integer value of an SV, doing any necessary string
2472 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2473 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2474
2475 =cut
2476 */
2477
2478 IV
2479 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2480 {
2481     if (!sv)
2482         return 0;
2483     if (SvGMAGICAL(sv)) {
2484         if (flags & SV_GMAGIC)
2485             mg_get(sv);
2486         if (SvIOKp(sv))
2487             return SvIVX(sv);
2488         if (SvNOKp(sv)) {
2489             return I_V(SvNVX(sv));
2490         }
2491         if (SvPOKp(sv) && SvLEN(sv))
2492             return asIV(sv);
2493         if (!SvROK(sv)) {
2494             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2495                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2496                     report_uninit(sv);
2497             }
2498             return 0;
2499         }
2500     }
2501     if (SvTHINKFIRST(sv)) {
2502         if (SvROK(sv)) {
2503           SV* tmpstr;
2504           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2505                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2506               return SvIV(tmpstr);
2507           return PTR2IV(SvRV(sv));
2508         }
2509         if (SvIsCOW(sv)) {
2510             sv_force_normal_flags(sv, 0);
2511         }
2512         if (SvREADONLY(sv) && !SvOK(sv)) {
2513             if (ckWARN(WARN_UNINITIALIZED))
2514                 report_uninit(sv);
2515             return 0;
2516         }
2517     }
2518     if (SvIOKp(sv)) {
2519         if (SvIsUV(sv)) {
2520             return (IV)(SvUVX(sv));
2521         }
2522         else {
2523             return SvIVX(sv);
2524         }
2525     }
2526     if (SvNOKp(sv)) {
2527         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2528          * without also getting a cached IV/UV from it at the same time
2529          * (ie PV->NV conversion should detect loss of accuracy and cache
2530          * IV or UV at same time to avoid this.  NWC */
2531
2532         if (SvTYPE(sv) == SVt_NV)
2533             sv_upgrade(sv, SVt_PVNV);
2534
2535         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2536         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2537            certainly cast into the IV range at IV_MAX, whereas the correct
2538            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2539            cases go to UV */
2540         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2541             SvIV_set(sv, I_V(SvNVX(sv)));
2542             if (SvNVX(sv) == (NV) SvIVX(sv)
2543 #ifndef NV_PRESERVES_UV
2544                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2545                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2546                 /* Don't flag it as "accurately an integer" if the number
2547                    came from a (by definition imprecise) NV operation, and
2548                    we're outside the range of NV integer precision */
2549 #endif
2550                 ) {
2551                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2552                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2553                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2554                                       PTR2UV(sv),
2555                                       SvNVX(sv),
2556                                       SvIVX(sv)));
2557
2558             } else {
2559                 /* IV not precise.  No need to convert from PV, as NV
2560                    conversion would already have cached IV if it detected
2561                    that PV->IV would be better than PV->NV->IV
2562                    flags already correct - don't set public IOK.  */
2563                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2564                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2565                                       PTR2UV(sv),
2566                                       SvNVX(sv),
2567                                       SvIVX(sv)));
2568             }
2569             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2570                but the cast (NV)IV_MIN rounds to a the value less (more
2571                negative) than IV_MIN which happens to be equal to SvNVX ??
2572                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2573                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2574                (NV)UVX == NVX are both true, but the values differ. :-(
2575                Hopefully for 2s complement IV_MIN is something like
2576                0x8000000000000000 which will be exact. NWC */
2577         }
2578         else {
2579             SvUV_set(sv, U_V(SvNVX(sv)));
2580             if (
2581                 (SvNVX(sv) == (NV) SvUVX(sv))
2582 #ifndef  NV_PRESERVES_UV
2583                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2584                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2585                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2586                 /* Don't flag it as "accurately an integer" if the number
2587                    came from a (by definition imprecise) NV operation, and
2588                    we're outside the range of NV integer precision */
2589 #endif
2590                 )
2591                 SvIOK_on(sv);
2592             SvIsUV_on(sv);
2593           ret_iv_max:
2594             DEBUG_c(PerlIO_printf(Perl_debug_log,
2595                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2596                                   PTR2UV(sv),
2597                                   SvUVX(sv),
2598                                   SvUVX(sv)));
2599             return (IV)SvUVX(sv);
2600         }
2601     }
2602     else if (SvPOKp(sv) && SvLEN(sv)) {
2603         UV value;
2604         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2605         /* We want to avoid a possible problem when we cache an IV which
2606            may be later translated to an NV, and the resulting NV is not
2607            the same as the direct translation of the initial string
2608            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2609            be careful to ensure that the value with the .456 is around if the
2610            NV value is requested in the future).
2611
2612            This means that if we cache such an IV, we need to cache the
2613            NV as well.  Moreover, we trade speed for space, and do not
2614            cache the NV if we are sure it's not needed.
2615          */
2616
2617         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2618         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2619              == IS_NUMBER_IN_UV) {
2620             /* It's definitely an integer, only upgrade to PVIV */
2621             if (SvTYPE(sv) < SVt_PVIV)
2622                 sv_upgrade(sv, SVt_PVIV);
2623             (void)SvIOK_on(sv);
2624         } else if (SvTYPE(sv) < SVt_PVNV)
2625             sv_upgrade(sv, SVt_PVNV);
2626
2627         /* If NV preserves UV then we only use the UV value if we know that
2628            we aren't going to call atof() below. If NVs don't preserve UVs
2629            then the value returned may have more precision than atof() will
2630            return, even though value isn't perfectly accurate.  */
2631         if ((numtype & (IS_NUMBER_IN_UV
2632 #ifdef NV_PRESERVES_UV
2633                         | IS_NUMBER_NOT_INT
2634 #endif
2635             )) == IS_NUMBER_IN_UV) {
2636             /* This won't turn off the public IOK flag if it was set above  */
2637             (void)SvIOKp_on(sv);
2638
2639             if (!(numtype & IS_NUMBER_NEG)) {
2640                 /* positive */;
2641                 if (value <= (UV)IV_MAX) {
2642                     SvIV_set(sv, (IV)value);
2643                 } else {
2644                     SvUV_set(sv, value);
2645                     SvIsUV_on(sv);
2646                 }
2647             } else {
2648                 /* 2s complement assumption  */
2649                 if (value <= (UV)IV_MIN) {
2650                     SvIV_set(sv, -(IV)value);
2651                 } else {
2652                     /* Too negative for an IV.  This is a double upgrade, but
2653                        I'm assuming it will be rare.  */
2654                     if (SvTYPE(sv) < SVt_PVNV)
2655                         sv_upgrade(sv, SVt_PVNV);
2656                     SvNOK_on(sv);
2657                     SvIOK_off(sv);
2658                     SvIOKp_on(sv);
2659                     SvNV_set(sv, -(NV)value);
2660                     SvIV_set(sv, IV_MIN);
2661                 }
2662             }
2663         }
2664         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2665            will be in the previous block to set the IV slot, and the next
2666            block to set the NV slot.  So no else here.  */
2667
2668         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2669             != IS_NUMBER_IN_UV) {
2670             /* It wasn't an (integer that doesn't overflow the UV). */
2671             SvNV_set(sv, Atof(SvPVX(sv)));
2672
2673             if (! numtype && ckWARN(WARN_NUMERIC))
2674                 not_a_number(sv);
2675
2676 #if defined(USE_LONG_DOUBLE)
2677             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2678                                   PTR2UV(sv), SvNVX(sv)));
2679 #else
2680             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2681                                   PTR2UV(sv), SvNVX(sv)));
2682 #endif
2683
2684
2685 #ifdef NV_PRESERVES_UV
2686             (void)SvIOKp_on(sv);
2687             (void)SvNOK_on(sv);
2688             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2689                 SvIV_set(sv, I_V(SvNVX(sv)));
2690                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2691                     SvIOK_on(sv);
2692                 } else {
2693                     /* Integer is imprecise. NOK, IOKp */
2694                 }
2695                 /* UV will not work better than IV */
2696             } else {
2697                 if (SvNVX(sv) > (NV)UV_MAX) {
2698                     SvIsUV_on(sv);
2699                     /* Integer is inaccurate. NOK, IOKp, is UV */
2700                     SvUV_set(sv, UV_MAX);
2701                     SvIsUV_on(sv);
2702                 } else {
2703                     SvUV_set(sv, U_V(SvNVX(sv)));
2704                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2705                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2706                         SvIOK_on(sv);
2707                         SvIsUV_on(sv);
2708                     } else {
2709                         /* Integer is imprecise. NOK, IOKp, is UV */
2710                         SvIsUV_on(sv);
2711                     }
2712                 }
2713                 goto ret_iv_max;
2714             }
2715 #else /* NV_PRESERVES_UV */
2716             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2717                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2718                 /* The IV slot will have been set from value returned by
2719                    grok_number above.  The NV slot has just been set using
2720                    Atof.  */
2721                 SvNOK_on(sv);
2722                 assert (SvIOKp(sv));
2723             } else {
2724                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2725                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2726                     /* Small enough to preserve all bits. */
2727                     (void)SvIOKp_on(sv);
2728                     SvNOK_on(sv);
2729                     SvIV_set(sv, I_V(SvNVX(sv)));
2730                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2731                         SvIOK_on(sv);
2732                     /* Assumption: first non-preserved integer is < IV_MAX,
2733                        this NV is in the preserved range, therefore: */
2734                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2735                           < (UV)IV_MAX)) {
2736                         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);
2737                     }
2738                 } else {
2739                     /* IN_UV NOT_INT
2740                          0      0       already failed to read UV.
2741                          0      1       already failed to read UV.
2742                          1      0       you won't get here in this case. IV/UV
2743                                         slot set, public IOK, Atof() unneeded.
2744                          1      1       already read UV.
2745                        so there's no point in sv_2iuv_non_preserve() attempting
2746                        to use atol, strtol, strtoul etc.  */
2747                     if (sv_2iuv_non_preserve (sv, numtype)
2748                         >= IS_NUMBER_OVERFLOW_IV)
2749                     goto ret_iv_max;
2750                 }
2751             }
2752 #endif /* NV_PRESERVES_UV */
2753         }
2754     } else  {
2755         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2756             report_uninit(sv);
2757         if (SvTYPE(sv) < SVt_IV)
2758             /* Typically the caller expects that sv_any is not NULL now.  */
2759             sv_upgrade(sv, SVt_IV);
2760         return 0;
2761     }
2762     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2763         PTR2UV(sv),SvIVX(sv)));
2764     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2765 }
2766
2767 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2768  * this function provided for binary compatibility only
2769  */
2770
2771 UV
2772 Perl_sv_2uv(pTHX_ register SV *sv)
2773 {
2774     return sv_2uv_flags(sv, SV_GMAGIC);
2775 }
2776
2777 /*
2778 =for apidoc sv_2uv_flags
2779
2780 Return the unsigned integer value of an SV, doing any necessary string
2781 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2782 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2783
2784 =cut
2785 */
2786
2787 UV
2788 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2789 {
2790     if (!sv)
2791         return 0;
2792     if (SvGMAGICAL(sv)) {
2793         if (flags & SV_GMAGIC)
2794             mg_get(sv);
2795         if (SvIOKp(sv))
2796             return SvUVX(sv);
2797         if (SvNOKp(sv))
2798             return U_V(SvNVX(sv));
2799         if (SvPOKp(sv) && SvLEN(sv))
2800             return asUV(sv);
2801         if (!SvROK(sv)) {
2802             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2803                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2804                     report_uninit(sv);
2805             }
2806             return 0;
2807         }
2808     }
2809     if (SvTHINKFIRST(sv)) {
2810         if (SvROK(sv)) {
2811           SV* tmpstr;
2812           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2813                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2814               return SvUV(tmpstr);
2815           return PTR2UV(SvRV(sv));
2816         }
2817         if (SvIsCOW(sv)) {
2818             sv_force_normal_flags(sv, 0);
2819         }
2820         if (SvREADONLY(sv) && !SvOK(sv)) {
2821             if (ckWARN(WARN_UNINITIALIZED))
2822                 report_uninit(sv);
2823             return 0;
2824         }
2825     }
2826     if (SvIOKp(sv)) {
2827         if (SvIsUV(sv)) {
2828             return SvUVX(sv);
2829         }
2830         else {
2831             return (UV)SvIVX(sv);
2832         }
2833     }
2834     if (SvNOKp(sv)) {
2835         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2836          * without also getting a cached IV/UV from it at the same time
2837          * (ie PV->NV conversion should detect loss of accuracy and cache
2838          * IV or UV at same time to avoid this. */
2839         /* IV-over-UV optimisation - choose to cache IV if possible */
2840
2841         if (SvTYPE(sv) == SVt_NV)
2842             sv_upgrade(sv, SVt_PVNV);
2843
2844         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2845         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2846             SvIV_set(sv, I_V(SvNVX(sv)));
2847             if (SvNVX(sv) == (NV) SvIVX(sv)
2848 #ifndef NV_PRESERVES_UV
2849                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2850                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2851                 /* Don't flag it as "accurately an integer" if the number
2852                    came from a (by definition imprecise) NV operation, and
2853                    we're outside the range of NV integer precision */
2854 #endif
2855                 ) {
2856                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2857                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2858                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2859                                       PTR2UV(sv),
2860                                       SvNVX(sv),
2861                                       SvIVX(sv)));
2862
2863             } else {
2864                 /* IV not precise.  No need to convert from PV, as NV
2865                    conversion would already have cached IV if it detected
2866                    that PV->IV would be better than PV->NV->IV
2867                    flags already correct - don't set public IOK.  */
2868                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2869                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2870                                       PTR2UV(sv),
2871                                       SvNVX(sv),
2872                                       SvIVX(sv)));
2873             }
2874             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2875                but the cast (NV)IV_MIN rounds to a the value less (more
2876                negative) than IV_MIN which happens to be equal to SvNVX ??
2877                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2878                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2879                (NV)UVX == NVX are both true, but the values differ. :-(
2880                Hopefully for 2s complement IV_MIN is something like
2881                0x8000000000000000 which will be exact. NWC */
2882         }
2883         else {
2884             SvUV_set(sv, U_V(SvNVX(sv)));
2885             if (
2886                 (SvNVX(sv) == (NV) SvUVX(sv))
2887 #ifndef  NV_PRESERVES_UV
2888                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2889                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2890                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2891                 /* Don't flag it as "accurately an integer" if the number
2892                    came from a (by definition imprecise) NV operation, and
2893                    we're outside the range of NV integer precision */
2894 #endif
2895                 )
2896                 SvIOK_on(sv);
2897             SvIsUV_on(sv);
2898             DEBUG_c(PerlIO_printf(Perl_debug_log,
2899                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2900                                   PTR2UV(sv),
2901                                   SvUVX(sv),
2902                                   SvUVX(sv)));
2903         }
2904     }
2905     else if (SvPOKp(sv) && SvLEN(sv)) {
2906         UV value;
2907         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2908
2909         /* We want to avoid a possible problem when we cache a UV which
2910            may be later translated to an NV, and the resulting NV is not
2911            the translation of the initial data.
2912
2913            This means that if we cache such a UV, we need to cache the
2914            NV as well.  Moreover, we trade speed for space, and do not
2915            cache the NV if not needed.
2916          */
2917
2918         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2919         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2920              == IS_NUMBER_IN_UV) {
2921             /* It's definitely an integer, only upgrade to PVIV */
2922             if (SvTYPE(sv) < SVt_PVIV)
2923                 sv_upgrade(sv, SVt_PVIV);
2924             (void)SvIOK_on(sv);
2925         } else if (SvTYPE(sv) < SVt_PVNV)
2926             sv_upgrade(sv, SVt_PVNV);
2927
2928         /* If NV preserves UV then we only use the UV value if we know that
2929            we aren't going to call atof() below. If NVs don't preserve UVs
2930            then the value returned may have more precision than atof() will
2931            return, even though it isn't accurate.  */
2932         if ((numtype & (IS_NUMBER_IN_UV
2933 #ifdef NV_PRESERVES_UV
2934                         | IS_NUMBER_NOT_INT
2935 #endif
2936             )) == IS_NUMBER_IN_UV) {
2937             /* This won't turn off the public IOK flag if it was set above  */
2938             (void)SvIOKp_on(sv);
2939
2940             if (!(numtype & IS_NUMBER_NEG)) {
2941                 /* positive */;
2942                 if (value <= (UV)IV_MAX) {
2943                     SvIV_set(sv, (IV)value);
2944                 } else {
2945                     /* it didn't overflow, and it was positive. */
2946                     SvUV_set(sv, value);
2947                     SvIsUV_on(sv);
2948                 }
2949             } else {
2950                 /* 2s complement assumption  */
2951                 if (value <= (UV)IV_MIN) {
2952                     SvIV_set(sv, -(IV)value);
2953                 } else {
2954                     /* Too negative for an IV.  This is a double upgrade, but
2955                        I'm assuming it will be rare.  */
2956                     if (SvTYPE(sv) < SVt_PVNV)
2957                         sv_upgrade(sv, SVt_PVNV);
2958                     SvNOK_on(sv);
2959                     SvIOK_off(sv);
2960                     SvIOKp_on(sv);
2961                     SvNV_set(sv, -(NV)value);
2962                     SvIV_set(sv, IV_MIN);
2963                 }
2964             }
2965         }
2966
2967         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2968             != IS_NUMBER_IN_UV) {
2969             /* It wasn't an integer, or it overflowed the UV. */
2970             SvNV_set(sv, Atof(SvPVX(sv)));
2971
2972             if (! numtype && ckWARN(WARN_NUMERIC))
2973                     not_a_number(sv);
2974
2975 #if defined(USE_LONG_DOUBLE)
2976             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2977                                   PTR2UV(sv), SvNVX(sv)));
2978 #else
2979             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2980                                   PTR2UV(sv), SvNVX(sv)));
2981 #endif
2982
2983 #ifdef NV_PRESERVES_UV
2984             (void)SvIOKp_on(sv);
2985             (void)SvNOK_on(sv);
2986             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2987                 SvIV_set(sv, I_V(SvNVX(sv)));
2988                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2989                     SvIOK_on(sv);
2990                 } else {
2991                     /* Integer is imprecise. NOK, IOKp */
2992                 }
2993                 /* UV will not work better than IV */
2994             } else {
2995                 if (SvNVX(sv) > (NV)UV_MAX) {
2996                     SvIsUV_on(sv);
2997                     /* Integer is inaccurate. NOK, IOKp, is UV */
2998                     SvUV_set(sv, UV_MAX);
2999                     SvIsUV_on(sv);
3000                 } else {
3001                     SvUV_set(sv, U_V(SvNVX(sv)));
3002                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3003                        NV preservse UV so can do correct comparison.  */
3004                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3005                         SvIOK_on(sv);
3006                         SvIsUV_on(sv);
3007                     } else {
3008                         /* Integer is imprecise. NOK, IOKp, is UV */
3009                         SvIsUV_on(sv);
3010                     }
3011                 }
3012             }
3013 #else /* NV_PRESERVES_UV */
3014             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3015                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3016                 /* The UV slot will have been set from value returned by
3017                    grok_number above.  The NV slot has just been set using
3018                    Atof.  */
3019                 SvNOK_on(sv);
3020                 assert (SvIOKp(sv));
3021             } else {
3022                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3023                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3024                     /* Small enough to preserve all bits. */
3025                     (void)SvIOKp_on(sv);
3026                     SvNOK_on(sv);
3027                     SvIV_set(sv, I_V(SvNVX(sv)));
3028                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
3029                         SvIOK_on(sv);
3030                     /* Assumption: first non-preserved integer is < IV_MAX,
3031                        this NV is in the preserved range, therefore: */
3032                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3033                           < (UV)IV_MAX)) {
3034                         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);
3035                     }
3036                 } else
3037                     sv_2iuv_non_preserve (sv, numtype);
3038             }
3039 #endif /* NV_PRESERVES_UV */
3040         }
3041     }
3042     else  {
3043         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3044             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3045                 report_uninit(sv);
3046         }
3047         if (SvTYPE(sv) < SVt_IV)
3048             /* Typically the caller expects that sv_any is not NULL now.  */
3049             sv_upgrade(sv, SVt_IV);
3050         return 0;
3051     }
3052
3053     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3054                           PTR2UV(sv),SvUVX(sv)));
3055     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3056 }
3057
3058 /*
3059 =for apidoc sv_2nv
3060
3061 Return the num value of an SV, doing any necessary string or integer
3062 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3063 macros.
3064
3065 =cut
3066 */
3067
3068 NV
3069 Perl_sv_2nv(pTHX_ register SV *sv)
3070 {
3071     if (!sv)
3072         return 0.0;
3073     if (SvGMAGICAL(sv)) {
3074         mg_get(sv);
3075         if (SvNOKp(sv))
3076             return SvNVX(sv);
3077         if (SvPOKp(sv) && SvLEN(sv)) {
3078             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3079                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
3080                 not_a_number(sv);
3081             return Atof(SvPVX(sv));
3082         }
3083         if (SvIOKp(sv)) {
3084             if (SvIsUV(sv))
3085                 return (NV)SvUVX(sv);
3086             else
3087                 return (NV)SvIVX(sv);
3088         }
3089         if (!SvROK(sv)) {
3090             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3091                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3092                     report_uninit(sv);
3093             }
3094             return 0;
3095         }
3096     }
3097     if (SvTHINKFIRST(sv)) {
3098         if (SvROK(sv)) {
3099           SV* tmpstr;
3100           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3101                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3102               return SvNV(tmpstr);
3103           return PTR2NV(SvRV(sv));
3104         }
3105         if (SvIsCOW(sv)) {
3106             sv_force_normal_flags(sv, 0);
3107         }
3108         if (SvREADONLY(sv) && !SvOK(sv)) {
3109             if (ckWARN(WARN_UNINITIALIZED))
3110                 report_uninit(sv);
3111             return 0.0;
3112         }
3113     }
3114     if (SvTYPE(sv) < SVt_NV) {
3115         if (SvTYPE(sv) == SVt_IV)
3116             sv_upgrade(sv, SVt_PVNV);
3117         else
3118             sv_upgrade(sv, SVt_NV);
3119 #ifdef USE_LONG_DOUBLE
3120         DEBUG_c({
3121             STORE_NUMERIC_LOCAL_SET_STANDARD();
3122             PerlIO_printf(Perl_debug_log,
3123                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3124                           PTR2UV(sv), SvNVX(sv));
3125             RESTORE_NUMERIC_LOCAL();
3126         });
3127 #else
3128         DEBUG_c({
3129             STORE_NUMERIC_LOCAL_SET_STANDARD();
3130             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3131                           PTR2UV(sv), SvNVX(sv));
3132             RESTORE_NUMERIC_LOCAL();
3133         });
3134 #endif
3135     }
3136     else if (SvTYPE(sv) < SVt_PVNV)
3137         sv_upgrade(sv, SVt_PVNV);
3138     if (SvNOKp(sv)) {
3139         return SvNVX(sv);
3140     }
3141     if (SvIOKp(sv)) {
3142         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3143 #ifdef NV_PRESERVES_UV
3144         SvNOK_on(sv);
3145 #else
3146         /* Only set the public NV OK flag if this NV preserves the IV  */
3147         /* Check it's not 0xFFFFFFFFFFFFFFFF */
3148         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3149                        : (SvIVX(sv) == I_V(SvNVX(sv))))
3150             SvNOK_on(sv);
3151         else
3152             SvNOKp_on(sv);
3153 #endif
3154     }
3155     else if (SvPOKp(sv) && SvLEN(sv)) {
3156         UV value;
3157         const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3158         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3159             not_a_number(sv);
3160 #ifdef NV_PRESERVES_UV
3161         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3162             == IS_NUMBER_IN_UV) {
3163             /* It's definitely an integer */
3164             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3165         } else
3166             SvNV_set(sv, Atof(SvPVX(sv)));
3167         SvNOK_on(sv);
3168 #else
3169         SvNV_set(sv, Atof(SvPVX(sv)));
3170         /* Only set the public NV OK flag if this NV preserves the value in
3171            the PV at least as well as an IV/UV would.
3172            Not sure how to do this 100% reliably. */
3173         /* if that shift count is out of range then Configure's test is
3174            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3175            UV_BITS */
3176         if (((UV)1 << NV_PRESERVES_UV_BITS) >
3177             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3178             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3179         } else if (!(numtype & IS_NUMBER_IN_UV)) {
3180             /* Can't use strtol etc to convert this string, so don't try.
3181                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
3182             SvNOK_on(sv);
3183         } else {
3184             /* value has been set.  It may not be precise.  */
3185             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3186                 /* 2s complement assumption for (UV)IV_MIN  */
3187                 SvNOK_on(sv); /* Integer is too negative.  */
3188             } else {
3189                 SvNOKp_on(sv);
3190                 SvIOKp_on(sv);
3191
3192                 if (numtype & IS_NUMBER_NEG) {
3193                     SvIV_set(sv, -(IV)value);
3194                 } else if (value <= (UV)IV_MAX) {
3195                     SvIV_set(sv, (IV)value);
3196                 } else {
3197                     SvUV_set(sv, value);
3198                     SvIsUV_on(sv);
3199                 }
3200
3201                 if (numtype & IS_NUMBER_NOT_INT) {
3202                     /* I believe that even if the original PV had decimals,
3203                        they are lost beyond the limit of the FP precision.
3204                        However, neither is canonical, so both only get p
3205                        flags.  NWC, 2000/11/25 */
3206                     /* Both already have p flags, so do nothing */
3207                 } else {
3208                     NV nv = SvNVX(sv);
3209                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3210                         if (SvIVX(sv) == I_V(nv)) {
3211                             SvNOK_on(sv);
3212                             SvIOK_on(sv);
3213                         } else {
3214                             SvIOK_on(sv);
3215                             /* It had no "." so it must be integer.  */
3216                         }
3217                     } else {
3218                         /* between IV_MAX and NV(UV_MAX).
3219                            Could be slightly > UV_MAX */
3220
3221                         if (numtype & IS_NUMBER_NOT_INT) {
3222                             /* UV and NV both imprecise.  */
3223                         } else {
3224                             UV nv_as_uv = U_V(nv);
3225
3226                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3227                                 SvNOK_on(sv);
3228                                 SvIOK_on(sv);
3229                             } else {
3230                                 SvIOK_on(sv);
3231                             }
3232                         }
3233                     }
3234                 }
3235             }
3236         }
3237 #endif /* NV_PRESERVES_UV */
3238     }
3239     else  {
3240         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3241             report_uninit(sv);
3242         if (SvTYPE(sv) < SVt_NV)
3243             /* Typically the caller expects that sv_any is not NULL now.  */
3244             /* XXX Ilya implies that this is a bug in callers that assume this
3245                and ideally should be fixed.  */
3246             sv_upgrade(sv, SVt_NV);
3247         return 0.0;
3248     }
3249 #if defined(USE_LONG_DOUBLE)
3250     DEBUG_c({
3251         STORE_NUMERIC_LOCAL_SET_STANDARD();
3252         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3253                       PTR2UV(sv), SvNVX(sv));
3254         RESTORE_NUMERIC_LOCAL();
3255     });
3256 #else
3257     DEBUG_c({
3258         STORE_NUMERIC_LOCAL_SET_STANDARD();
3259         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3260                       PTR2UV(sv), SvNVX(sv));
3261         RESTORE_NUMERIC_LOCAL();
3262     });
3263 #endif
3264     return SvNVX(sv);
3265 }
3266
3267 /* asIV(): extract an integer from the string value of an SV.
3268  * Caller must validate PVX  */
3269
3270 STATIC IV
3271 S_asIV(pTHX_ SV *sv)
3272 {
3273     UV value;
3274     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3275
3276     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3277         == IS_NUMBER_IN_UV) {
3278         /* It's definitely an integer */
3279         if (numtype & IS_NUMBER_NEG) {
3280             if (value < (UV)IV_MIN)
3281                 return -(IV)value;
3282         } else {
3283             if (value < (UV)IV_MAX)
3284                 return (IV)value;
3285         }
3286     }
3287     if (!numtype) {
3288         if (ckWARN(WARN_NUMERIC))
3289             not_a_number(sv);
3290     }
3291     return I_V(Atof(SvPVX(sv)));
3292 }
3293
3294 /* asUV(): extract an unsigned integer from the string value of an SV
3295  * Caller must validate PVX  */
3296
3297 STATIC UV
3298 S_asUV(pTHX_ SV *sv)
3299 {
3300     UV value;
3301     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
3302
3303     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3304         == IS_NUMBER_IN_UV) {
3305         /* It's definitely an integer */
3306         if (!(numtype & IS_NUMBER_NEG))
3307             return value;
3308     }
3309     if (!numtype) {
3310         if (ckWARN(WARN_NUMERIC))
3311             not_a_number(sv);
3312     }
3313     return U_V(Atof(SvPVX(sv)));
3314 }
3315
3316 /*
3317 =for apidoc sv_2pv_nolen
3318
3319 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3320 use the macro wrapper C<SvPV_nolen(sv)> instead.
3321 =cut
3322 */
3323
3324 char *
3325 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3326 {
3327     STRLEN n_a;
3328     return sv_2pv(sv, &n_a);
3329 }
3330
3331 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3332  * UV as a string towards the end of buf, and return pointers to start and
3333  * end of it.
3334  *
3335  * We assume that buf is at least TYPE_CHARS(UV) long.
3336  */
3337
3338 static char *
3339 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3340 {
3341     char *ptr = buf + TYPE_CHARS(UV);
3342     char *ebuf = ptr;
3343     int sign;
3344
3345     if (is_uv)
3346         sign = 0;
3347     else if (iv >= 0) {
3348         uv = iv;
3349         sign = 0;
3350     } else {
3351         uv = -iv;
3352         sign = 1;
3353     }
3354     do {
3355         *--ptr = '0' + (char)(uv % 10);
3356     } while (uv /= 10);
3357     if (sign)
3358         *--ptr = '-';
3359     *peob = ebuf;
3360     return ptr;
3361 }
3362
3363 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3364  * this function provided for binary compatibility only
3365  */
3366
3367 char *
3368 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3369 {
3370     return sv_2pv_flags(sv, lp, SV_GMAGIC);
3371 }
3372
3373 /*
3374 =for apidoc sv_2pv_flags
3375
3376 Returns a pointer to the string value of an SV, and sets *lp to its length.
3377 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3378 if necessary.
3379 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3380 usually end up here too.
3381
3382 =cut
3383 */
3384
3385 char *
3386 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3387 {
3388     register char *s;
3389     int olderrno;
3390     SV *tsv, *origsv;
3391     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
3392     char *tmpbuf = tbuf;
3393
3394     if (!sv) {
3395         *lp = 0;
3396         return (char *)"";
3397     }
3398     if (SvGMAGICAL(sv)) {
3399         if (flags & SV_GMAGIC)
3400             mg_get(sv);
3401         if (SvPOKp(sv)) {
3402             *lp = SvCUR(sv);
3403             return SvPVX(sv);
3404         }
3405         if (SvIOKp(sv)) {
3406             if (SvIsUV(sv))
3407                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3408             else
3409                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3410             tsv = Nullsv;
3411             goto tokensave;
3412         }
3413         if (SvNOKp(sv)) {
3414             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3415             tsv = Nullsv;
3416             goto tokensave;
3417         }
3418         if (!SvROK(sv)) {
3419             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3420                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3421                     report_uninit(sv);
3422             }
3423             *lp = 0;
3424             return (char *)"";
3425         }
3426     }
3427     if (SvTHINKFIRST(sv)) {
3428         if (SvROK(sv)) {
3429             SV* tmpstr;
3430             register const char *typestr;
3431             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3432                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3433                 char *pv = SvPV(tmpstr, *lp);
3434                 if (SvUTF8(tmpstr))
3435                     SvUTF8_on(sv);
3436                 else
3437                     SvUTF8_off(sv);
3438                 return pv;
3439             }
3440             origsv = sv;
3441             sv = (SV*)SvRV(sv);
3442             if (!sv)
3443                 typestr = "NULLREF";
3444             else {
3445                 MAGIC *mg;
3446
3447                 switch (SvTYPE(sv)) {
3448                 case SVt_PVMG:
3449                     if ( ((SvFLAGS(sv) &
3450                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3451                           == (SVs_OBJECT|SVs_SMG))
3452                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3453                         const regexp *re = (regexp *)mg->mg_obj;
3454
3455                         if (!mg->mg_ptr) {
3456                             const char *fptr = "msix";
3457                             char reflags[6];
3458                             char ch;
3459                             int left = 0;
3460                             int right = 4;
3461                             char need_newline = 0;
3462                             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3463
3464                             while((ch = *fptr++)) {
3465                                 if(reganch & 1) {
3466                                     reflags[left++] = ch;
3467                                 }
3468                                 else {
3469                                     reflags[right--] = ch;
3470                                 }
3471                                 reganch >>= 1;
3472                             }
3473                             if(left != 4) {
3474                                 reflags[left] = '-';
3475                                 left = 5;
3476                             }
3477
3478                             mg->mg_len = re->prelen + 4 + left;
3479                             /*
3480                              * If /x was used, we have to worry about a regex
3481                              * ending with a comment later being embedded
3482                              * within another regex. If so, we don't want this
3483                              * regex's "commentization" to leak out to the
3484                              * right part of the enclosing regex, we must cap
3485                              * it with a newline.
3486                              *
3487                              * So, if /x was used, we scan backwards from the
3488                              * end of the regex. If we find a '#' before we
3489                              * find a newline, we need to add a newline
3490                              * ourself. If we find a '\n' first (or if we
3491                              * don't find '#' or '\n'), we don't need to add
3492                              * anything.  -jfriedl
3493                              */
3494                             if (PMf_EXTENDED & re->reganch)
3495                             {
3496                                 const char *endptr = re->precomp + re->prelen;
3497                                 while (endptr >= re->precomp)
3498                                 {
3499                                     const char c = *(endptr--);
3500                                     if (c == '\n')
3501                                         break; /* don't need another */
3502                                     if (c == '#') {
3503                                         /* we end while in a comment, so we
3504                                            need a newline */
3505                                         mg->mg_len++; /* save space for it */
3506                                         need_newline = 1; /* note to add it */
3507                                         break;
3508                                     }
3509                                 }
3510                             }
3511
3512                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3513                             Copy("(?", mg->mg_ptr, 2, char);
3514                             Copy(reflags, mg->mg_ptr+2, left, char);
3515                             Copy(":", mg->mg_ptr+left+2, 1, char);
3516                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3517                             if (need_newline)
3518                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3519                             mg->mg_ptr[mg->mg_len - 1] = ')';
3520                             mg->mg_ptr[mg->mg_len] = 0;
3521                         }
3522                         PL_reginterp_cnt += re->program[0].next_off;
3523
3524                         if (re->reganch & ROPT_UTF8)
3525                             SvUTF8_on(origsv);
3526                         else
3527                             SvUTF8_off(origsv);
3528                         *lp = mg->mg_len;
3529                         return mg->mg_ptr;
3530                     }
3531                                         /* Fall through */
3532                 case SVt_NULL:
3533                 case SVt_IV:
3534                 case SVt_NV:
3535                 case SVt_RV:
3536                 case SVt_PV:
3537                 case SVt_PVIV:
3538                 case SVt_PVNV:
3539                 case SVt_PVBM:  typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3540                 case SVt_PVLV:  typestr = SvROK(sv) ? "REF"
3541                                 /* tied lvalues should appear to be
3542                                  * scalars for backwards compatitbility */
3543                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3544                                     ? "SCALAR" : "LVALUE";      break;
3545                 case SVt_PVAV:  typestr = "ARRAY";      break;
3546                 case SVt_PVHV:  typestr = "HASH";       break;
3547                 case SVt_PVCV:  typestr = "CODE";       break;
3548                 case SVt_PVGV:  typestr = "GLOB";       break;
3549                 case SVt_PVFM:  typestr = "FORMAT";     break;
3550                 case SVt_PVIO:  typestr = "IO";         break;
3551                 default:        typestr = "UNKNOWN";    break;
3552                 }
3553                 tsv = NEWSV(0,0);
3554                 if (SvOBJECT(sv)) {
3555                     const char *name = HvNAME_get(SvSTASH(sv));
3556                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3557                                    name ? name : "__ANON__" , typestr, PTR2UV(sv));
3558                 }
3559                 else
3560                     Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3561                 goto tokensaveref;
3562             }
3563             *lp = strlen(typestr);
3564             return (char *)typestr;
3565         }
3566         if (SvREADONLY(sv) && !SvOK(sv)) {
3567             if (ckWARN(WARN_UNINITIALIZED))
3568                 report_uninit(sv);
3569             *lp = 0;
3570             return (char *)"";
3571         }
3572     }
3573     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3574         /* I'm assuming that if both IV and NV are equally valid then
3575            converting the IV is going to be more efficient */
3576         const U32 isIOK = SvIOK(sv);
3577         const U32 isUIOK = SvIsUV(sv);
3578         char buf[TYPE_CHARS(UV)];
3579         char *ebuf, *ptr;
3580
3581         if (SvTYPE(sv) < SVt_PVIV)
3582             sv_upgrade(sv, SVt_PVIV);
3583         if (isUIOK)
3584             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3585         else
3586             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3587         SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
3588         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3589         SvCUR_set(sv, ebuf - ptr);
3590         s = SvEND(sv);
3591         *s = '\0';
3592         if (isIOK)
3593             SvIOK_on(sv);
3594         else
3595             SvIOKp_on(sv);
3596         if (isUIOK)
3597             SvIsUV_on(sv);
3598     }
3599     else if (SvNOKp(sv)) {
3600         if (SvTYPE(sv) < SVt_PVNV)
3601             sv_upgrade(sv, SVt_PVNV);
3602         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3603         SvGROW(sv, NV_DIG + 20);
3604         s = SvPVX(sv);
3605         olderrno = errno;       /* some Xenix systems wipe out errno here */
3606 #ifdef apollo
3607         if (SvNVX(sv) == 0.0)
3608             (void)strcpy(s,"0");
3609         else
3610 #endif /*apollo*/
3611         {
3612             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3613         }
3614         errno = olderrno;
3615 #ifdef FIXNEGATIVEZERO
3616         if (*s == '-' && s[1] == '0' && !s[2])
3617             strcpy(s,"0");
3618 #endif
3619         while (*s) s++;
3620 #ifdef hcx
3621         if (s[-1] == '.')
3622             *--s = '\0';
3623 #endif
3624     }
3625     else {
3626         if (ckWARN(WARN_UNINITIALIZED)
3627             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3628             report_uninit(sv);
3629         *lp = 0;
3630         if (SvTYPE(sv) < SVt_PV)
3631             /* Typically the caller expects that sv_any is not NULL now.  */
3632             sv_upgrade(sv, SVt_PV);
3633         return (char *)"";
3634     }
3635     *lp = s - SvPVX(sv);
3636     SvCUR_set(sv, *lp);
3637     SvPOK_on(sv);
3638     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3639                           PTR2UV(sv),SvPVX(sv)));
3640     return SvPVX(sv);
3641
3642   tokensave:
3643     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3644         /* Sneaky stuff here */
3645
3646       tokensaveref:
3647         if (!tsv)
3648             tsv = newSVpv(tmpbuf, 0);
3649         sv_2mortal(tsv);
3650         *lp = SvCUR(tsv);
3651         return SvPVX(tsv);
3652     }
3653     else {
3654         dVAR;
3655         STRLEN len;
3656         const char *t;
3657
3658         if (tsv) {
3659             sv_2mortal(tsv);
3660             t = SvPVX(tsv);
3661             len = SvCUR(tsv);
3662         }
3663         else {
3664             t = tmpbuf;
3665             len = strlen(tmpbuf);
3666         }
3667 #ifdef FIXNEGATIVEZERO
3668         if (len == 2 && t[0] == '-' && t[1] == '0') {
3669             t = "0";
3670             len = 1;
3671         }
3672 #endif
3673         (void)SvUPGRADE(sv, SVt_PV);
3674         *lp = len;
3675         s = SvGROW(sv, len + 1);
3676         SvCUR_set(sv, len);
3677         SvPOKp_on(sv);
3678         return strcpy(s, t);
3679     }
3680 }
3681
3682 /*
3683 =for apidoc sv_copypv
3684
3685 Copies a stringified representation of the source SV into the
3686 destination SV.  Automatically performs any necessary mg_get and
3687 coercion of numeric values into strings.  Guaranteed to preserve
3688 UTF-8 flag even from overloaded objects.  Similar in nature to
3689 sv_2pv[_flags] but operates directly on an SV instead of just the
3690 string.  Mostly uses sv_2pv_flags to do its work, except when that
3691 would lose the UTF-8'ness of the PV.
3692
3693 =cut
3694 */
3695
3696 void
3697 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3698 {
3699     STRLEN len;
3700     char *s;
3701     s = SvPV(ssv,len);
3702     sv_setpvn(dsv,s,len);
3703     if (SvUTF8(ssv))
3704         SvUTF8_on(dsv);
3705     else
3706         SvUTF8_off(dsv);
3707 }
3708
3709 /*
3710 =for apidoc sv_2pvbyte_nolen
3711
3712 Return a pointer to the byte-encoded representation of the SV.
3713 May cause the SV to be downgraded from UTF-8 as a side-effect.
3714
3715 Usually accessed via the C<SvPVbyte_nolen> macro.
3716
3717 =cut
3718 */
3719
3720 char *
3721 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3722 {
3723     STRLEN n_a;
3724     return sv_2pvbyte(sv, &n_a);
3725 }
3726
3727 /*
3728 =for apidoc sv_2pvbyte
3729
3730 Return a pointer to the byte-encoded representation of the SV, and set *lp
3731 to its length.  May cause the SV to be downgraded from UTF-8 as a
3732 side-effect.
3733
3734 Usually accessed via the C<SvPVbyte> macro.
3735
3736 =cut
3737 */
3738
3739 char *
3740 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3741 {
3742     sv_utf8_downgrade(sv,0);
3743     return SvPV(sv,*lp);
3744 }
3745
3746 /*
3747 =for apidoc sv_2pvutf8_nolen
3748
3749 Return a pointer to the UTF-8-encoded representation of the SV.
3750 May cause the SV to be upgraded to UTF-8 as a side-effect.
3751
3752 Usually accessed via the C<SvPVutf8_nolen> macro.
3753
3754 =cut
3755 */
3756
3757 char *
3758 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3759 {
3760     STRLEN n_a;
3761     return sv_2pvutf8(sv, &n_a);
3762 }
3763
3764 /*
3765 =for apidoc sv_2pvutf8
3766
3767 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3768 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3769
3770 Usually accessed via the C<SvPVutf8> macro.
3771
3772 =cut
3773 */
3774
3775 char *
3776 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3777 {
3778     sv_utf8_upgrade(sv);
3779     return SvPV(sv,*lp);
3780 }
3781
3782 /*
3783 =for apidoc sv_2bool
3784
3785 This function is only called on magical items, and is only used by
3786 sv_true() or its macro equivalent.
3787
3788 =cut
3789 */
3790
3791 bool
3792 Perl_sv_2bool(pTHX_ register SV *sv)
3793 {
3794     if (SvGMAGICAL(sv))
3795         mg_get(sv);
3796
3797     if (!SvOK(sv))
3798         return 0;
3799     if (SvROK(sv)) {
3800         SV* tmpsv;
3801         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3802                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3803             return (bool)SvTRUE(tmpsv);
3804       return SvRV(sv) != 0;
3805     }
3806     if (SvPOKp(sv)) {
3807         register XPV* Xpvtmp;
3808         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3809                 (*sv->sv_u.svu_pv > '0' ||
3810                 Xpvtmp->xpv_cur > 1 ||
3811                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3812             return 1;
3813         else
3814             return 0;
3815     }
3816     else {
3817         if (SvIOKp(sv))
3818             return SvIVX(sv) != 0;
3819         else {
3820             if (SvNOKp(sv))
3821                 return SvNVX(sv) != 0.0;
3822             else
3823                 return FALSE;
3824         }
3825     }
3826 }
3827
3828 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3829  * this function provided for binary compatibility only
3830  */
3831
3832
3833 STRLEN
3834 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3835 {
3836     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3837 }
3838
3839 /*
3840 =for apidoc sv_utf8_upgrade
3841
3842 Converts the PV of an SV to its UTF-8-encoded form.
3843 Forces the SV to string form if it is not already.
3844 Always sets the SvUTF8 flag to avoid future validity checks even
3845 if all the bytes have hibit clear.
3846
3847 This is not as a general purpose byte encoding to Unicode interface:
3848 use the Encode extension for that.
3849
3850 =for apidoc sv_utf8_upgrade_flags
3851
3852 Converts the PV of an SV to its UTF-8-encoded form.
3853 Forces the SV to string form if it is not already.
3854 Always sets the SvUTF8 flag to avoid future validity checks even
3855 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3856 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3857 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3858
3859 This is not as a general purpose byte encoding to Unicode interface:
3860 use the Encode extension for that.
3861
3862 =cut
3863 */
3864
3865 STRLEN
3866 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3867 {
3868     if (sv == &PL_sv_undef)
3869         return 0;
3870     if (!SvPOK(sv)) {
3871         STRLEN len = 0;
3872         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3873             (void) sv_2pv_flags(sv,&len, flags);
3874             if (SvUTF8(sv))
3875                 return len;
3876         } else {
3877             (void) SvPV_force(sv,len);
3878         }
3879     }
3880
3881     if (SvUTF8(sv)) {
3882         return SvCUR(sv);
3883     }
3884
3885     if (SvIsCOW(sv)) {
3886         sv_force_normal_flags(sv, 0);
3887     }
3888
3889     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3890         sv_recode_to_utf8(sv, PL_encoding);
3891     else { /* Assume Latin-1/EBCDIC */
3892         /* This function could be much more efficient if we
3893          * had a FLAG in SVs to signal if there are any hibit
3894          * chars in the PV.  Given that there isn't such a flag
3895          * make the loop as fast as possible. */
3896         U8 *s = (U8 *) SvPVX(sv);
3897         U8 *e = (U8 *) SvEND(sv);
3898         U8 *t = s;
3899         int hibit = 0;
3900
3901         while (t < e) {
3902             U8 ch = *t++;
3903             if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3904                 break;
3905         }
3906         if (hibit) {
3907             STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3908             s = bytes_to_utf8((U8*)s, &len);
3909
3910             SvPV_free(sv); /* No longer using what was there before. */
3911
3912             SvPV_set(sv, (char*)s);
3913             SvCUR_set(sv, len - 1);
3914             SvLEN_set(sv, len); /* No longer know the real size. */
3915         }
3916         /* Mark as UTF-8 even if no hibit - saves scanning loop */
3917         SvUTF8_on(sv);
3918     }
3919     return SvCUR(sv);
3920 }
3921
3922 /*
3923 =for apidoc sv_utf8_downgrade
3924
3925 Attempts to convert the PV of an SV from characters to bytes.
3926 If the PV contains a character beyond byte, this conversion will fail;
3927 in this case, either returns false or, if C<fail_ok> is not
3928 true, croaks.
3929
3930 This is not as a general purpose Unicode to byte encoding interface:
3931 use the Encode extension for that.
3932
3933 =cut
3934 */
3935
3936 bool
3937 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3938 {
3939     if (SvPOKp(sv) && SvUTF8(sv)) {
3940         if (SvCUR(sv)) {
3941             U8 *s;
3942             STRLEN len;
3943
3944             if (SvIsCOW(sv)) {
3945                 sv_force_normal_flags(sv, 0);
3946             }
3947             s = (U8 *) SvPV(sv, len);
3948             if (!utf8_to_bytes(s, &len)) {
3949                 if (fail_ok)
3950                     return FALSE;
3951                 else {
3952                     if (PL_op)
3953                         Perl_croak(aTHX_ "Wide character in %s",
3954                                    OP_DESC(PL_op));
3955                     else
3956                         Perl_croak(aTHX_ "Wide character");
3957                 }
3958             }
3959             SvCUR_set(sv, len);
3960         }
3961     }
3962     SvUTF8_off(sv);
3963     return TRUE;
3964 }
3965
3966 /*
3967 =for apidoc sv_utf8_encode
3968
3969 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3970 flag off so that it looks like octets again.
3971
3972 =cut
3973 */
3974
3975 void
3976 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3977 {
3978     (void) sv_utf8_upgrade(sv);
3979     if (SvIsCOW(sv)) {
3980         sv_force_normal_flags(sv, 0);
3981     }
3982     if (SvREADONLY(sv)) {
3983         Perl_croak(aTHX_ PL_no_modify);
3984     }
3985     SvUTF8_off(sv);
3986 }
3987
3988 /*
3989 =for apidoc sv_utf8_decode
3990
3991 If the PV of the SV is an octet sequence in UTF-8
3992 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3993 so that it looks like a character. If the PV contains only single-byte
3994 characters, the C<SvUTF8> flag stays being off.
3995 Scans PV for validity and returns false if the PV is invalid UTF-8.
3996
3997 =cut
3998 */
3999
4000 bool
4001 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4002 {
4003     if (SvPOKp(sv)) {
4004         U8 *c;
4005         U8 *e;
4006
4007         /* The octets may have got themselves encoded - get them back as
4008          * bytes
4009          */
4010         if (!sv_utf8_downgrade(sv, TRUE))
4011             return FALSE;
4012
4013         /* it is actually just a matter of turning the utf8 flag on, but
4014          * we want to make sure everything inside is valid utf8 first.
4015          */
4016         c = (U8 *) SvPVX(sv);
4017         if (!is_utf8_string(c, SvCUR(sv)+1))
4018             return FALSE;
4019         e = (U8 *) SvEND(sv);
4020         while (c < e) {
4021             U8 ch = *c++;
4022             if (!UTF8_IS_INVARIANT(ch)) {
4023                 SvUTF8_on(sv);
4024                 break;
4025             }
4026         }
4027     }
4028     return TRUE;
4029 }
4030
4031 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4032  * this function provided for binary compatibility only
4033  */
4034
4035 void
4036 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4037 {
4038     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4039 }
4040
4041 /*
4042 =for apidoc sv_setsv
4043
4044 Copies the contents of the source SV C<ssv> into the destination SV
4045 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
4046 function if the source SV needs to be reused. Does not handle 'set' magic.
4047 Loosely speaking, it performs a copy-by-value, obliterating any previous
4048 content of the destination.
4049
4050 You probably want to use one of the assortment of wrappers, such as
4051 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4052 C<SvSetMagicSV_nosteal>.
4053
4054 =for apidoc sv_setsv_flags
4055
4056 Copies the contents of the source SV C<ssv> into the destination SV
4057 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
4058 function if the source SV needs to be reused. Does not handle 'set' magic.
4059 Loosely speaking, it performs a copy-by-value, obliterating any previous
4060 content of the destination.
4061 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4062 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4063 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4064 and C<sv_setsv_nomg> are implemented in terms of this function.
4065
4066 You probably want to use one of the assortment of wrappers, such as
4067 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4068 C<SvSetMagicSV_nosteal>.
4069
4070 This is the primary function for copying scalars, and most other
4071 copy-ish functions and macros use this underneath.
4072
4073 =cut
4074 */
4075
4076 void
4077 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4078 {
4079     register U32 sflags;
4080     register int dtype;
4081     register int stype;
4082
4083     if (sstr == dstr)
4084         return;
4085     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4086     if (!sstr)
4087         sstr = &PL_sv_undef;
4088     stype = SvTYPE(sstr);
4089     dtype = SvTYPE(dstr);
4090
4091     SvAMAGIC_off(dstr);
4092     if ( SvVOK(dstr) )
4093     {
4094         /* need to nuke the magic */
4095         mg_free(dstr);
4096         SvRMAGICAL_off(dstr);
4097     }
4098
4099     /* There's a lot of redundancy below but we're going for speed here */
4100
4101     switch (stype) {
4102     case SVt_NULL:
4103       undef_sstr:
4104         if (dtype != SVt_PVGV) {
4105             (void)SvOK_off(dstr);
4106             return;
4107         }
4108         break;
4109     case SVt_IV:
4110         if (SvIOK(sstr)) {
4111             switch (dtype) {
4112             case SVt_NULL:
4113                 sv_upgrade(dstr, SVt_IV);
4114                 break;
4115             case SVt_NV:
4116                 sv_upgrade(dstr, SVt_PVNV);
4117                 break;
4118             case SVt_RV:
4119             case SVt_PV:
4120                 sv_upgrade(dstr, SVt_PVIV);
4121                 break;
4122             }
4123             (void)SvIOK_only(dstr);
4124             SvIV_set(dstr,  SvIVX(sstr));
4125             if (SvIsUV(sstr))
4126                 SvIsUV_on(dstr);
4127             if (SvTAINTED(sstr))
4128                 SvTAINT(dstr);
4129             return;
4130         }
4131         goto undef_sstr;
4132
4133     case SVt_NV:
4134         if (SvNOK(sstr)) {
4135             switch (dtype) {
4136             case SVt_NULL:
4137             case SVt_IV:
4138                 sv_upgrade(dstr, SVt_NV);
4139                 break;
4140             case SVt_RV:
4141             case SVt_PV:
4142             case SVt_PVIV:
4143                 sv_upgrade(dstr, SVt_PVNV);
4144                 break;
4145             }
4146             SvNV_set(dstr, SvNVX(sstr));
4147             (void)SvNOK_only(dstr);
4148             if (SvTAINTED(sstr))
4149                 SvTAINT(dstr);
4150             return;
4151         }
4152         goto undef_sstr;
4153
4154     case SVt_RV:
4155         if (dtype < SVt_RV)
4156             sv_upgrade(dstr, SVt_RV);
4157         else if (dtype == SVt_PVGV &&
4158                  SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4159             sstr = SvRV(sstr);
4160             if (sstr == dstr) {
4161                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4162                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4163                 {
4164                     GvIMPORTED_on(dstr);
4165                 }
4166                 GvMULTI_on(dstr);
4167                 return;
4168             }
4169             goto glob_assign;
4170         }
4171         break;
4172     case SVt_PVFM:
4173 #ifdef PERL_COPY_ON_WRITE
4174         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4175             if (dtype < SVt_PVIV)
4176                 sv_upgrade(dstr, SVt_PVIV);
4177             break;
4178         }
4179         /* Fall through */
4180 #endif
4181     case SVt_PV:
4182         if (dtype < SVt_PV)
4183             sv_upgrade(dstr, SVt_PV);
4184         break;
4185     case SVt_PVIV:
4186         if (dtype < SVt_PVIV)
4187             sv_upgrade(dstr, SVt_PVIV);
4188         break;
4189     case SVt_PVNV:
4190         if (dtype < SVt_PVNV)
4191             sv_upgrade(dstr, SVt_PVNV);
4192         break;
4193     case SVt_PVAV:
4194     case SVt_PVHV:
4195     case SVt_PVCV:
4196     case SVt_PVIO:
4197         {
4198         const char * const type = sv_reftype(sstr,0);
4199         if (PL_op)
4200             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4201         else
4202             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4203         }
4204         break;
4205
4206     case SVt_PVGV:
4207         if (dtype <= SVt_PVGV) {
4208   glob_assign:
4209             if (dtype != SVt_PVGV) {
4210                 const char * const name = GvNAME(sstr);
4211                 const STRLEN len = GvNAMELEN(sstr);
4212                 /* don't upgrade SVt_PVLV: it can hold a glob */
4213                 if (dtype != SVt_PVLV)
4214                     sv_upgrade(dstr, SVt_PVGV);
4215                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4216                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4217                 GvNAME(dstr) = savepvn(name, len);
4218                 GvNAMELEN(dstr) = len;
4219                 SvFAKE_on(dstr);        /* can coerce to non-glob */
4220             }
4221             /* ahem, death to those who redefine active sort subs */
4222             else if (PL_curstackinfo->si_type == PERLSI_SORT
4223                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4224                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4225                       GvNAME(dstr));
4226
4227 #ifdef GV_UNIQUE_CHECK
4228                 if (GvUNIQUE((GV*)dstr)) {
4229                     Perl_croak(aTHX_ PL_no_modify);
4230                 }
4231 #endif
4232
4233             (void)SvOK_off(dstr);
4234             GvINTRO_off(dstr);          /* one-shot flag */
4235             gp_free((GV*)dstr);
4236             GvGP(dstr) = gp_ref(GvGP(sstr));
4237             if (SvTAINTED(sstr))
4238                 SvTAINT(dstr);
4239             if (GvIMPORTED(dstr) != GVf_IMPORTED
4240                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4241             {
4242                 GvIMPORTED_on(dstr);
4243             }
4244             GvMULTI_on(dstr);
4245             return;
4246         }
4247         /* FALL THROUGH */
4248
4249     default:
4250         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4251             mg_get(sstr);
4252             if ((int)SvTYPE(sstr) != stype) {
4253                 stype = SvTYPE(sstr);
4254                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4255                     goto glob_assign;
4256             }
4257         }
4258         if (stype == SVt_PVLV)
4259             (void)SvUPGRADE(dstr, SVt_PVNV);
4260         else
4261             (void)SvUPGRADE(dstr, (U32)stype);
4262     }
4263
4264     sflags = SvFLAGS(sstr);
4265
4266     if (sflags & SVf_ROK) {
4267         if (dtype >= SVt_PV) {
4268             if (dtype == SVt_PVGV) {
4269                 SV *sref = SvREFCNT_inc(SvRV(sstr));
4270                 SV *dref = 0;
4271                 const int intro = GvINTRO(dstr);
4272
4273 #ifdef GV_UNIQUE_CHECK
4274                 if (GvUNIQUE((GV*)dstr)) {
4275                     Perl_croak(aTHX_ PL_no_modify);
4276                 }
4277 #endif
4278
4279                 if (intro) {
4280                     GvINTRO_off(dstr);  /* one-shot flag */
4281                     GvLINE(dstr) = CopLINE(PL_curcop);
4282                     GvEGV(dstr) = (GV*)dstr;
4283                 }
4284                 GvMULTI_on(dstr);
4285                 switch (SvTYPE(sref)) {
4286                 case SVt_PVAV:
4287                     if (intro)
4288                         SAVEGENERICSV(GvAV(dstr));
4289                     else
4290                         dref = (SV*)GvAV(dstr);
4291                     GvAV(dstr) = (AV*)sref;
4292                     if (!GvIMPORTED_AV(dstr)
4293                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4294                     {
4295                         GvIMPORTED_AV_on(dstr);
4296                     }
4297                     break;
4298                 case SVt_PVHV:
4299                     if (intro)
4300                         SAVEGENERICSV(GvHV(dstr));
4301                     else
4302                         dref = (SV*)GvHV(dstr);
4303                     GvHV(dstr) = (HV*)sref;
4304                     if (!GvIMPORTED_HV(dstr)
4305                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4306                     {
4307                         GvIMPORTED_HV_on(dstr);
4308                     }
4309                     break;
4310                 case SVt_PVCV:
4311                     if (intro) {
4312                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4313                             SvREFCNT_dec(GvCV(dstr));
4314                             GvCV(dstr) = Nullcv;
4315                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4316                             PL_sub_generation++;
4317                         }
4318                         SAVEGENERICSV(GvCV(dstr));
4319                     }
4320                     else
4321                         dref = (SV*)GvCV(dstr);
4322                     if (GvCV(dstr) != (CV*)sref) {
4323                         CV* cv = GvCV(dstr);
4324                         if (cv) {
4325                             if (!GvCVGEN((GV*)dstr) &&
4326                                 (CvROOT(cv) || CvXSUB(cv)))
4327                             {
4328                                 /* ahem, death to those who redefine
4329                                  * active sort subs */
4330                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4331                                       PL_sortcop == CvSTART(cv))
4332                                     Perl_croak(aTHX_
4333                                     "Can't redefine active sort subroutine %s",
4334                                           GvENAME((GV*)dstr));
4335                                 /* Redefining a sub - warning is mandatory if
4336                                    it was a const and its value changed. */
4337                                 if (ckWARN(WARN_REDEFINE)
4338                                     || (CvCONST(cv)
4339                                         && (!CvCONST((CV*)sref)
4340                                             || sv_cmp(cv_const_sv(cv),
4341                                                       cv_const_sv((CV*)sref)))))
4342                                 {
4343                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4344                                         CvCONST(cv)
4345                                         ? "Constant subroutine %s::%s redefined"
4346                                         : "Subroutine %s::%s redefined",
4347                                         HvNAME_get(GvSTASH((GV*)dstr)),
4348                                         GvENAME((GV*)dstr));
4349                                 }
4350                             }
4351                             if (!intro)
4352                                 cv_ckproto(cv, (GV*)dstr,
4353                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
4354                         }
4355                         GvCV(dstr) = (CV*)sref;
4356                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4357                         GvASSUMECV_on(dstr);
4358                         PL_sub_generation++;
4359                     }
4360                     if (!GvIMPORTED_CV(dstr)
4361                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4362                     {
4363                         GvIMPORTED_CV_on(dstr);
4364                     }
4365                     break;
4366                 case SVt_PVIO:
4367                     if (intro)
4368                         SAVEGENERICSV(GvIOp(dstr));
4369                     else
4370                         dref = (SV*)GvIOp(dstr);
4371                     GvIOp(dstr) = (IO*)sref;
4372                     break;
4373                 case SVt_PVFM:
4374                     if (intro)
4375                         SAVEGENERICSV(GvFORM(dstr));
4376                     else
4377                         dref = (SV*)GvFORM(dstr);
4378                     GvFORM(dstr) = (CV*)sref;
4379                     break;
4380                 default:
4381                     if (intro)
4382                         SAVEGENERICSV(GvSV(dstr));
4383                     else
4384                         dref = (SV*)GvSV(dstr);
4385                     GvSV(dstr) = sref;
4386                     if (!GvIMPORTED_SV(dstr)
4387                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4388                     {
4389                         GvIMPORTED_SV_on(dstr);
4390                     }
4391                     break;
4392                 }
4393                 if (dref)
4394                     SvREFCNT_dec(dref);
4395                 if (SvTAINTED(sstr))
4396                     SvTAINT(dstr);
4397                 return;
4398             }
4399             if (SvPVX(dstr)) {
4400                 SvPV_free(dstr);
4401                 SvLEN_set(dstr, 0);
4402                 SvCUR_set(dstr, 0);
4403             }
4404         }
4405         (void)SvOK_off(dstr);
4406         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4407         SvROK_on(dstr);
4408         if (sflags & SVp_NOK) {
4409             SvNOKp_on(dstr);
4410             /* Only set the public OK flag if the source has public OK.  */
4411             if (sflags & SVf_NOK)
4412                 SvFLAGS(dstr) |= SVf_NOK;
4413             SvNV_set(dstr, SvNVX(sstr));
4414         }
4415         if (sflags & SVp_IOK) {
4416             (void)SvIOKp_on(dstr);
4417             if (sflags & SVf_IOK)
4418                 SvFLAGS(dstr) |= SVf_IOK;
4419             if (sflags & SVf_IVisUV)
4420                 SvIsUV_on(dstr);
4421             SvIV_set(dstr, SvIVX(sstr));
4422         }
4423         if (SvAMAGIC(sstr)) {
4424             SvAMAGIC_on(dstr);
4425         }
4426     }
4427     else if (sflags & SVp_POK) {
4428         bool isSwipe = 0;
4429
4430         /*
4431          * Check to see if we can just swipe the string.  If so, it's a
4432          * possible small lose on short strings, but a big win on long ones.
4433          * It might even be a win on short strings if SvPVX(dstr)
4434          * has to be allocated and SvPVX(sstr) has to be freed.
4435          */
4436
4437         /* Whichever path we take through the next code, we want this true,
4438            and doing it now facilitates the COW check.  */
4439         (void)SvPOK_only(dstr);
4440
4441         if (
4442 #ifdef PERL_COPY_ON_WRITE
4443             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4444             &&
4445 #endif
4446             !(isSwipe =
4447                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4448                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4449                  (!(flags & SV_NOSTEAL)) &&
4450                                         /* and we're allowed to steal temps */
4451                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4452                  SvLEN(sstr)    &&        /* and really is a string */
4453                                 /* and won't be needed again, potentially */
4454               !(PL_op && PL_op->op_type == OP_AASSIGN))
4455 #ifdef PERL_COPY_ON_WRITE
4456             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4457                  && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4458                  && SvTYPE(sstr) >= SVt_PVIV)
4459 #endif
4460             ) {
4461             /* Failed the swipe test, and it's not a shared hash key either.
4462                Have to copy the string.  */
4463             STRLEN len = SvCUR(sstr);
4464             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4465             Move(SvPVX(sstr),SvPVX(dstr),len,char);
4466             SvCUR_set(dstr, len);
4467             *SvEND(dstr) = '\0';
4468         } else {
4469             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4470                be true in here.  */
4471 #ifdef PERL_COPY_ON_WRITE
4472             /* Either it's a shared hash key, or it's suitable for
4473                copy-on-write or we can swipe the string.  */
4474             if (DEBUG_C_TEST) {
4475                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4476                 sv_dump(sstr);
4477                 sv_dump(dstr);
4478             }
4479             if (!isSwipe) {
4480                 /* I believe I should acquire a global SV mutex if
4481                    it's a COW sv (not a shared hash key) to stop
4482                    it going un copy-on-write.
4483                    If the source SV has gone un copy on write between up there
4484                    and down here, then (assert() that) it is of the correct
4485                    form to make it copy on write again */
4486                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4487                     != (SVf_FAKE | SVf_READONLY)) {
4488                     SvREADONLY_on(sstr);
4489                     SvFAKE_on(sstr);
4490                     /* Make the source SV into a loop of 1.
4491                        (about to become 2) */
4492                     SV_COW_NEXT_SV_SET(sstr, sstr);
4493                 }
4494             }
4495 #endif
4496             /* Initial code is common.  */
4497             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
4498                 if (SvOOK(dstr)) {
4499                     SvFLAGS(dstr) &= ~SVf_OOK;
4500                     Safefree(SvPVX(dstr) - SvIVX(dstr));
4501                 }
4502                 else if (SvLEN(dstr))
4503                     Safefree(SvPVX(dstr));
4504             }
4505
4506 #ifdef PERL_COPY_ON_WRITE
4507             if (!isSwipe) {
4508                 /* making another shared SV.  */
4509                 STRLEN cur = SvCUR(sstr);
4510                 STRLEN len = SvLEN(sstr);
4511                 assert (SvTYPE(dstr) >= SVt_PVIV);
4512                 if (len) {
4513                     /* SvIsCOW_normal */
4514                     /* splice us in between source and next-after-source.  */
4515                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4516                     SV_COW_NEXT_SV_SET(sstr, dstr);
4517                     SvPV_set(dstr, SvPVX(sstr));
4518                 } else {
4519                     /* SvIsCOW_shared_hash */
4520                     UV hash = SvUVX(sstr);
4521                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4522                                           "Copy on write: Sharing hash\n"));
4523                     SvPV_set(dstr,
4524                              sharepvn(SvPVX(sstr),
4525                                       (sflags & SVf_UTF8?-cur:cur), hash));
4526                     SvUV_set(dstr, hash);
4527                 }
4528                 SvLEN_set(dstr, len);
4529                 SvCUR_set(dstr, cur);
4530                 SvREADONLY_on(dstr);
4531                 SvFAKE_on(dstr);
4532                 /* Relesase a global SV mutex.  */
4533             }
4534             else
4535 #endif
4536                 {       /* Passes the swipe test.  */
4537                 SvPV_set(dstr, SvPVX(sstr));
4538                 SvLEN_set(dstr, SvLEN(sstr));
4539                 SvCUR_set(dstr, SvCUR(sstr));
4540
4541                 SvTEMP_off(dstr);
4542                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4543                 SvPV_set(sstr, Nullch);
4544                 SvLEN_set(sstr, 0);
4545                 SvCUR_set(sstr, 0);
4546                 SvTEMP_off(sstr);
4547             }
4548         }
4549         if (sflags & SVf_UTF8)
4550             SvUTF8_on(dstr);
4551         /*SUPPRESS 560*/
4552         if (sflags & SVp_NOK) {
4553             SvNOKp_on(dstr);
4554             if (sflags & SVf_NOK)
4555                 SvFLAGS(dstr) |= SVf_NOK;
4556             SvNV_set(dstr, SvNVX(sstr));
4557         }
4558         if (sflags & SVp_IOK) {
4559             (void)SvIOKp_on(dstr);
4560             if (sflags & SVf_IOK)
4561                 SvFLAGS(dstr) |= SVf_IOK;
4562             if (sflags & SVf_IVisUV)
4563                 SvIsUV_on(dstr);
4564             SvIV_set(dstr, SvIVX(sstr));
4565         }
4566         if (SvVOK(sstr)) {
4567             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4568             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4569                         smg->mg_ptr, smg->mg_len);
4570             SvRMAGICAL_on(dstr);
4571         }
4572     }
4573     else if (sflags & SVp_IOK) {
4574         if (sflags & SVf_IOK)
4575             (void)SvIOK_only(dstr);
4576         else {
4577             (void)SvOK_off(dstr);
4578             (void)SvIOKp_on(dstr);
4579         }
4580         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4581         if (sflags & SVf_IVisUV)
4582             SvIsUV_on(dstr);
4583         SvIV_set(dstr, SvIVX(sstr));
4584         if (sflags & SVp_NOK) {
4585             if (sflags & SVf_NOK)
4586                 (void)SvNOK_on(dstr);
4587             else
4588                 (void)SvNOKp_on(dstr);
4589             SvNV_set(dstr, SvNVX(sstr));
4590         }
4591     }
4592     else if (sflags & SVp_NOK) {
4593         if (sflags & SVf_NOK)
4594             (void)SvNOK_only(dstr);
4595         else {
4596             (void)SvOK_off(dstr);
4597             SvNOKp_on(dstr);
4598         }
4599         SvNV_set(dstr, SvNVX(sstr));
4600     }
4601     else {
4602         if (dtype == SVt_PVGV) {
4603             if (ckWARN(WARN_MISC))
4604                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4605         }
4606         else
4607             (void)SvOK_off(dstr);
4608     }
4609     if (SvTAINTED(sstr))
4610         SvTAINT(dstr);
4611 }
4612
4613 /*
4614 =for apidoc sv_setsv_mg
4615
4616 Like C<sv_setsv>, but also handles 'set' magic.
4617
4618 =cut
4619 */
4620
4621 void
4622 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4623 {
4624     sv_setsv(dstr,sstr);
4625     SvSETMAGIC(dstr);
4626 }
4627
4628 #ifdef PERL_COPY_ON_WRITE
4629 SV *
4630 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4631 {
4632     STRLEN cur = SvCUR(sstr);
4633     STRLEN len = SvLEN(sstr);
4634     register char *new_pv;
4635
4636     if (DEBUG_C_TEST) {
4637         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4638                       sstr, dstr);
4639         sv_dump(sstr);
4640         if (dstr)
4641                     sv_dump(dstr);
4642     }
4643
4644     if (dstr) {
4645         if (SvTHINKFIRST(dstr))
4646             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4647         else if (SvPVX(dstr))
4648             Safefree(SvPVX(dstr));
4649     }
4650     else
4651         new_SV(dstr);
4652     (void)SvUPGRADE (dstr, SVt_PVIV);
4653
4654     assert (SvPOK(sstr));
4655     assert (SvPOKp(sstr));
4656     assert (!SvIOK(sstr));
4657     assert (!SvIOKp(sstr));
4658     assert (!SvNOK(sstr));
4659     assert (!SvNOKp(sstr));
4660
4661     if (SvIsCOW(sstr)) {
4662
4663         if (SvLEN(sstr) == 0) {
4664             /* source is a COW shared hash key.  */
4665             UV hash = SvUVX(sstr);
4666             DEBUG_C(PerlIO_printf(Perl_debug_log,
4667                                   "Fast copy on write: Sharing hash\n"));
4668             SvUV_set(dstr, hash);
4669             new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4670             goto common_exit;
4671         }
4672         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4673     } else {
4674         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4675         (void)SvUPGRADE (sstr, SVt_PVIV);
4676         SvREADONLY_on(sstr);
4677         SvFAKE_on(sstr);
4678         DEBUG_C(PerlIO_printf(Perl_debug_log,
4679                               "Fast copy on write: Converting sstr to COW\n"));
4680         SV_COW_NEXT_SV_SET(dstr, sstr);
4681     }
4682     SV_COW_NEXT_SV_SET(sstr, dstr);
4683     new_pv = SvPVX(sstr);
4684
4685   common_exit:
4686     SvPV_set(dstr, new_pv);
4687     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4688     if (SvUTF8(sstr))
4689         SvUTF8_on(dstr);
4690     SvLEN_set(dstr, len);
4691     SvCUR_set(dstr, cur);
4692     if (DEBUG_C_TEST) {
4693         sv_dump(dstr);
4694     }
4695     return dstr;
4696 }
4697 #endif
4698
4699 /*
4700 =for apidoc sv_setpvn
4701
4702 Copies a string into an SV.  The C<len> parameter indicates the number of
4703 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4704 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4705
4706 =cut
4707 */
4708
4709 void
4710 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4711 {
4712     register char *dptr;
4713
4714     SV_CHECK_THINKFIRST_COW_DROP(sv);
4715     if (!ptr) {
4716         (void)SvOK_off(sv);
4717         return;
4718     }
4719     else {
4720         /* len is STRLEN which is unsigned, need to copy to signed */
4721         const IV iv = len;
4722         if (iv < 0)
4723             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4724     }
4725     (void)SvUPGRADE(sv, SVt_PV);
4726
4727     SvGROW(sv, len + 1);
4728     dptr = SvPVX(sv);
4729     Move(ptr,dptr,len,char);
4730     dptr[len] = '\0';
4731     SvCUR_set(sv, len);
4732     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4733     SvTAINT(sv);
4734 }
4735
4736 /*
4737 =for apidoc sv_setpvn_mg
4738
4739 Like C<sv_setpvn>, but also handles 'set' magic.
4740
4741 =cut