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