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