sv.c

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