sv.c

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