sv.c

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