sv.c

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