sv.c

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